zurück zur Übersicht

   
Autor: Tunarus Termine von Outlook an Word übergeben
 
Hi zusammen,

hier mal etwas für Fortgeschrittene:

Wer mit Outlook arbeitet und seine Termine dort verwaltet stand sicher schon einmal vor dem Problem diese Termine übersichtlich zu listen um sie beispielsweise in dieser Listenform weiterzugeben oder ähnliches. Hier also eine Möglichkeit eingetragene Termine als Liste in ein Word-Dokument zu überführen:

1.) Outlook und Word starten
2.) In Outlook mit der Tastenkombi [Alt] & [F11] den VBA-Editor aufrufen
3.) Menübefehl "Extras - Verweise" aufrufen
4.) Den Verweis auf die "Microsoft Word Objekt Library" aktivieren und mit OK bestätigen. Je nach Word-Version kann hier 7.0 bis 10.0 auftauchen
5.) Über den Menübefehl "Einfügen - Modul" ein neues Modul hinzufügen
6.) Im neuen Modul folgendes erfassen (am Besten per Copy & Paste direkt aus diesem Fenster)

Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer

Sub TermineAnWord()
Dim objWord As Word.Application
Dim objOutlook As Outlook.Application
Dim objNamespace As NameSpace
Dim objAlleTermine As Items
Dim objTermineGefiltert As Items
Dim objTermin As AppointmentItem
Dim strRestrict As String, strResult As String
Dim strZeile As String
Dim dtStart As Date, dtEnd As Date
Dim intKW As Integer, intMonat As Integer
Dim lngSelStart As Long

On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If Err <> 0 Then
Beep
MsgBox "Word nicht gefunden!", vbOKOnly + _
vbCritical, "!!! Problem !!!"
Exit Sub
End If

Set objOutlook = GetObject("Outlook.Application")
Set objNamespace = GetNamespace("MAPI")
Set objAlleTermine = _
objNamespace.GetDefaultFolder(olFolderCalendar).Items

objAlleTermine.Sort "[Start]"
objAlleTermine.IncludeRecurrences = True

'Spaltenüberschriften
strResult = "Datum" & vbTab & _
"Uhrzeit" & vbTab & _
"Termin" & vbTab & _
"Notizen" & vbCrLf

'Default: Heute...
dtStart = CDate(Now)
dtEnd = CDate(Now)

'Umschalt gedrückt?
If Abs(GetKeyState(16) < 0) Then 'Woche...
intKW = Val(Format$(Now, "ww")) 'Kalenderwoche
While Val(Format$(dtStart, "ww")) = intKW
dtStart = dtStart - 1
Wend
While Val(Format$(dtEnd, "ww")) = intKW
dtEnd = dtEnd + 1
Wend
'Strg gedrückt?
ElseIf Abs(GetKeyState(17) < 0) Then 'Monat
intMonat = Month(Now)
While Month(dtStart) = intMonat
dtStart = dtStart - 1
Wend
While Month(dtEnd) = intMonat
dtEnd = dtEnd + 1
Wend
End If 'Sondertaste prüfen

'Laufende Termine prüfen...
strRestrict = "[Start] < " & _
Chr$(34) & Format(dtStart, _
"dd mmm yyyy") & " 12:00 AM" & Chr$(34) & _
" AND [End] > " & _
Chr$(34) & Format(dtEnd, _
"dd mmm yyyy") & " 12:00 AM" & Chr$(34)
Set objTermineGefiltert = _
objAlleTermine.Restrict(strRestrict)

For Each objTermin In objTermineGefiltert
GoSub ZeileAufbauen
Next

'Termine im Zeitraum...
strRestrict = "[Start] >= " & _
Chr$(34) & Format(dtStart, "dd mmm yyyy") & _
" 12:00 AM" & Chr$(34) & _
" AND [Start] < " & _
Chr$(34) & Format(dtEnd + 1, _
"dd mmm yyyy") & " 12:00 AM" & Chr$(34)
Set objTermineGefiltert = _
objAlleTermine.Restrict(strRestrict)

For Each objTermin In objTermineGefiltert
GoSub ZeileAufbauen
Next

'In Word einfügen
Err = 0
On Error GoTo 0
With objWord
If .Documents.Count = 0 Then
Documents.Add
End If
lngSelStart = Selection.Start
.Selection.TypeText strResult
.Selection.Start = lngSelStart
Selection.Range.ConvertToTable vbTab
End With
objWord.Activate
objWord.WindowState = wdWindowStateMaximize

Set objWord = Nothing
Set objTermin = Nothing
Set objTermineGefiltert = Nothing
Set objAlleTermine = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
Exit Sub

ZeileAufbauen:
strZeile = ""
If objTermin.AllDayEvent Then
strZeile = strZeile & Format$(objTermin.Start, _
"Ddd, d.m.yyyy") & vbTab & "Serie" & vbTab
Else
strZeile = strZeile & Format$(objTermin.Start, _
"Ddd, d.m.yyyy") & vbTab & _
FormatDateTime(objTermin.Start, vbShortTime) & _
" - " & FormatDateTime(objTermin.End, _
vbShortTime) & vbTab
End If

strZeile = strZeile & objTermin.Subject
If objTermin.Location <> "" Then
strZeile = strZeile & " (" & objTermin.Location & ")"
End If
strZeile = strZeile & vbTab

If objTermin.Body <> "" Then
strZeile = strZeile & objTermin.Body
End If
If Right$(strZeile, 1) = vbTab Then
strZeile = Left$(strZeile, Len(strZeile) - 1)
End If
strResult = strResult & strZeile & vbCrLf
Return 'ZeileAufbauen...

End Sub

7.) Das Modul mit der Tastenkombi [Strg] & [S] speichern und den VBA-Editor schließen
8.) Sicherstellen, dass Makros ausgeführt werden können. Dazu in Outlook über den Menübefehl "Extras - Makro - Sicherheit" die Sicherheitsstufe "Mittel" aktivieren
9.) Über die Tastenkombi [Alt] & [F8] die Makros anzeigen lassen
10.) Das Makro "TermineAnWord" ausführen:
-einfach ausgeführt werden die Termine des aktuellen Tages an Word übergeben
-zusammen mit der [Umschalt]-Taste werden werden die Termine der aktuellen Woche an Word übergeben
-zusammen mit der [Strg]-Taste werden die Termine des aktuellen Monats an Word übergeben
einfach die Tasten beim Klick auf die Schaltfläche "Ausführen" gedrückt halten

Ihr könnt das Makro auch auf eine Schaltfläche legen:
1.) Menü Ansicht - Symbolleisten - Anpassen... - Register "Befehle" - Kategorie "Makros" - Befehl "ProjektX.TermineAnWord" mit der linken Maustaste auf eine beliebige Position einer Symbolleiste ziehen und da fallen lassen (drag & drop)
2.) Rechte Maustaste auf die neue Schaltfläche und "Standard" auswählen
3.) Erneut rechte Maustaste auf die Schaltfläche und über "Schaltflächensymbol ändern" ein passendes Symbol aussuchen.
4.) Dialog "Anpassen" schließen

feddich

Viele Grüße,
Tunarus

 
   

zurück zur Übersicht