Termine von Excel nach Outlook

Frage: Es sollen Termine von Excel nach Outlook übergeben werden. Das Datum steht in Spalte A ab Zeile 1 und der Betreff (Subject) in Spalte B ab Zeile 1. Ist der Termin schon vorhanden soll nichts passieren. Wie geht das?

Option Explicit
Sub Excel_Control_Termin_nach_Outlook()
    Dim wksSheet As Worksheet
    Dim objFolder As Object
    Dim objOutApp As Object
    Dim objTermin As Object
    Dim lngRow As Long
    On Error GoTo Fin
    Set wksSheet = ThisWorkbook.Worksheets("Tabelle1") ' Anpassen!!!
    Set objOutApp = CreateObject("Outlook.Application")
    '9 = olFolderCalendar
    Set objFolder = objOutApp.GetNamespace("MAPI").GetDefaultFolder(9)
    For lngRow = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        If Not fncPointExist(objFolder, wksSheet.Cells(lngRow, 2).Value) Then
            Set objTermin = objOutApp.CreateItem(1)
            With objTermin
                .Start = Format(wksSheet.Cells(lngRow, 1).Value _
                    + 1, "dd.mm.yyyy") & " 08:00"
                .Subject = wksSheet.Cells(lngRow, 2).Value
                .Body = "Das macht Spass!"
                .Location = "tbd"
                .Duration = "60"
                .ReminderMinutesBeforeStart = 10
                .ReminderPlaySound = True
                .ReminderSet = True
                .Save
            End With
            Set objTermin = Nothing
        End If
    Next lngRow
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    Set objFolder = Nothing
    Set objTermin = Nothing
    Set objOutApp = Nothing
    If Err.Number = 0 Then MsgBox "Termine nach Outlook übertragen!"
End Sub
Private Function fncPointExist(ByVal objTMP As Object, _
    ByVal strSubject As String) As Boolean
    Dim objItem As Object
    For Each objItem In objTMP.Items
        If objItem.Subject = strSubject Then fncPointExist = True
    Next
End Function

Änderunsfrage: Jetzt steht das Datum in Spalte F, Subject soll immer gleich sein und der Body soll geprüft werden - der steht in Spalte C. Wie geht das?

Option Explicit
Sub Excel_Control_Termin_nach_Outlook()
    Dim wksSheet As Worksheet
    Dim objFolder As Object
    Dim objOutApp As Object
    Dim objTermin As Object
    Dim lngRow As Long
    On Error GoTo Fin
    Set wksSheet = ThisWorkbook.Worksheets("Roadmap AUDIT") ' Anpassen!!!
    Set objOutApp = CreateObject("Outlook.Application")
    '9 = olFolderCalendar
    Set objFolder = objOutApp.GetNamespace("MAPI").GetDefaultFolder(9)
    For lngRow = 1 To wksSheet.Cells(Rows.Count, 6).End(xlUp).Row
        If Not fncPointExist(objFolder, wksSheet.Cells(lngRow, 3).Value) And _
            IsDate(wksSheet.Cells(lngRow, 6).Value) Then
            Set objTermin = objOutApp.CreateItem(1)
            With objTermin
                .Start = Format(wksSheet.Cells(lngRow, 6).Value _
                    + 1, "dd.mm.yyyy") & " 10:00"
                .Subject = "Reminder AUDIT-Issue"
                .Body = wksSheet.Cells(lngRow, 3).Value
                .Location = "tbd"
                .Duration = "30"
                .ReminderMinutesBeforeStart = 10
                .ReminderPlaySound = True
                .ReminderSet = True
                .Save
            End With
            Set objTermin = Nothing
        End If
    Next lngRow
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    Set objFolder = Nothing
    Set objTermin = Nothing
    Set objOutApp = Nothing
    If Err.Number = 0 Then MsgBox "Termine nach Outlook übertragen!"
End Sub
Private Function fncPointExist(ByVal objTMP As Object, _
    ByVal strBody As String) As Boolean
    Dim objItem As Object
    For Each objItem In objTMP.Items
        If objItem.Body = strBody Then fncPointExist = True
    Next
End Function

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...