Outlook Termine identifizieren und entfernen

[Frank77]

Hallo!

Hab da eine Frage zu Access und Outlook

Ich exportiere Termine die in einer Tabelle hinterlegt sind von Access nach Outlook das klappt super hier mal der Code dazu

Im externen Modul  steht das hier :

Code [Auswählen] Erweitern

Option Compare Database
Option Explicit

Private objOutlook As Outlook.Application
Private NS As Outlook.NameSpace
Private Folder As Outlook.Folder

Public Property Get GetOutlook() As Outlook.Application
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    If Err <> 0 Or objOutlook Is Nothing Then
        Err = 0
        Set objOutlook = CreateObject("Outlook.Application")
        If Err <> 0 Or objOutlook Is Nothing Then
            Beep
            MsgBox "Verbindung zu Outlook kann nicht aufgebaut werden: " & _
                   Err.Description, vbOKOnly + vbCritical, "Problem:"
            Exit Property
        End If
    End If
    Set GetOutlook = objOutlook
End Property

Public Function ResetOutlook()
    On Error Resume Next
    If Not objOutlook Is Nothing Then
        Set objOutlook = Nothing
    End If
    If Not NS Is Nothing Then
        Set NS = Nothing
    End If
        If Not Folder Is Nothing Then
        Set Folder = Nothing
    End If
End Function

Public Property Get GetMAPINamespace() As Outlook.NameSpace
    If NS Is Nothing Then
        Set NS = GetOutlook.GetNamespace("MAPI")
    End If
    Set GetMAPINamespace = NS
End Property

Public Property Get GetAppointmentFolder() As Outlook.Folder
    If Folder Is Nothing Then
        Set Folder = GetMAPINamespace.GetDefaultFolder(olFolderCalendar)
    End If
    Set GetAppointmentFolder = Folder
End Property

Die Prozedur die die Termine exportiert sieht so aus 

Code [Auswählen] Erweitern

Public Sub TermineExportieren()
    Dim olc As Outlook.AppointmentItem
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim objUserProperty As Outlook.UserProperty
    Dim strBody As String
    Set db = CurrentDb
    Set rst = db.OpenRecordset("TblVeranstaltungs_Termine_Outlook", dbOpenDynaset)

    strBody = CurrentDb.OpenRecordset("SELECT QryBody_Outlook.TerminID, [Veranstalter] & Chr$(13) & Chr$(10) & [Veranstaltung] & Chr$(13) & Chr$(10) & [Termin] AS Body" & _
                                    " From QryBody_Outlook" & _
                                    " WHERE QryBody_Outlook.TerminID=" & rst!VeranstaltungsDatumIDRef)(1)

    On Error GoTo Err_ErrHandler
    Do While Not rst.EOF
        'On Error Resume Next
        Set olc = GetAppointmentFolder.items.Find("[TerminID] = " & rst!TerminID)
        If olc Is Nothing Then
            Set olc = GetAppointmentFolder.items.Add
            With olc
                .Subject = rst!Betreff
                .Body = strBody
                .Start = rst!BeginntAm
                .End = rst!EndetAm
                .AllDayEvent = True
                Set objUserProperty = .UserProperties.Add("TerminID", olText)
                objUserProperty.Value = rst!TerminID
                .Save
                rst.Edit
                rst!GeaendertAm = .LastModificationTime
                rst.Update
            End With
        Else
            With olc
                If Not (rst!GeaendertAm = .LastModificationTime) Then
                    .Subject = rst!Betreff
                    .Body = strBody
                    .Start = rst!BeginntAm
                    .End = rst!EndetAm
                    .AllDayEvent = True
                    rst.Edit
                    rst!GeaendertAm = .LastModificationTime
                    rst.Update
                    .Save
                End If
            End With
        End If
        rst.MoveNext
    Loop
Exit_ErrHandler:
    If Not rst Is Nothing Then rst.Close: Set rst = Nothing
    If Not db Is Nothing Then db.Close: Set db = Nothing
    Call ResetOutlook
    Exit Sub
