AW: Outlook Termin in Terminkalender anderer Person
14.05.2019 16:01:06
Lorenz
Hi Patrick
Der Code erzeugt auch eine ics-Datei!
Vielleicht ist nachfogender deiner Aufgabenstellung näher:
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$, 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
Text$ = .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
.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
.ResponseRequested = False
.Save
'.Send
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
einziger Nebeneffekt nach meinen Anforderung(en). "Die Gegenstelle muß bestätigen (ablehnen od. annehmen). falls du dies auch beseitigen kannst wäre nett mir vieieicht Bescheid (loko@direkt.at) zu geben.
Nochmals Grüße aus Österreich
Lorenz