Office: Excel Termine über entry ID mit Outlook abgleichen

Hallo liebe VBAler,

meine Kenntnisse in VBA habe ich mir größtenteils selbst beigebracht bzw. das meiste ergooglet.
Ich habe für meine arbeit als Disponent eine Excel Arbeitsmappe erstellt in der über ein Userform Datum Uhrzeit Dauer sowie Betreff (Abholadresse und Name) und Ort(Zieladresse) in eine Zelle im ersten Tabellenblatt eingegeben werden(fortlaufener Text. Im zweiten Tabellenblatt ist das ganze dann aufgesplittet. über ein Makro werden nun alle Termine in Outlook eingetragen und an meine Fahrer verschickt(funktioniert auch prima).

Nun zu meinem Problem ich lassen nach dem übertragen die Id des Termins in das 2.Tabellenblatt eintragen und würde gerne das bei Änderungen der Termin in Outlook mit geändert wird.... hierbei ist es wichtig das scih alle neuen Details mit aktualisieren.
Bei meiner Recherche bin ich zwar auf die Info gestoßen mit Getitemfromid jedoch übersteigt das jetzt komplett meine Kenntnisse.

Hier mal mein Code zum übertragen an Outlook:

Option Explicit

Public Sub Meeting_Liste()
Const olMeeting = 1
Const olAppointmentItem = 1

' Dim olApp As Outlook.Application '(für Early-Binding)
' Dim olAppointItem As Outlook.AppointmentItem '(für Early-Binding)
Dim olApp As Object '(für Late-Binding)
Dim olAppointItem As Object '(für Late-Binding)

Dim RgTermine As Range, Ws As Worksheet, RgTermin As Range
Dim EMailAdr$, strCategory$, Betreff$, RemDatum As Date, RemUhrzeit As Date, RemDauer As Date
Dim Ort$, Text$, JaNein$


' Neue Outlook-Instanz erzeugen
' Set olApp = New Outlook.Application '(für Early-Binding)
Set olApp = CreateObject("Outlook.Application") '(für Late-Binding)
Set Ws = ActiveSheet
Set RgTermine = Ws.Cells(2, 1).CurrentRegion
Set RgTermine = RgTermine.Offset(1).Resize(RgTermine.Rows.Count - 1)

For Each RgTermin In RgTermine.Rows
On Error GoTo Err_Termin
With RgTermin
'Überprüfen, ob diese Excel-Zeile versendet werden soll (Spalte H):
JaNein$ = UCase(.Cells(8).Value)
If JaNein$ = "JA" Or JaNein$ = "OK" Then
'Die E-Mail-Daten aus den Spalten des Excel-Arbeitsblattes holen (Spalten A-G):
EMailAdr$ = .Cells(1).Value
Betreff$ = .Cells(2).Value
RemDatum = .Cells(3).Value
RemUhrzeit = .Cells(4).Value
RemDauer = .Cells(5).Value
Ort$ = .Cells(6).Value
strCategory$ = .Cells(7).Value

'Meeting-Objekt erstellen:
Set olAppointItem = olApp.CreateItem(olAppointmentItem)
With olAppointItem
'E-Mail-Objekt mit Daten befüllen (Modus: einfaches TEXT-EMail)
.MeetingStatus = olMeeting
.Categories = strCategory
.Location = Ort$
.Start = RemDatum & " " & RemUhrzeit
.Duration = RemDauer * 24 * 60 'Dauer in Tagen -> Dauer in Minuten
.Recipients.Add EMailAdr$
.Subject = Betreff$
.Body = Betreff$ & " für:" & vbCrLf & _
"Datum: " & vbTab & Format$(RemDatum, "DD.MM.YYYY") & vbCrLf & _
"Uhrzeit: " & vbTab & Format$(RemUhrzeit, "HH:MM") & vbCrLf & _
"Dauer: " & vbTab & Format$(RemDauer, "HH:MM") & vbCrLf & _
"Ort: " & vbTab & Ort$ & vbCrLf & _
"Text: " & vbTab & Text$
'E-Mail/Meeting absenden
.Send
Cells(Cells(Rows.Count, "J").End(xlUp).Row + 1, "J").Value = .EntryID
End With
Else
'Ja_Nein enthielt nicht "Ja" oder "ok":
'Sende diese Zeile nicht
End If
End With
Nxt_Termin:
On Error GoTo 0
Next RgTermin

'Outlook-Objekt als zu löschen kennzeichnen für den Garbage-Collector:
Set olApp = Nothing
Exit Sub
Err_Termin:
MsgBox "Fehler bei Termin: " & EMailAdr$ & vbCrLf & _
"Fehler=" & Err.Number & ": " & Err.Description
Resume Nxt_Termin
End Sub

:)

 

