0
J'exporte des données de calendrier Outlook à partir d'un calendrier partagé vers Excel. Tout fonctionne parfaitement, sauf que mon code exporte les éléments récurrents avec leur date de publication originale de la série et non pour chaque instance.Outlook Exporter un calendrier partagé vers Excel - Evénements récurrents ne pas exporter correctement
J'ai vu un message connexe "Comment afficher la date de début d'une INSTANCE d'une série récurrente?" mais je ne pouvais pas le faire fonctionner - je pense que mes yeux sont buggy maintenant et j'ai besoin d'aide ...
Merci.
Sub Export_Calendar_Final()
Const SCRIPT_NAME = "Export Calendar to Excel"
Const xlAscending = 1
Const xlYes = 1
Dim olkFld As Object, _
olkLst As Object, _
olkRes As Object, _
olkApt As Object, _
olkRec As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
lngRow As Long, _
lngCnt As Long, _
strFil As String, _
strLst As String, _
strDat As String, _
datBeg As Date, _
datEnd As Date, _
arrTmp As Variant
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("John Doe")
Dim CalendarFolder As Outlook.Folder
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
Dim CalendarItem As Outlook.AppointmentItem
Set CalendarItem = CalendarFolder.Items(1)
CalendarFolder.Items.Sort "[Start]"
CalendarFolder.Items.IncludeRecurrences = True
datBeg = DateAdd("d", -14, Date)
datEnd = Date
Dim RestictStr As String
RestrictStr = "[Start] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [Start] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'"
Set olkRes = CalendarFolder.Items.Restrict(RestrictStr)
strFil = "I:\Weekly Sales Order Reports\Sales Calendar Export\John Doe.xlsx" 'change folder and file name as needed
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.Worksheets(1)
'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Start Date"
.Cells(1, 3) = "Start Time"
.Cells(1, 4) = "End Date"
.Cells(1, 5) = "End Time"
.Cells(1, 6) = "All day event"
.Cells(1, 7) = "Required Attendees"
.Cells(1, 8) = "Categories"
.Cells(1, 9) = "Hours"
.Cells(1, 10) = "Location"
.Cells(1, 11) = "Mailbox"
End With
lngRow = 2
For Each olkApt In olkRes
'Only export appointments
If olkApt.Class = olAppointment Then
strLst = ""
For Each olkRec In olkApt.Recipients
strLst = strLst & olkRec.Name & ", "
Next
If strLst <> "" Then strLst = Left(strLst, Len(strLst) - 2)
'Add a row for each field in the message you want to export
excWks.Cells(lngRow, 1) = olkApt.Subject
excWks.Cells(lngRow, 2) = Format(olkApt.Start, "mm/dd/yyyy")
excWks.Cells(lngRow, 3) = Format(olkApt.Start, "hh:nn:ss")
excWks.Cells(lngRow, 4) = Format(olkApt.End, "mm/dd/yyyy")
excWks.Cells(lngRow, 5) = Format(olkApt.End, "hh:nn:ss")
excWks.Cells(lngRow, 6) = olkApt.AllDayEvent = bolAllDay
excWks.Cells(lngRow, 7) = strLst
excWks.Cells(lngRow, 8) = olkApt.Categories
excWks.Cells(lngRow, 9) = DateDiff("n", olkApt.Start, olkApt.End)/60
excWks.Cells(lngRow, 9).NumberFormat = "0.00"
excWks.Cells(lngRow, 10) = olkApt.Location
excWks.Cells(lngRow, 11) = "John Doe"
lngRow = lngRow + 1
lngCnt = lngCnt + 1
End If
Next
excWks.Columns("A:H").AutoFit
excWkb.SaveAs "I:\Weekly Sales Order Reports\Sales Calendar Export\John Doe.xlsx"
excWkb.Close
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
Set olkApt = Nothing
Set olkLst = Nothing
Set olkFld = Nothing
MsgBox "Process complete. A total of " & lngCnt & " appointments were exported.", vbInformation + vbOKOnly, SCRIPT_NAME
End Sub