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 :
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
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
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
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
Hier die lösung
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
Hier noch die Import in die tabele
Access - Outlook 2010
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
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