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