Hallo,
sorry, ich hatte einen kleinen Fehler. Versuch mal das (ich kann es nicht testen):
Sub auswahlNachOutlook()
'
' Beispiel-Funktion - Markieren - und autoamtisch eintragen in Outlook
' 2016, www.stallwanger.net
'
Dim StartDatum As Date
Dim Dauer As Long
Dim Beschreibung As String
Dim Nachricht As String
Dim Ort As String
'Daten aus der Zeile der aktiven Zelle entnehmen
StartDatum = CDate(Cells(ActiveCell.Row, 3).Value)
Dauer = Cells(ActiveCell.Row, 4).Value
Beschreibung = Cells(ActiveCell.Row, 5).Value
Nachricht = Cells(ActiveCell.Row, 6).Value
Ort = Cells(ActiveCell.Row, 7).Value
'Nach Outlook
lvOutlook StartDatum, Dauer, Beschreibung, Nachricht, Ort
End Sub
Public Function lvOutlook(ByVal outDate As Date, outDauer As Long, outSubject As String, outBody As String, outlocation As String) As Boolean
'Hier beginnen die Termine
'On Error GoTo ErrOutLook wenn es gut läuft, dann kannst du diese Fehlerbehandlung aktivieren (ich bin kein Freund davon)
Set OutApp = CreateObject("Outlook.Application")
Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem)
With apptOutApp
'Datum und Uhrzeit - als Start-Uhrzeit 8:00 -
.Start = DateSerial(Year(outDate), Month(outDate), Day(outDate)) + TimeSerial(8, 0, 0) 'Es kann auch eine andere Uhrzeit festgelegt werden.
'Termininfo
.Subject = outSubject
'oder der Betreff steht in der Spalte rechts von den Terminen
.Location = outlocation ' 'Ort
.Duration = outDauer ' 1 Std. = "60" Dauer in Minuten
'Erinnerung setzen in Outlook (hier inaktiv)
'
.ReminderPlaySound = True
'Erinnerung wiederholen
.ReminderSet = True
'Termin speichern
.Save
End With
Set apptOutApp = Nothing
Set OutApp = Nothing
lvOutlook = True
MsgBox "Termin an Outlook übertragen."
Exit Function
ErrOutLook:
Set apptOutApp = Nothing
Set OutApp = Nothing
lvOutlook = False
MsgBox "Termin konnte in Outlook nicht eingetragen werden. Fehler:" & Err.Description
End Function
|