Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
972to976
972to976
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Zeilen aus Liste in Outlook-Aufgabe exportieren

Zeilen aus Liste in Outlook-Aufgabe exportieren
05.05.2008 13:53:24
Erni
Guten Tag
Ich habe untenstehendes Script gefunden und möchte es nun auf eine ExcelAufgabenliste anpassen.
Es geht um die Variablen
vBetreff = aktuelle Zelle
vFaelligAm = aktuelle Zelle + 3 Spalten
vBeginntAm = aktuelle Zelle + 3 Spalten
vBemerkungen = ActiveCell + 4 Spalten
Die Liste ist so aufgebaut:
Spalte A = Betreff
Spalte C = Beginnt am
Spalte D = Fällig am
Spalte E = Bemerkungen
Meine Idee ist:
- Benutzer hat Markierung irgendwo in der entsprechenden Zeile
- Klick auf Button Exportieren
- Makro geht zur Spalte A
- vBetreff = aktuelle Zelle
- vBeginntAm = aktuelle Zelle + 2 Spalten
- vFaelligAm = aktuelle Zelle + 3 Spalten
- vBemerkungen = aktuelle Zelle + 4 Spalten
  • 
    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
    



  • Vielen Dank für eure Unterstützung
    Gruess Andreas Erni

    4
    Beiträge zum Forumthread
    Beiträge zu diesem Forumthread

    Betreff
    Datum
    Anwender
    Anzeige
    AW: Zeilen aus Liste in Outlook-Aufgabe exportieren
    06.05.2008 16:10:41
    Tino
    Hallo,
    hab hier mal ein Beispiel, getestet unter Office 2003
    !!!! Benötigt den Verweis auf Microsoft Outlook 11.0 Object Library !!!!
    
    Option Explicit
    'Aufgaben erstellen*****************************************************
    'Benötigt den Verweis auf
    'Microsoft Outlook 11.0 Object Library
    Sub AufgabeAnlegen()
    Dim myOlApp As New Outlook.Application
    Dim myItem As Outlook.TaskItem
    Dim myDelegate As Outlook.Recipient
    Dim wer As String, Erst As Date, Bis As Date, TXT As String, _
    Betr As String, Them As String
    Set myItem = myOlApp.CreateItem(olTaskItem)
    myItem.Assign
    wer = Range("A2") 'Name oder Mailadresse
    Erst = Range("B2") 'StartDatum
    Bis = Range("C2") 'erledigen bis Datum
    TXT = Range("A3") 'Text Body
    Betr = Range("D2") 'Betreffzeile
    Them = Range("E2") 'Thema
    Set myDelegate = myItem.Recipients.Add(wer)
    myDelegate.Resolve
    With myItem
    .Subject = Betr
    .Body = TXT
    .Categories = Them 'Thema
    .DueDate = Bis 'erledigen bis Datum
    .StartDate = Erst 'Start Aufgabe
    .Display
    .Save
    '            .Send
    End With
    Set myItem = Nothing
    End Sub
    


    Gruß
    Tino

    Anzeige
    AW: Zeilen aus Liste in Outlook-Aufgabe exportieren
    07.05.2008 13:57:00
    Erni
    Hallo Tino
    danke für deinen Input. Der Export funktioniert soweit, nur habe ich folgendes Problem:
    Das Ganze ist eine Terminliste mit den Spalten
    Spalte A = Betreff
    Spalte C = Beginnt am
    Spalte D = Fällig am
    Spalte E = Bemerkungen
    in dieser Liste gibt es eine vielzahl von Terminen welche ich einzeln mit einem Klick exportieren möchte, da nicht alle Termine jeden betreffen. Darum soll auch nur die Zeile exportiert werden in welcher sich die Markierung befindet.
    Beim klick in der Zeile wo sich die Markierung befindet, soll die Zelle in der Spalte A markiert werden.
    Dies wäre dann vBetreff = ActiveCell bzw. Betr = ActiveCell 'Betreffzeile.
    Als nächstes müsste die Zelle in der Spalte C markiert werden, dies wäre dann vFaelligAm = ActiveCell
    Hast du oder jemand anderes einen Tipp wie man zur vordersten Zelle bzw zu nächsten Zelle "hüpfen" kann.
    Danke und Gruss
    Andreas

    Anzeige
    AW: Zeilen aus Liste in Outlook-Aufgabe exportieren
    07.05.2008 14:58:00
    Tino
    Hallo,
    wie wäre es den mit einer Eventgesteuerten Funktion „Doppelklick“?
    Dies würde demnach so aussehen, den Code in dass entsprechende Tabellenblatt.
    
    Option Explicit
    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    'Range("A1:A100") entspricht dem Arbeitsbereich für die Aufgaben
    If Intersect(Target, Range("A1:A100")) Is Nothing Then Exit Sub
    Cancel = True
    If MsgBox("möchten Sie diese Aufgabe übertragen?", vbYesNo, "Nach Outlook?") = vbYes Then
    If AufgabeAnlegen(Target) = True Then
    MsgBox "Aufgabe erfolgreich übertragen!", vbInformation, "Übertragung!"
    Else
    MsgBox "Es sind Fehler bei der Übertragung aufgetreten!", vbCritical, "!!! Fehler !!!"
    End If
    End If
    End Sub
    'Aufgaben erstellen*****************************************************
    'Benötigt den Verweis auf
    'Microsoft Outlook 11.0 Object Library
    Function AufgabeAnlegen(RefZelle As Range) As Boolean
    Dim myOlApp As New Outlook.Application
    Dim myItem As Outlook.TaskItem
    Dim myDelegate As Outlook.Recipient
    Dim wer As String, Erst As Date, Bis As Date, TXT As String, _
    Betr As String, Them As String
    '   On Error GoTo Fehler:
    Set myItem = myOlApp.CreateItem(olTaskItem)
    myItem.Assign
    wer = "Name" 'Name oder Mailadresse
    Erst = RefZelle.Offset(0, 2) 'StartDatum
    Bis = RefZelle.Offset(0, 3) 'erledigen bis Datum
    TXT = RefZelle.Offset(0, 4)  'Text Body
    Betr = RefZelle 'Betreffzeile
    '    Them =  RefZelle.Offset(0, 4) 'Thema
    Set myDelegate = myItem.Recipients.Add(wer)
    myDelegate.Resolve
    With myItem
    .Subject = Betr
    .Body = TXT
    .Categories = Them 'Thema
    .DueDate = Bis 'erledigen bis Datum
    .StartDate = Erst 'Start Aufgabe
    .Display
    .Save
    '            .Send
    End With
    Set myDelegate = Nothing
    Set myItem = Nothing
    AufgabeAnlegen = True
    Exit Function
    Fehler:
    On Error Resume Next
    Set myItem = Nothing
    Set myDelegate = Nothing
    AufgabeAnlegen = False
    End Function
    


    Fruß
    Tino

    Anzeige
    AW: Zeilen aus Liste in Outlook-Aufgabe exportieren
    20.05.2008 16:25:24
    Erni
    Hallo Tino
    Danke für den Code! Habe ihn mit dem restlichen gut "geschüttel" und folgende Variante daraus gemacht. Wir benutzen in der Firma leider immernoch Outlook2002...
    
    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    'Range("A1:A100") entspricht dem Arbeitsbereich für die Aufgaben
    If Intersect(Target, Range("A1:A1000")) Is Nothing Then Exit Sub
    Cancel = True
    If MsgBox("Möchten Sie die Aufgabe ins Outlook übertragen?", vbYesNo, "Nach Outlook?") = vbYes  _
    Then
    If AufgabeAnlegen(Target) = True Then
    MsgBox "Aufgabe erfolgreich übertragen!", vbInformation, "Übertragung!"
    Else
    MsgBox "Es sind Fehler bei der Übertragung aufgetreten!", vbCritical, "!!! Fehler !!!"
    End If
    End If
    End Sub
    'Aufgaben erstellen*****************************************************
    'Benötigt den Verweis auf
    'Microsoft Outlook 11.0 Object Library
    Function AufgabeAnlegen(RefZelle As Range) As Boolean
    '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
    vBetreff = RefZelle 'Betreffzeile
    vFaelligAm = RefZelle.Offset(0, 3) 'StartDatum
    vBeginntAm = RefZelle.Offset(0, 2) 'StartDatum
    'vErinnerung = "01.06.2008"
    '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
    myToDo = vFaelligAm
    'Alternativ die Eingabe eines Datums erzwingen
    'Hier wird die Datumseingabe explicit angefordert
    'Do
    ' myToDo = DateValue(InputBox("In wieviel Tagen soll die Aufgabe erstellt werden ?", "Neue  _
    Aufgabe", Format(Now + 21, "dd.mm.yyyy")))
    'Loop While Not IsDate(myToDo) Or myToDo  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 = 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)
    'Datum "Beginnt am" setzen. In diesem Fall wird die gesetzte Variable verwendet.
    .StartDate = vBeginntAm
    'Die Wichtigkeit der Aufgabe
    'Werte 1 und 2 zulässig
    .Importance = 1
    'Inhalt des Feldes Bemerkungen
    '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 = "Link zur Datei:" & Chr$(13) & "file://" & myLink
    'Die Aufgabe wird definitiv gespeichert
    .Save
    End With
    'ErrorExit:
    '    Set myJob = Nothing
    '    Set myOlApp = Nothing
    'Exit Sub
    Set myDelegate = Nothing
    Set myItem = Nothing
    AufgabeAnlegen = True
    Exit Function
    Fehler:
    On Error Resume Next
    Set myItem = Nothing
    Set myDelegate = Nothing
    AufgabeAnlegen = False
    End Function
    


    Vielen Dank für die Unterstützung!
    Gruss aus der Schweiz
    Andreas

    Anzeige

    Links zu Excel-Dialogen

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige