Excel2010 - Hilfe beim Umschreiben eines Makros
28.08.2014 08:25:45
Andreas
hoffe, dass mir hier geholfen werden kann.
Habe mir im Netz nen geniales Makro gezogen.
Jetzt würde ich gerne dieses umschreiben, leider fehlen diesbezüglich die notwendigen Kennntisse.
Anbei natürlich das Makro. Hier wird eine Outlook- Aufgabe aus Excel erstellt.
Dieses Makro soll aus Excel2010 über ein button ausgelöst werden.
Anstatt nach einer der Dauer von 20Tagen zu fragen, soll ein Datum aus einer Zelle übernommen werden. Standard mäßig soll immer ein Tag vorher ein Erinnerung erscheinen. Könnt ihr mir hierbei helfen?
Zweite Frage: Wenn ich diese Excel datei öffne(doppelklick) und makro ausführe, funktioniert das einwandrfrei. Wenn ich aber diese Datei mit nem Hyperlink aus ner anderen Datei öffne und das Makro ausführe, meckert er!(Datei wurde nicht gespeichert) Würde gerne dieses Gimmick gerne behalten!
Gruß Hauenkrieger
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
'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("Wann soll der Auftrag fertig sein?", "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 !")
'Datum wann die Aufgabe erledigt sein muss
.DueDate = myToDo
'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
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(myToDo - myRemBefore, 2)
Case 7
myToDo = myToDo - 2
Case 6
myToDo = myToDo - 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 = myToDo & " " & TimeSerial(8, 0, 0)
'Der Einfachheit halber wird das Startdatum auf den gleichen Termin gesetzt
.startDate = myToDo
'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 = "Diese Datei muss nochmals bearbeitet werden:" & Chr$(13) & _
"\\Server\ShareName\Ordner\" & ActiveWorkbook.Name & Chr$(13) & _
"oder:" & Chr$(13) & "file://" & myLink
'Die Aufgabe wird definitiv gespeichert
.Save
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