VBATools

Jedną z braku funkcjonalności Outlooka jest export obiektów kalendarzowych zawierających osoby zaproszone na spotkanie, ich status oraz potwierdzenie przybycia.

Dzięki wbudowanej opcji zawartej w Menu/Plik/Importuj lub exportuj/Eksport do pliku/Microsoft Excel/.. otrzymujemy jedynie listę:

Temat, Datarozpoczęcia, Czasrozpoczęcia, Datazakończenia, Czaszakończenia, Przypomnienie wł/wył, Dataprzypomnienia, Czasprzypomnienia, Kategorie, Opis

która nie jest wystarczająca np.: dla raportowania statusów odbiorców zaproszeń na spotkanie.

Naszym celem jest uzyskanie pliku który posiadał by następujące pola:

• Temat wydarzenia
• Data i godzina rozpoczęcia
• Data i godzina zakończenia
• Data i godzina utworzenia obiektu
• Miejsce potkania
• Kategoria
• Cykliczność

W obrębie każdego wydarzenia (o ile jest to zaproszenie na spotkanie):

1. Zaproszony (adres email)
2. Odpowiedź potwierdzająca (czy potwierdzono)
3. Wymagany (czy wymagano obecności)

To wszystko eksportowane do nowego arkusza Excela z zatrzymaniem nagłówka, autofiltrem, i zgrupowaniem od najwcześniejszego do ostatniego wydarzenia.

Option Explicit

Sub OLCalendarToExcel()
'MVP OShon from VBATools.pl
On Error GoTo Blad

Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim i&, j&, x&, ilosc&, ktory&, statspo$, zakres&
Dim ns As Outlook.NameSpace
Dim fol As Outlook.MAPIFolder
Dim Zaproszeni As Outlook.Recipients
Dim itm As Object

Set ns = Application.GetNamespace("MAPI")
Set fol = ns.PickFolder
 If fol Is Nothing Then
 GoTo koniec
 End If

If fol.DefaultItemType <> olAppointmentItem Then
 MsgBox "Wskazany folder nie jest obiektem kalendarzowym." & vbCr & _
 "Procedura została przerwana."
 GoTo koniec
End If

Set appExcel = CreateObject("Excel.Application")
 appExcel.Visible = True
 appExcel.Workbooks.Add

Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
 wks.Activate

ilosc = fol.Items.Count
 If ilosc = 0 Then
 MsgBox "Brak obektów do eksportu"

GoTo koniec
 Else
 'mozliwość dołączenia Bara postpu
 'Debug.Print "Ilość obieków: " & Ilosc
 End If

i = 1: j = 1: ktory = 1
Set rng = wks.Cells(i, j)
With rng
 .value = "Temat"
 .Offset(, 1).value = "Rozpoczęcie"
 .Offset(, 2).value = "Zakoczenie"
 .Offset(, 3).value = "Utworzono"
 .Offset(, 4).value = "Miejsce"
 .Offset(, 5).value = "Kategoria"
 .Offset(, 6).value = "Cykliczne"
 .Offset(, 7).value = "Zaproszony"
 .Offset(, 8).value = "Potwierdzenie"
 .Offset(, 9).value = "Wymagany"
End With

With wks
 .Range("A1").AutoFilter
 .Cells.EntireColumn.AutoFit
 .Columns("A:C").ColumnWidth = 16
 .Outline.SummaryRow = xlAbove
End With
appExcel.ScreenUpdating = False

For Each itm In fol.Items
DoEvents
Set rng = wks.Cells(i, j)
 If itm.Class = olAppointment Then
 If itm.Start <> "" Then rng.Offset(1, 0).value = itm.Subject
 If itm.End <> "" Then rng.Offset(1, 1).value = itm.Start
 If itm.CreationTime <> "" Then rng.Offset(1, 2).value = itm.End
 If itm.Subject <> "" Then rng.Offset(1, 3).value = itm.CreationTime
 If itm.Location <> "" Then rng.Offset(1, 4).value = itm.Location
 If itm.Categories <> "" Then rng.Offset(1, 5).value = itm.Categories
 If itm.IsRecurring <> "" Then rng.Offset(1, 6).value = itm.IsRecurring
 appExcel.StatusBar = "Export danych: " & Format(ktory / ilosc, "0.00%")

 Set Zaproszeni = itm.Recipients
 For x = 1 To Zaproszeni.Count
 statspo = ""
 i = i + 1
 Select Case Zaproszeni(x).MeetingResponseStatus
 Case 0:  statspo = "Brak odpowiedzi"
 Case 1:  statspo = "Organizator"
 Case 2:  statspo = "Wstępnia zgoda"
 Case 3:  statspo = "Zaakceptwał"
 Case 4:  statspo = "Odmówił"
 End Select

 If Zaproszeni(x).Type = olRequired Then
 wks.Cells(i + 1, 8).value = Zaproszeni(x).Name
 wks.Cells(i + 1, 9).value = statspo
 wks.Cells(i + 1, 10).value = "Obwiązkowy"
 Else
 wks.Cells(i + 1, 8).value = Zaproszeni(x).Name
 wks.Cells(i + 1, 9).value = statspo
 wks.Cells(i + 1, 10).value = "Opcjonalny"
 End If
 wks.Cells(i + 1, 2).value = itm.Start
 Next x

 On Error Resume Next
 If itm.UserProperties("CustomField") <> "" Then
 rng.value = itm.UserProperties("CustomField")
 End If
 On Error GoTo 0
 End If
 i = i + 1
 ktory = ktory + 1
Next itm

With wks
 .Cells.Sort Key1:=.Range("B2"), Order1:=1, Header:=True
 For j = 2 To i
 If j = i Then
  Exit For
 ElseIf .Cells(j, 1).value = "" Then
  zakres = .Range("A" & j).End(xlDown).Row
 If zakres = .Rows.Count Then Exit For
   .Range(j & ":" & zakres - 1).Rows.Group
   j = zakres
 End If
 Next j
 If .Range("A" & .Rows.Count).End(xlUp).Row <> .Range("B" & .Rows.Count).End(xlUp).Row Then _
  .Range(.Range("A" & .Rows.Count).End(xlUp).Row + 1 & ":" & .Range("B" & .Rows.Count).End(xlUp).Row).Rows.Group
  .Outline.ShowLevels RowLevels:=1
  .Range("A2").Select
End With

With appExcel
 .ActiveWindow.FreezePanes = True
 .ScreenUpdating = True
 .StatusBar = ""
End With

koniec:
If Not Zaproszeni Is Nothing Then Set Zaproszeni = Nothing
If Not rng Is Nothing Then Set rng = Nothing
If Not fol Is Nothing Then Set fol = Nothing
If Not ns Is Nothing Then Set ns = Nothing
If Not wks Is Nothing Then Set wks = Nothing
If Not wkb Is Nothing Then Set wkb = Nothing
If Not appExcel Is Nothing Then Set appExcel = Nothing

Exit Sub
Blad:
 MsgBox Err.Number & vbCr & Err.Description
 Resume koniec
End Sub 

Aby osadzić procedurę „OLCalendarToExcel” pod przyciskiem w menu MS Outlook, polecam uwadze ten artykuł.

Postępowanie krokowe w makro:

• sprawdza, czy wybrano folder kalendarza
• sprawdza, czy folder zawiera obiekty
• tworzy arkusz Excela z nagłówkiem eksportowanych danych
• zapisuj kolejno dane z obiektów kalendarzowych z uwzględnieniem podanych pow założeń
• formatuje arkusz