Общий экспорт 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
1 ответ
Ваша проблема: в папке календаря есть только одна запись для повторяющегося элемента, и вы не запрашиваете ни одного из свойств повторяющегося элемента.
Если вы ищете одну запись для каждого повторения в вашем рабочем листе, вам придется сгенерировать их. Вам понадобится конечная дата, если вы не хотите, чтобы записи "навсегда" повторялись до 4500 года, и какая-то рабочая таблица после завершения обработки всех элементов календаря.
Я не помню обстоятельств, в которых я кодировал макрос ниже. Это явно исследование элементов календаря, а не попытка создать красивый результат. Я ставлю Debug.Assert False утверждение в верхней части каждого пути через мой код и закомментируйте эти утверждения, когда я с ними сталкиваюсь. Я, кажется, сгенерировал тестовые записи для большинства различных типов повторения, хотя комментарий Have not thought repeating multi-day appointments through предлагает не все.
Я обновил строку 12 с учетом моего текущего рабочего стола, чтобы этот код работал с Office 2016 и Windows 10, а также с более старыми версиями, для которых он был написан. Вам нужно будет обновить строку 12, чтобы обратиться к папке в вашей системе.
Попробуйте этот код в своем общем календаре, а затем найдите его для функций, необходимых для обновления кода.
Option Explicit
Sub DspCalandarItems()
Dim ItemCrnt As Object
Dim ItemCrntClass As Long
Dim FileOut As Object
Dim FolderSrc As MAPIFolder
Dim FSO As FileSystemObject
Dim RecurrPattCrnt As RecurrencePattern
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FileOut = FSO.CreateTextFile("c:\users\Admin\Desktop\Appointments.txt", True)
With GetNamespace("MAPI")
Set FolderSrc = .GetDefaultFolder(olFolderCalendar)
FileOut.WriteLine ("Number of items: " & FolderSrc.Items.Count)
For Each ItemCrnt In FolderSrc.Items
With ItemCrnt
' Occasionally I get syncronisation
' errors. This code avoids them.
ItemCrntClass = 0
On Error Resume Next
ItemCrntClass = .Class
On Error GoTo 0
' I have never found anything but appointments in
' Calendar but test just in case
If ItemCrntClass = olAppointment Then
Select Case .RecurrenceState
Case olApptException
FileOut.WriteLine ("Recurrence state is Exception")
If .AllDayEvent Then
FileOut.WriteLine ("All day " & Format(.Start, "ddd d mmm yy"))
Debug.Assert False
ElseIf Day(.Start) = Day(.End) Then
' Appointment starts and finishes on same day
If Format(.Start, "hh:mm") <> Format(.End, "hh:mm") Then
' Different start and end times on same day
FileOut.Write ("From " & Format(.Start, "hh:mm") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
Debug.Assert False
Else
' Start and end time the same
Debug.Assert False
FileOut.Write ("At " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
End If
Else
' Different start and end dates.
FileOut.Write ("From " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.End, "ddd d mmm yy"))
End If
Debug.Assert False
Case olApptMaster
Set RecurrPattCrnt = .GetRecurrencePattern
Debug.Assert Year(RecurrPattCrnt.PatternStartDate) = Year(.Start)
Debug.Assert Month(RecurrPattCrnt.PatternStartDate) = Month(.Start)
Debug.Assert Day(RecurrPattCrnt.PatternStartDate) = Day(.Start)
If .AllDayEvent Then
FileOut.Write ("All day ")
ElseIf Day(.Start) = Day(.End) Then
Debug.Assert False
' Appointment starts and finishes on same day
If Format(.Start, "hh:mm") <> Format(.End, "hh:mm") Then
' Different start and end times on same day
FileOut.Write ("From " & Format(.Start, "hh:mm") & " to " & _
Format(.End, "hh:mm") & " ")
Debug.Assert False
Else
' Start and end time the same
FileOut.Write ("At " & Format(.Start, "hh:mm") & " ")
Debug.Assert False
End If
ElseIf DateDiff("d", .Start, .End) = 1 And Format(.Start, "hh:mm") = "00:00" And _
Format(.End, "hh:mm") = "00:00" Then
FileOut.Write ("All day ")
'Debug.Assert False
Else
' Have not thought repeating multi-day appointments through
Debug.Assert False
FileOut.Write ("XXX From " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.End, "ddd d mmm yy"))
End If
Select Case RecurrPattCrnt.RecurrenceType
Case olRecursDaily
FileOut.Write ("daily")
Case olRecursMonthly
Case olRecursMonthNth
FileOut.Write ("nth monthly")
Case olRecursWeekly
FileOut.Write ("weekly")
Debug.Assert False
Case olRecursYearly
'Debug.Assert False
FileOut.Write ("yearly")
End Select ' RecurrPattCrnt.RecurrenceType
FileOut.Write (" from " & Format(RecurrPattCrnt.PatternStartDate, "ddd d mmm yy"))
If Year(RecurrPattCrnt.PatternEndDate) = 4500 Then
' For ever
'Debug.Assert False
Else
FileOut.Write (" to " & Format(RecurrPattCrnt.PatternEndDate, "ddd d mmm yy"))
'Debug.Assert False
End If
Case olApptNotRecurring
If .AllDayEvent Then
FileOut.Write ("All day " & Format(.Start, "ddd d mmm yy"))
'Debug.Assert False
ElseIf Day(.Start) = Day(.End) Then
' Appointment starts and finishes on same day
If Format(.Start, "hh:mm") <> Format(.End, "hh:mm") Then
' Different start and end times on same day
FileOut.Write ("From " & Format(.Start, "hh:mm") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
'Debug.Assert False
Else
' Start and end time the same
FileOut.Write ("At " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
'Debug.Assert False
End If
Else
' Different start and end dates.
FileOut.Write ("From " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.End, "ddd d mmm yy"))
'Debug.Assert False
End If
Case olApptOccurrence
FileOut.WriteLine ("Occurrence")
Debug.Assert False
Case Else
Debug.Print ("Unknown recurrence state " & .RecurrenceState)
Debug.Assert False
FileOut.WriteLine ("Unknown recurrence state " & .RecurrenceState)
End Select ' .RecurrenceState
If .Subject <> "" Then
FileOut.Write (" " & .Subject)
Else
FileOut.Write (" ""No subject""")
End If
If .Location <> "" Then
FileOut.Write (" at " & .Location)
Else
FileOut.Write (" at undefined location")
End If
FileOut.WriteLine ("")
If .Body <> "" Then
FileOut.WriteLine (" Body: " & .Body)
End If
End If ' ItemCrntClass = olAppointment
End With ' ItemCrnt
Next ItemCrnt
End With ' GetNamespace("MAPI")
FileOut.Close
End Sub