Aufgabe in eigenes und fremdes Outlook eintragen
31.08.2016 14:22:33
Rico
Ich brauche noch einmal kompetente Hilfe zum Thema VBA:
In einer Excel-Tabelle werden Aufgaben und Termine erstellt und per Makro in Outlook eingetragen. Durch die Recherche im Forum habe ich auch das Passende gefunden und dank Chris auch auf meine Bedürfnisse anpassen können. An dieser Stelle nochmals vielen Dank dafür!
Was mir jetzt noch fehlt, ist folgendes: Die Aufgabe soll nicht nur in meinem Outlook eingetragen werden (was ja schon funktioniert), sondern auch (per Mail?) in den Kalender des Anforderers bzw. des Ausführenden. Die Namen und damit Mailadressen ändern sich aber je nach Aufgabenstellung.
Ich gebe zu, dass ich für diesen Code nicht den Pulitzer-Preis gewinnen werde, aber ich bin in VBA nicht so fit:
Sub Excel_Control_Termin_nach_Outlook()
'Termine werden von einer Excel-Liste nach Outlook übertragen
Dim OutApp As Object, apptOutApp As Object
Dim BlattName As String
Dim Zeile As Integer
Dim EmailNamen As String
BlattName = "Arbeitsauftragstracker"
For Zeile = 4 To Sheets(BlattName).UsedRange.Rows.Count
Set OutApp = CreateObject("Outlook.Application")
Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem
If IsDate(Sheets(BlattName).Cells(Zeile, 7)) Then 'Datum vorhanden
If IsEmpty(Sheets(BlattName).Cells(Zeile, 10)) = True Then 'Status ohne Wert
With apptOutApp
'Als Datum wird der Termin aus Spalte G genommen
.Start = Format(Sheets(BlattName).Cells(Zeile, 7), "dd.mm.yyyy") & " 08:00"
'Beschreibung der Aufgabe
.Subject = "Auftrag: " & Sheets(BlattName).Cells(Zeile, 3)
'Zusätzlicher Text (Arbeitsauftrags-Nr.)
Nachricht = Sheets(BlattName).Cells(Zeile, 2) & Chr(10)
'Nachricht = Nachricht & "weiterer Text möglich"
.Body = Nachricht
'Anzeige
.display
'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen
.Duration = "480"
'Erinnerung
.ReminderMinutesBeforeStart = 10080
'mit Sound?
.ReminderPlaySound = False
'Erinnerung wiederholen
.ReminderSet = True
'Status
.MeetingStatus = olMeeting
'Termin speichern
.Save
'Schließen ohne senden
Application.SendKeys "%DL"
'Erledigt setzen und Bemerkung in Spalte J einfügen
Sheets(BlattName).Cells(Zeile, 10) = "in Outlook übernommen"
End With
ActiveCell.Offset(1, 0).Select
' Variablen leeren,
End If
End If
Set apptOutApp = Nothing
Set OutApp = Nothing
Next Zeile
End Sub
Für Eure Hilfe bedanke ich mich schon einmal vorab!
Viele Grüße
Rico
https://www.herber.de/bbs/user/107920.xlsm