AW: Outlook-Termine nach Excel
28.09.2009 21:22:44
Christian
hallo Melek,
wenn der Betreff jedesmal exakt gleich ist, könnte man alle Termine mit diesem Betreff auslesen und davon jenen mit dem neuesten Datum ermitteln.
Hier ein Ansatz - In Spalte A ab Zeile 2 stehen deine "Betreffs"
in den Spalten B bis D wird der Betreff, dass jüngste Datum und die letzte Zeile des Inhalts aufgeführt.
Die Übertragung in diverse Dateien ist ein anderes Thema, erst mal muss das Auslesen ja passen.
Wie zuvor muss der Verweis auf Outlook im VBE Editor gesetzt sein (das kann man später auch umgehen, ist aber bei der Entwicklung ganz hilfreich).
Gib mir Bescheid, wie du damit zurecht kommst.
Gruß
Christian
Option Explicit
Sub GetAppointmentItems()
Dim objOL As Outlook.Application
Dim objAptItem As Outlook.AppointmentItem
Dim strAptItem$(), dblDate#, i&, j&, vLine
On Error GoTo ErrorHandler
With Sheets("Tabelle1")
.Columns(2).Resize(, 3).Clear
Set objOL = New Outlook.Application
For j = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
dblDate = 0
ReDim strAptItem(2)
For Each objAptItem In objOL.GetNamespace("MAPI").GetDefaultFolder(9).Items
If objAptItem.Subject = .Cells(j, 1).Text Then
If CDbl(objAptItem.Start) > dblDate Then
dblDate = CDbl(objAptItem.Start)
strAptItem(0) = objAptItem.Subject
strAptItem(1) = objAptItem.Start
strAptItem(2) = objAptItem.Body
End If
End If
Next
vLine = Split(strAptItem(2), vbCrLf)
For i = UBound(vLine) To 0 Step -1
If Len(Trim(vLine(i))) Then
strAptItem(2) = Trim(vLine(i))
Exit For
End If
Next
.Cells(j, 2).Resize(, 3).Value = strAptItem
Next
End With
Exit Sub
ErrorHandler:
MsgBox Err.Description & vbLf & Err.Number
Err.Clear
End Sub