Zeilen aus Liste in Outlook-Aufgabe exportieren

Sub Excel_an_Outlook_Aufgabe()
'Dieses Code-Beispiel sollte ab Outlook XP sicher funktionieren
'O 2000 und O97 wurden nicht getestet
'Einschaltung der Fehlerbehandlung
On Error GoTo ErrorToDo
'Verwendete Variablen
Dim myToDo As Date, myDay As String, myRemBefore As Integer, myToInterVal
Dim Qe As Integer
Dim myLink As String
Dim T1 As String, T2 As String, T3 As String, T4 As String
Dim MyOlApp As Object, myJob As Object
'Für Terminkontrolle verwendete Variablen
'Müssen noch angepasst werden!
'Gehe zu Zelle in 1. Spalte
'vBetreff = aktuelle Zelle
'vFaelligAm = aktuelle Zelle + 3 Spalten
'vBeginntAm = aktuelle Zelle + 3 Spalten
'vBemerkungen = ActiveCell + 4 Spalten
'In diesem Beispiel soll der Link auf die aktuelle Datei aufgenommen werden
'um den Inhalt zum gewählten Termin nochmal nachbearbeiten zu können.
'Der Link kann direkt in der Aufgabe angeklickt werden
'Dateiname aufnehmen für einen späteren Link
myLink = ActiveWorkbook.FullName
'Ist kein Doppelpunkt vorhanden in "Fullname" wurde die Datei
'noch nicht gespeichert, daher wird die weitere Verarbeitung
'des Makros abgebrochen.
If Mid(myLink, 2, 1)  ":" Then
MsgBox "Die Datei wurde noch nicht gespeichert"
Exit Sub
End If
'Aufgabe erstellen heute in X Tagen
'Erzwingen eines korrekten Wertes
'Do
'    myDay = InputBox("In wieviel Tagen soll die Aufgabe erstellt werden ?", "Neue Aufgabe", _
_
20)
'Loop While Not IsNumeric(CInt(myDay)) Or CInt(myDay)  5
T1 = "Die Aufgabe würde auf ein Wochenende fallen: " & Format(myToDo, "DDDD DD.MMM.  _
_
YY")
T2 = "JA = Die Aufgabe wird auf den darauffolgenden Montag verschoben"
T3 = "NEIN = Die Aufgabe auf den Freitag davor verlegt"
T4 = "ABBRECHEN = Die Aufgabe wird am berechneten Termin eingefügt"
Qe = MsgBox(T1 & Chr$(13) & T2 & Chr$(13) & T3 & Chr$(13) & T4, vbYesNoCancel, " _
Terminkorrektur")
If Qe = vbYes Then
'Termin auf Montag vorverlegen
myToDo = myToDo + (8 - Weekday(myToDo, 2))
ElseIf Qe = vbNo Then
'Termin auf Freitag zurücklegen
myToDo = myToDo - (7 - Weekday(myToDo, 2))
End If
End Select
'Eigentliche Aufgabe erstellen
'Objectvariablen zuweisen
Set MyOlApp = CreateObject("Outlook.Application")
'CreateItem(3) erstellt ein Aufgaben-Object
Set myJob = MyOlApp.CreateItem(3)
With myJob
'Titel der Aufgabe
'.Subject = InputBox("Beschreibung der Aufgabe", "Aufgaben Titel", "Datei  _
Nachbearbeiten !")
.Subject = vBetreff
'Datum wann die Aufgabe erledigt sein muss
.DueDate = vFaelligAm
'Erinnerung in Tagen davor
'In diesem Beispiel wird per default 1 Tag vorher,
'bzw. am Freitag vor einem Montag informiert
'Es werden jedoch max. 30 Tage Vorlaufzeit akzeptiert
'myToDoRem = myToDo
'Do
'    myRemBefore = 1
'    myRemBefore = CInt(InputBox("Wieviel Tage davor:", "Erinnerung max. 30 Tage",  _
myRemBefore))
'Loop While Not IsNumeric(myRemBefore) Or myRemBefore > 30
'Select Case Weekday(myToDoRem - myRemBefore, 2)
'    Case 7
'        myToDoRem = myToDoRem - 2
'    Case 6
'        myToDoRem = myToDoRem - 1
'End Select
'Erinnerung einschalten !!!
.ReminderSet = True
'Für eine Reminder-Uhrzeit muss auch das Datum angegeben
'werden, ansonsten Outlook den 1.1.1900 um 08:00 erinnert :-) !!
'Uhrzeit definieren im Serialformat
'Stunde, Minute, Sekunde
'.Remindertime = myToDoRem & " " & TimeSerial(8, 0, 0)
.Remindertime = vFaelligAm & " " & TimeSerial(8, 0, 0)
'Der Einfachheit halber wird das Startdatum auf den gleichen Termin gesetzt
.startDate = vBeginntAm
'Die Wichtigkeit der Aufgabe
'Werte 1,2 und 3 zulässig
.Importance = 2
'Zwecks Optimierung können Sie auch gleich einen Link
'auf ihre Datei erstellen die auf Ihrem Rechner oder Netzwerk liegt
'Wird ein Dateilink mit "\\" erkennt Outlook automatisch dass es ein Link ist
'Bei lokalen Dateien müssen sie den Zusatz "File:" davorsetzen
'um den Link auf die Datei zu erzeugen
'Der Pfad und Dateiname dürfen KEINE Leerzeichen enthalten
'ansonsten wird der Link nicht korrekt dargestellt
.Body = "Bei Erledigung Datum in Termindatei eintragen:" & Chr$(13) & "file://" &  _
myLink
'Die Aufgabe wird definitiv gespeichert
.Save
MsgBox ("Aufgabe gespeichert")
End With
ErrorExit:
Set myJob = Nothing
Set MyOlApp = Nothing
Exit Sub
ErrorToDo:
Select Case Err.Number
Case 13
'Ohne Information aus dem Makro aussteigen
'Der Fehler 13 kommt bei einer Typ-Unverträglichkeit vor
'also z.B. "Abbrechen" in einer Inputbox
Resume ErrorExit
Case Else
'Information an den Benutzer
MsgBox Err.Number & ";" & Err.Description
'Abbruch des Makros
Resume ErrorExit
End Select
End Sub