Export zaproszeń w Microsoft Outlook do Excela z uwzględnieniem adresatów

Artykuł dotyczy: Microsoft Outlook 2007/ 2003 / 2002 / 2000

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 On

Sub OLCalendarToExcel()
    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

    ns = Application.GetNamespace("MAPI")
    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

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

    wkb = appExcel.ActiveWorkbook
    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
    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()
        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%")

            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 Zaproszeni = Nothing
    If Not rng Is Nothing Then rng = Nothing
    If Not fol Is Nothing Then fol = Nothing
    If Not ns Is Nothing Then ns = Nothing
    If Not wks Is Nothing Then wks = Nothing
    If Not wkb Is Nothing Then wkb = Nothing
    If Not appExcel Is Nothing Then 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
 

Shon Oskar – www.VBATools.pl

© Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.