Err_ErrHandler:
    Select Case Err.Number
    Case 2501
        Call LogError(Err.Number, Err.Description, "MdlKontext_Tree_Veranstalter - BearbeitenVeranstaltungTerminDrucken(), , False")
        Resume Exit_ErrHandler:
    Case Else
        Call LogError(Err.Number, Err.Description, "MdlKontext_Tree_Veranstalter - BearbeitenVeranstaltungTerminDrucken(), , True")
        Resume Exit_ErrHandler:
    End Select
    Resume Exit_ErrHandler:
End Sub

Die Termine möchte ich aber aus Outlook wieder löschen das konnte ich auch auf diese Weise realisieren was auch klappt der Termin nach dem suchen der Termini in Outlook auch Explicit gelöscht

Code [Auswählen] Erweitern

Public Sub TermineLoeschen(ID As Long)
    Dim olc As Outlook.AppointmentItem
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim objUserProperty As Outlook.UserProperty
    Dim OK As Boolean
    Set db = CurrentDb
    Set rst = db.OpenRecordset("TblVeranstaltungs_Termine_Outlook", dbOpenDynaset)
If Not rst.EOF Then
    On Error Resume Next
        rst.FindFirst "TerminID=" & ID
        Set olc = GetAppointmentFolder.items.Find("[TerminID] = " & rst!TerminID)
        OK = False
With olc
            .Delete
            rst.Delete
            MsgBox "Der Termin wurde aus Outlook entfernt!"
            If IstFormularGeoeffnet("TblVeranstaltungs_Termine_Outlook") Then
                Forms!TblVeranstaltungs_Termine_Outlook.Requery
            End If
        End With
    End If
    If Not rst Is Nothing Then rst.Close: Set rst = Nothing
    If Not db Is Nothing Then db.Close: Set db = Nothing
    Call ResetOutlook
End Sub

Nun aber zu meiner Idee das ganze etwas Benutzer freundlicher zu gestalten und wo der eigentliche haken hängt. Ich bekomme es nicht hin das der Termin identifiziert wird und bekomme eine Fehlermeldung das die With Block oder Objekt variable  nicht vorhanden ist an der stelle

If Not IsMissing(.Subject) Then ein On Error Resume Next bring da nichts  der Termin wird nicht wie in der oberen Prozedur gelöscht und auch die MsgBox geht nicht los

was ich eigentlich erreichen möchte ist das  ich eine Rückmeldung bekomme ob die TerminID
vorhanden ist  wenn nicht Termin aus Tabelle löschen oder erneut Exportieren
der folgende Code ist nur mal ein Ansatz dieser Lösung

wäre für jede Hilfe sehr dankbar Gruß Frank 

Code [Auswählen] Erweitern


Public Sub TermineLoeschen(ID As Long)

    Dim olc As Outlook.AppointmentItem
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim objUserProperty As Outlook.UserProperty
    Dim OK As Boolean
    Set db = CurrentDb
    Set rst = db.OpenRecordset("TblVeranstaltungs_Termine_Outlook", dbOpenDynaset)

    If Not rst.EOF Then
        'On Error Resume Next
        rst.FindFirst "TerminID=" & ID
        Set olc = GetAppointmentFolder.items.Find("[TerminID] = " & rst!TerminID)
        OK = False

        With olc
            If Not IsMissing(.Subject) Then
                If .Subject = rst!Betreff Then OK = True
            End If
            If OK = True Then
                .Delete
                rst.Delete
                MsgBox "Der Termin wurde aus Outlook entfernt!"
                If IstFormularGeoeffnet("TblVeranstaltungs_Termine_Outlook") Then
                    Forms!TblVeranstaltungs_Termine_Outlook.Requery
                End If
            End If
        End With
        If OK = False Then
            MsgBox "Der Termin ist nicht in Outlook vorhanden!"
        End If
    End If
    'Exit_ErrHandler:
    If Not rst Is Nothing Then rst.Close: Set rst = Nothing
    If Not db Is Nothing Then db.Close: Set db = Nothing
    Call ResetOutlook
End Sub

[Frank77]

Hier die lösung

Code [Auswählen] Erweitern