So jetzt habe ich zumindest eine HALBE Lösung gefunden Termine wieder zu löschen jedoch löscht er mir die Termine in Outlook nur sendet aber keine Absage an den Fahrer.

Hier mal der Code ... vielleicht kann man den ja auch nutzen um Änderungen vorzunehmen:
Bitte lacht mich nicht aus ich bastel mir meistens nur Codes aus bestehenden zusammen das heisst viele Dinge die drin stehen werde ich vielliecht gar nicht brauchen aber es funktioniert für meine Zwecke weitestgehend... Ihr seht ich brauche DRINGEND hilfe....


Public Sub Oulooklöschen()
Sheets("Tabelle2").Select

Const olMeeting = 1
Const olAppointmentItem = 1

' Dim olApp As Outlook.Application '(für Early-Binding)
' Dim olAppointItem As Outlook.AppointmentItem '(für Early-Binding)
Dim olapp As Object '(für Late-Binding)
Dim olAppointItem As Object '(für Late-Binding)

Dim RgTermine As Range, Ws As Worksheet, RgTermin As Range
Dim EMailAdr$, strCategory$, Betreff$, RemDatum As Date, RemUhrzeit As Date, RemDauer As Date
Dim Ort$, Text$, JaNein$


' Neue Outlook-Instanz erzeugen
' Set olApp = New Outlook.Application '(für Early-Binding)
Set olapp = CreateObject("Outlook.Application") '(für Late-Binding)
Set Ws = ActiveSheet
Set RgTermine = Ws.Cells(2, 1).CurrentRegion
Set RgTermine = RgTermine.Offset(1).Resize(RgTermine.Rows.Count - 1)

For Each RgTermin In RgTermine.Rows
On Error GoTo Err_Termin
With RgTermin
JaNein$ = UCase(.Cells(9).Value)
If JaNein$ = "JA" Or JaNein$ = "OK" Then
Dim eid As String: eid = .Cells(10).Value

Dim app As Object: Set app = olapp.GetNamespace("MAPI").GetItemFromID(eid)
Set olapp = CreateObject("Outlook.Application")


'Appointment auslesen

app.Delete
Else
'Ja_Nein enthielt nicht "Ja" oder "ok":
'Sende diese Zeile nicht
End If
End With
Nxt_Termin:
On Error GoTo 0
Next RgTermin

'Outlook-Objekt als zu löschen kennzeichnen für den Garbage-Collector:
Set olapp = Nothing
Exit Sub
Err_Termin:
MsgBox "Fehler bei Termin: " & EMailAdr$ & vbCrLf & _
"Fehler=" & Err.Number & ": " & Err.Description
Resume Nxt_Termin
MsgBox "Termine erfolgreich an Outlook übertragen & ggf. verschickt"
End Sub

 

So nun habe ich es mit basteln und probieren hinbekommen die Besprechung abzusagen und den Termin anschließend zu löschen.

vor app.delete musste ich einsetzte:

app.MeetingStatus = olMeetingCanceled
app.Send


jetzt brauche nur tatkräftige Unterstützung für das abändern von Terminen...