Outlook Besprechungen mit Durchblick

Outlook – getParticipants

Worum Geht’s?

Leider kann man im Status-Fenster einer Outlook-Einladung nicht nach Name oder Status sortieren. Mit diesem Skript wird Liste der eingeladenen Personen mit Status in ein neues Excel kopiert. Funktioniert allerdings nur bei Terminen die man selbst erstellt hat. Getestet mit Outlook 2003.

HowTo

Am besten das Makro mit einem Symbol in die Symbolleiste aufnehmen. Im Kalender einen Termin anklicken und anschließend das Makro starten…

edited: Danke an Greg! Man muss über Extras –> Verweis –> Microsoft Excel x.0…. das Häckchen setzen damit das Makro läuft.

Code

Sub getParticipants_selection()
'© Karsten Hartlieb 2009
Dim olfolder As MAPIFolder
Dim olSel As Outlook.Selection
Dim olApp As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim obj As Object
Dim tmp, x, r, sAccepted, sNone, sNoResponse, sTentative, cAccepted, cNone, cNoResponse, cTentative
Set olApp = GetObject(, "outlook.application")
Set olSel = olApp.ActiveExplorer.Selection

    If olSel.Count Then
        Set obj = olSel.Item(1)
        If Not (TypeOf obj Is Outlook.AppointmentItem) Then
            tmp = MsgBox("Bitte zuerst den Termin markieren, der bearbeitet werden soll", vbOKOnly, "Karstens Termin-Tool")
            Exit Sub
        Else
        Set olAppt = obj
        tmp = "Die Daten des ausgewählten Termins sind:" & vbCrLf & vbCrLf
        tmp = tmp & "Betreff: '" & olAppt.Subject & "'" & vbCrLf
        tmp = tmp & "Datum: " & olAppt.Start & vbCrLf
        tmp = tmp & "Empfänger: " & olAppt.Recipients.Count
        If olAppt.Recipients.Count = 0 Then
            tmp = tmp & vbCrLf & vbCrLf & "Dies ist ein lokaler Termin."
            tmp = tmp & vbCrLf & "Das Extrahieren von Teilnehmerdaten ist hier nicht möglich."
            tmp = MsgBox(tmp, vbInformation, "Karstens Termin-Tool")
            Exit Sub
        End If
    'tmp = MsgBox(tmp, vbOKOnly, "Karstens Termin-Tool")
    tmp = tmp & vbCrLf & vbCrLf & "Sollen die Teilnehmerantworten nach Excel exportiert werden?"
    tmp = MsgBox(tmp, vbYesNoCancel, "Karstens Termin-Tool")
    If tmp <> 6 Then
        Exit Sub
    End If

Dim appExcel As Excel.Application
Dim wbExcel As Excel.Workbook
Dim wsExcel As Excel.Worksheet
    Set appExcel = CreateObject("Excel.Application")     'Excel öffnen
    appExcel.Visible = True
    Set wbExcel = appExcel.Workbooks.Add 'neue Arbeitsmappe anlegen
    If wbExcel.Worksheets.Count > 0 Then
        Set wsExcel = wbExcel.Worksheets(1) 'erste Tabelle auswählen bzw. ...
    Else
        Set wsExcel = wbExcel.Worksheets.Add '... neue Tabelle anlegen
    End If 'Count>0
    appExcel.ScreenUpdating = False
    wsExcel.Range("A1").Cells(1, 1).Value = "Status"
    wsExcel.Range("A1").Cells(1, 2).Value = "Name"
    For r = 1 To olAppt.Recipients.Count
        olAppt.Recipients(r).Resolve
        wsExcel.Range("A1").Cells(r + 1, 1).Value = response(olAppt.Recipients).MeetingResponseStatus
        wsExcel.Range("A1").Cells(r + 1, 2).Value = olAppt.Recipients(r).Name
    Next r
    Call formatExcel(wsExcel, olAppt.Recipients.Count, 2)
    appExcel.ScreenUpdating = True
    End If
    End If
End Sub

Function response(responseStatus)
response = "??????"
If responseStatus = olResponseAccepted Then response = "1 Zugesagt"
If responseStatus = olResponseDeclined Then response = "3 Abgelehnt"
If responseStatus = olResponseNone Then response = "4 Keine Antwort"
If responseStatus = olResponseNotResponded Then response = "5 Keine Antwort"
If responseStatus = olResponseOrganized Then response = "6 ???"
If responseStatus = olResponseTentative Then response = "2 Mit Vorbehalt"
End Function

Function getEmailAddress(address, ID)
Dim objSession
getEmailAddress = "????"
    If InStr(1, address, "/O=") > 0 Then
        Set objSession = CreateObject("MAPI.Session")
        objSession.Logon "", "", False, False
        Adresse = objSession.GetAddressEntry(ID).Fields(&H39FE001E).Value
        getEmailAddress = objSession.GetAddressEntry(ID).Fields(&H39FE001E).Value
        Set objSession = Nothing
    Else
        getEmailAddress = address
    End If
End Function