Public Sub TermineLoeschen(ID As Long)
    Dim olc As Outlook.AppointmentItem
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim objUserProperty As Outlook.UserProperty
    Dim OK As Boolean
    Dim Msg As String

    Set db = CurrentDb
    Set rst = db.OpenRecordset("TblVeranstaltungs_Termine_Outlook", dbOpenDynaset)
    On Error GoTo Err_ErrHandler

    If Not rst.EOF Then
        rst.FindFirst "TerminID=" & ID
        Set olc = GetAppointmentFolder.items.Find("[TerminID] = " & rst!TerminID)
        If olc Is Nothing Then
            Msg = " Der Termin ist nicht in Outlook vorhanden!" & vbCr & "" & vbCr & "Möchten Sie den Termin erneut exportieren ?" & vbCr & ""
            If MsgBox(Msg, vbInformation Or vbYesNo Or vbDefaultButton2, "No Match!") = vbYes Then
                callTermineImportieren  ' Ja
            Else
                rst.Delete   ' Nein
                If IstFormularGeoeffnet("TblVeranstaltungs_Termine_Outlook") Then
                    Forms!TblVeranstaltungs_Termine_Outlook.Requery
                End If
                GoTo Exit_ErrHandler
            End If
        Else
            With olc
                .Delete
                rst.Delete
                MsgBox "Der Termin wurde aus Outlook entfernt!"
                If IstFormularGeoeffnet("TblVeranstaltungs_Termine_Outlook") Then
                    Forms!TblVeranstaltungs_Termine_Outlook.Requery
                End If
            End With
        End If
    End If
Exit_ErrHandler:
    If Not rst Is Nothing Then rst.Close: Set rst = Nothing
    If Not db Is Nothing Then db.Close: Set db = Nothing
    Call ResetOutlook
    Exit Sub
Err_ErrHandler:
    Select Case Err.Number
    Case 2501
        Call LogError(Err.Number, Err.Description, "Mdl_Termin_Nach_Outlock - TermineLoeschen(), , False")
        Resume Exit_ErrHandler:
    Case Else
        Call LogError(Err.Number, Err.Description, "Mdl_Termin_Nach_Outlock - TermineLoeschen(), , True")
        Resume Exit_ErrHandler:
    End Select
    Resume Exit_ErrHandler:
End Sub

[Frank77]

Hier noch die Import in die tabele

Access - Outlook 2010

Code [Auswählen] Erweitern

Public Sub TermineImportieren()
    Dim olc As Outlook.AppointmentItem
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim objUserProperty As Outlook.UserProperty
    Dim lngTerminID As Long
    Set db = CurrentDb
    Set rst = db.OpenRecordset("TblVeranstaltungs_Termine_Outlook", dbOpenDynaset)
    For Each olc In GetAppointmentFolder.items
        With olc
            lngTerminID = 0
            On Error Resume Next
            lngTerminID = .UserProperties.Item("TerminID").Value
            On Error GoTo 0
            If lngTerminID > 0 Then
                rst.FindFirst "TerminID = " & lngTerminID
                If rst.NoMatch Then
                    rst.AddNew
                    rst!Betreff = .Subject
                    rst!Inhalt = .Body
                    rst!BeginntAm = .Start
                    rst!EndetAm = .End
                    rst!GeaendertAm = .LastModificationTime
                    Set objUserProperty = .UserProperties.Add("TerminID", olText)
                    objUserProperty.Value = rst!TerminID
                    .Save
                    rst.Update
                Else
                    If Not rst!GeaendertAm = .LastModificationTime Then
                        rst.Edit
                        rst!Betreff = .Subject
                        rst!Inhalt = .Body
                        rst!BeginntAm = .Start
                        rst!EndetAm = .End
                        rst!GeaendertAm = .LastModificationTime
                        rst.Update
                    End If
                End If
            Else
                rst.AddNew
                rst!Betreff = .Subject
                rst!Inhalt = .Body
                rst!BeginntAm = .Start
                rst!EndetAm = .End
                rst!GeaendertAm = .LastModificationTime
                Set objUserProperty = .UserProperties.Add("TerminID", olText)
                objUserProperty.Value = rst!TerminID
                .Save
                rst.Update
            End If
        End With
    Next olc
    If Not rst Is Nothing Then rst.Close: Set rst = Nothing
    If Not db Is Nothing Then db.Close: Set db = Nothing
    Call ResetOutlook

[beluga]

Schon lange her Frank, aber mein Dank sei Dir zugesprochen, hatte ein ähnliches Problem und nur schon dank einer Linie von Dir die Lösung bekommen... Danke