|
Hallo liebe Freunde.
Ich habe den Auftrag bekommen einen Massenterminupload durch eine csv-Datei zu realisieren. Dadurch habe ich den Weg zu VBA gefunden und bin auch relativ schnell voran gekommen. Zwei Sachen fehlen aber noch.
1. Kann ich die Uhrzeit noch nicht einstellen.
2. Werden die Termine noch nicht versandt. Die Teilnehmer sind zwar vom Prinzip her im Termin dabei, man muss den Termin aber noch manuell verschicken, damit andere Teilnehmer den Termin auch bekommen.
Wisst ihr hierfür eine Lösung? "Meinen" Code habe ich mal mit angehängt (Habe ich von verschiedenen Seiten geklaut und selbst etwas konfiguriert).
Sub auswahlNachOutlook()
Dim StartDatum As String
Dim StartZeit As String
Dim Dauer As Long
Dim Teilnehmer As String
Dim Teilnehmer2 As String
Dim Teilnehmer3 As String
Dim Beschreibung As String
Dim Nachricht As String
Dim Ort As String
With Excel.Selection
StartDatum = .Cells(1).Value
Dauer = .Cells(2).Value
Teilnehmer = .Cells(3).Value
Teilnehmer2 = .Cells(4).Value
Teilnehmer3 = .Cells(5).Value
Beschreibung = .Cells(6).Value
Nachricht = .Cells(7).Value
Ort = .Cells(8).Value
End With
lvOutlook StartDatum, Dauer, Teilnehmer, Teilnehmer2, Teilnehmer3, Beschreibung, Nachricht, Ort
End Sub
Public Function lvOutlook(outDate As String, outDauer As Long, outTeilnehmer As String, outTeilnehmer2 As String, outTeilnehmer3 As String, outSubject As String, outBody As String, outlocation As String) As Boolean
Set OutApp = CreateObject("Outlook.Application")
Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem)
With apptOutApp
.MeetingStatus = olMeeting
'Datum und Uhrzeit - als Start-Uhrzeit 8:00 -
.Start = Format(outDate, "dd.mm.yyyy") & " 15:30"
.Display
.Subject = outSubject
.Location = outlocation '
.Duration = outDauer
.Recipients.Add (outTeilnehmer)
.Recipients.Add (outTeilnehmer2)
.OptionalAttendees = (outTeilnehmer3) 'Hier habe ich nur versucht, ob ich das auch per Optional Attendees machen kann.
.Body = "Das ist ein Test"
.Recipients.Add (outTeilnehmer3)
.ReminderPlaySound = True
.ReminderSet = True
.Save
.Send
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
Wie gesagt, an vielen Stellen zusammengeklaubt, aber es funktioniert noch nicht ganz...
Vielen Dank für eure Hilfe!
Euer Constantin :)
|