AW: Termineintrag über Exceltabelle in Outlook
13.06.2010 15:51:22
Tino
Hallo,
kannst mal diesen Code testen.
Sub Beispiel()
Dim objOutlook As Object, objNameSpace As Object
Dim objMapiFolder As Object, objItems As Object
Dim vonDatum As Date, bisDatum As Date, LMinuten As Long
Dim strBetreff As String, strBody As String
Dim booFind As Boolean
Dim meAr, nCount As Long
With Tabelle1
meAr = .Range("B6", .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 7)
End With
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set objMapiFolder = objNameSpace.GetDefaultFolder(9)
For nCount = 1 To Ubound(meAr)
If LCase(meAr(nCount, 5)) = "ja" Then
strBetreff = "Kündigungsfrist:" & meAr(nCount, 1) 'Betreffzeile
vonDatum = (meAr(nCount, 3) + TimeSerial(8, 0, 0)) - 7 * meAr(nCount, 7) 'von
bisDatum = (meAr(nCount, 3) + TimeSerial(8, 30, 0)) - 7 * meAr(nCount, 7) 'bis
strBody = "Termineintrag: Hallo Lemmi," & Chr(10) & _
"der " & meAr(nCount, 1) & " läuft in " & meAr(nCount, 7) & " Wochen aus !" 'Body
'dauer in Minuten berechnen
LMinuten = Application.WorksheetFunction.Round((bisDatum - vonDatum) * 1440, 0)
Set objItems = objMapiFolder.Items
objItems.Sort "[Start]"
objItems.IncludeRecurrences = True
Set objItems = objItems.Restrict("[Start] >= '" & Format(vonDatum, "dd.mm.yyyy hh:mm") & "'" & _
"AND [Start] <= '" & Format(vonDatum + 1, "dd.mm.yyyy hh:mm") & "'")
'Schleife durch alle gefundenen Termine bis Start und Betreff übereinstimmen
For Each objItems In objItems
With objItems
If .Start = vonDatum And .Subject = strBetreff Then
booFind = True
Exit For
End If
End With
Next objItems
If booFind Then
'hier berabeiten *************************
With objItems
.body = strBody
.Start = Format(vonDatum, "dd.mm.yyyy hh:mm")
.Duration = LMinuten 'dauer in Minuten
.Save
End With
Else
'hier anlegen *************************
Set objItems = objMapiFolder.Items.Add
With objItems
.Subject = strBetreff
.body = strBody
.Start = Format(vonDatum, "dd.mm.yyyy hh:mm")
.Duration = LMinuten 'dauer in Minuten
.Save
End With
End If
End If
Next nCount
Set objNameSpace = Nothing
Set objNameSpace = Nothing
Set objMapiFolder = Nothing
Set objItems = Nothing
End Sub
Gruß Tino