0
Я экспортирую данные календаря Outlook из общего календаря в Excel. Все работает отлично, за исключением того, что мой код экспортирует повторяющиеся элементы с их исходной датой публикации, а не для каждого экземпляра.Outlook Экспорт общего календаря в Excel - повторяющиеся события не экспортируются правильно
Я видел связанный пост «Как показать дату начала для INSTANCE повторяющейся серии?» но я не мог заставить его работать - я думаю, что мои глаза сейчас не работают, и мне нужна помощь ...
Спасибо.
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