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
Hallo
fehlt in dem Makro eine Funktion??
Call formatExcel(wsExcel, olAppt.Recipients.Count, 2)
Bei der Zeile wird mir ein Fehler ausgegeben.
Viele Grüße
Greg
desweiteren hat sich da ein kleiner tippfehler eingeschlichen:
anstatt: wsExcel.Range(„A1“).Cells(r + 1, 1).Value = response(olAppt.Recipients).MeetingResponseStatus
sollte es heißen: wsExcel.Range(„A1“).Cells(r + 1, 1).Value = response(olAppt.Recipients(r).MeetingResponseStatus)
Ein Hinweis für den Anwender den Verweis auf Excel zu setzten ware auch nicht verkehrt:
Extras –> Verweis –> Microsoft Excel x.0…. –> Häckchen setzen
ansonsten: top! danke für das makro!! 🙂
Danke für den Hinweis und super, dass du es gleich selbst lösen konntest. Ich habe den Kommentar heute erst entdeckt…
fast…
mein erster post ist noch offen 😉
Könntest du mir bitte noch sagen was sích hinter der folgenden Funktion verbirgt?
Call formatExcel(wsExcel, olAppt.Recipients.Count, 2)
Sie wird in der Sub aufgerufen, ist aber oben im Code nicht auffindbar.
Wäre super 🙂
Hallo Greg,
ich habe gerade noch einmal gesucht, die Dateien aber nicht mehr gefunden. Ist ja schon ein paar Jährchen her. Inzwischen benutze ich den Automatismus, mit dem man aus dem Termin OneNote Notizen erstellen kann. Dort werden alle Teilnehmer mit Status übernommen.
Die Funktion „formatExcel“ hatte ich glaube ich aus einem aufgezeichneten Makro erstellt, dass ich parametrisierbar gemacht hatte. Es formatiert die Tabelle hübsch und erstellt alternierende Hintergrundfarben für jede zweite Zeile.
Viele Grüße
Karsten