Spät, aber es kommt:
Option Explicit
Option Base 1
'######################################################################################
' Artikel: http://www.wer-weiss-was.de/cgi-bin/forum/showarticle.fpl?ArtikelID=2012892
' Kristian Zarse, 17.02.2004
' geändert am 27.02.2004 (jetzt ist es ein Excel-Makro und kein Outlook-Makro mehr)
'
' Das Makro läuft nur, wenn Outlook installiert und hier im VBA registriert ist.
' Letzteres erfolgt im Menü "Extras / Verweise...".
' Dort nach "Microsoft Outlook 9.0 Object Library" suchen und diese anticken.
'######################################################################################
Dim appOL As Outlook.Application 'Outlook-Applikation
Dim olNameSpace As NameSpace 'Outlook-Datenbasis
Dim arrOrdner As Variant 'zweidimensionales Feld, das sich die Aufgaben-Ordner "merkt"
Dim Ueberschriften As Variant
Dim wbExcel As Workbook
Dim wsExcel As Worksheet
Const iDatum As Integer = 1
Const iStatus As Integer = 2
Const iWichtigkeit As Integer = 3
Const iVertraulichkeit As Integer = 4
Const xOffset As Integer = 1
Const yOffset As Integer = 2
'##########################################################################################
Sub Main()
Dim iOrdner As Integer
On Error Resume Next
' Outlook-Objekt instanzieren (Outlook wird ggf. gestartet)
Set appOL = New Outlook.Application
' Das Teil enthält u.a. die Outlook-Ordner:
Set olNameSpace = appOL.GetNamespace("MAPI")
If Err.Number 0 Then
MsgBox "Outlook konnte nicht geöffnet werden!", vbCritical, "Fehler"
GoTo MainEnde
End If 'Err.Number0
On Error GoTo 0
iOrdner = OrdnerAuswahl
If iOrdner \> 0 Then '-1: Abbruch, -2: Fehler, \>0: gültige Auswahl
Call OutlookAufgabenImportieren(iOrdner)
End If 'iOrdner\>0
MainEnde:
Set olNameSpace = Nothing
Set appOL = Nothing
End Sub 'Main
'##########################################################################################
Function OrdnerAuswahl() As Integer
Dim i As Integer 'Schleifen-Zähler
Dim k As Integer 'Schleifen-Zähler
Dim o As Integer 'zählt die Aufgaben-Ordner
Dim sOrdnerListe As String 'Auswahltext mit der Aufgaben-Ordner-Liste.
o = 0 'noch wurden keine Aufgaben-Ordner gefunden
ReDim arrOrdner(4, 1) 'Vier Informationen sollen pro Ordner gespeichert werden.
With olNameSpace
' i zählt die Ordner auf der höchsten Ebene.
For i = 1 To .Folders.Count
' k zählt die jeweiligen Unterordner.
For k = 1 To .Folders(i).Folders.Count
' Es werden nur Ordner gewertet, die vom Typ "Aufgaben" sind
' und die mindestens ein Element (gleich, welcher Art) enthalten.
If (.Folders(i).Folders(k).DefaultItemType = olTaskItem) And \_
(.Folders(i).Folders(k).Items.Count \> 0) Then
o = o + 1
ReDim Preserve arrOrdner(4, o)
arrOrdner(1, o) = i
arrOrdner(2, o) = k
arrOrdner(3, o) = .Folders(i).Name
arrOrdner(4, o) = .Folders(i).Folders(k).Name
End If 'Typ=Task
Next k
Next i
End With 'olNameSpace
' Hinweis: Die obige Prozedur findet nur Aufgaben-Ordner, die sich in der zweiten
' Hierarchie-Ebene befinden. Ordner, auf der höchsten Ebene oder Unterordner ab
' Ebene drei werden nicht berücksichtigt. Klar könnte man das auch machen, aber
' das ist mir jetzt zu aufwendig, zumal es wohl eher selten nötig sein wird.
' Notfalls muss eben mal ein Ordner entpsrechend verschoben werden zum Auslesen.
If o = 0 Then
MsgBox "Es wurden keine Aufgaben-Ordner gefunden. Abbruch.", vbExclamation, "Fehler"
Else
sOrdnerListe = ""
For i = 1 To o
' Dies ergibt eine Liste der gefundenen Ordner, die dann angezeigt wird:
sOrdnerListe = sOrdnerListe & i & " = " & arrOrdner(4, i) & " [" & arrOrdner(3, i) & "]" & vbCrLf
Next i
' Die Variable "sOrdnerListe" wird hier "recyclet" und enthält anschließend nur noch die Auswahl.
sOrdnerListe = InputBox(sOrdnerListe & vbCrLf & "Auswahl:", "Bitte einen Ordner auswählen")
If sOrdnerListe = "" Then
MsgBox "Das Programm wird wunschgemäß abgebrochen.", vbExclamation, "Abbruch"
o = -1 'signalisiert den Abbruch
Else
On Error Resume Next
i = CInt(sOrdnerListe)
If Err.Number 0 Then
MsgBox "Die Eingabe """ & sOrdnerListe & """ ist keine Zahl zwischen 1 und " & o & "!" & vbCrLf & \_
"Das Programm wird abgebrochen.", vbCritical, "Fehler"
o = -2 'signalisiert den Fehler
Else
o = i
End If 'Err.Number0
On Error GoTo 0
End If 'sOrdnerListe=""
End If 'o=0
OrdnerAuswahl = o
End Function 'OrdnerAuswahl
'##########################################################################################
Sub AufgabenEigenschaftSchreiben(AufgID\_ As Integer, EigID\_ As Integer, Eigenschaft\_ As Variant)
Dim ue As Integer
If AufgID\_ = 0 Then
For ue = 1 To UBound(Ueberschriften)
wsExcel.Cells(AufgID\_ + yOffset, ue + xOffset).Value = Ueberschriften(ue)
Next ue
Else
wsExcel.Cells(AufgID\_ + yOffset, EigID\_ + xOffset).Value = Eigenschaft\_
End If 'AufgID=0
End Sub 'AufgabenEigenschaftSchreiben
'##########################################################################################
Function EigenschaftValidieren(Eigenschaft\_ As Date, Typ\_ As Integer) As Variant
Select Case Typ\_
Case iDatum
If (Eigenschaft\_ = 949998) Then
EigenschaftValidieren = "-"
Else
EigenschaftValidieren = Eigenschaft\_
End If
Case iStatus
Select Case Eigenschaft\_
Case olTaskNotStarted
EigenschaftValidieren = "Nicht begonnen"
Case olTaskInProgress
EigenschaftValidieren = "In Bearbeitung"
Case olTaskComplete
EigenschaftValidieren = "Erledigt"
Case olTaskWaiting
EigenschaftValidieren = "Wartet auf jemand anderen"
Case olTaskDeferred
EigenschaftValidieren = "Zurückgestellt"
End Select 'iStatus
Case iWichtigkeit
Select Case Eigenschaft\_
Case olImportanceLow
EigenschaftValidieren = "Niedrig"
Case olImportanceNormal
EigenschaftValidieren = "Normal"
Case olImportanceHigh
EigenschaftValidieren = "Hoch"
End Select 'iWichtigkeit
Case iVertraulichkeit
Select Case Eigenschaft\_
Case olNormal
EigenschaftValidieren = "Normal"
Case olPersonal
EigenschaftValidieren = "Persönlich"
Case olPrivate
EigenschaftValidieren = "Privat"
Case olConfidential
EigenschaftValidieren = "Vertraulich"
End Select 'iVertraulichkeit
End Select 'Typ\_
End Function 'DatumValidieren
'##########################################################################################
Sub OutlookAufgabenImportieren(iOrdner\_ As Integer)
Dim a As Integer
Dim e As Variant
Dim tiAufgabe As Outlook.TaskItem
Dim bExcelGeoeffnet As Boolean
Dim rExcelRange As Range
With olNameSpace.Folders(arrOrdner(1, iOrdner\_)).Folders(arrOrdner(2, iOrdner\_))
If (.Items.Count \> 0) And (True) Then
Ueberschriften = Array( \_
"Betreff", \_
"Text", \_
"Angelegt", \_
"Modifiziert", \_
"Serie", \_
"Fällig am", \_
"Begonnen am", \_
"Status", \_
"Priorität", \_
"Vertraulichkeit", \_
"% erledigt", \_
"Erinnerung", \_
"Zuständig", \_
"Erledigt am", \_
"Gesamtaufwand", \_
"Ist-Aufwand")
On Error Resume Next
If Workbooks.Count \> 0 Then
Set wbExcel = ActiveWorkbook 'aktive Arbeitsmappe auswählen bzw. ...
Else
Set wbExcel = Workbooks.Add '... neue Arbeitsmappe anlegen
End If 'Count\>0
' neue Tabelle anlegen
Set wsExcel = wbExcel.Worksheets.Add(, wbExcel.Worksheets(wbExcel.Worksheets.Count))
bExcelGeoeffnet = (Err.Number = 0)
On Error GoTo 0
If bExcelGeoeffnet Then
On Error Resume Next
wsExcel.Name = arrOrdner(4, iOrdner\_)
a = 0
While Err.Number 0
Err.Clear
a = a + 1
wsExcel.Name = arrOrdner(4, iOrdner\_) & "\_" & a
Wend 'Err.Number0
On Error GoTo 0
AufgabenEigenschaftSchreiben 0, 0, 0 'Überschriften schreiben
For a = 1 To .Items.Count
On Error Resume Next
Set tiAufgabe = .Items(a)
With tiAufgabe
AufgabenEigenschaftSchreiben a, 1, .Subject 'Text
AufgabenEigenschaftSchreiben a, 2, .Body 'Text
AufgabenEigenschaftSchreiben a, 3, EigenschaftValidieren(.CreationTime, iDatum)
AufgabenEigenschaftSchreiben a, 4, EigenschaftValidieren(.LastModificationTime, iDatum)
AufgabenEigenschaftSchreiben a, 5, .IsRecurring 'Wahrheitswert
AufgabenEigenschaftSchreiben a, 6, EigenschaftValidieren(.DueDate, iDatum)
AufgabenEigenschaftSchreiben a, 7, EigenschaftValidieren(.StartDate, iDatum)
AufgabenEigenschaftSchreiben a, 8, EigenschaftValidieren(.Status, iStatus)
AufgabenEigenschaftSchreiben a, 9, EigenschaftValidieren(.Importance, iWichtigkeit)
AufgabenEigenschaftSchreiben a, 10, EigenschaftValidieren(.Sensitivity, iVertraulichkeit)
AufgabenEigenschaftSchreiben a, 11, .PercentComplete / 100 'Prozent
AufgabenEigenschaftSchreiben a, 12, EigenschaftValidieren(.ReminderTime, iDatum)
AufgabenEigenschaftSchreiben a, 13, .Owner 'Text
AufgabenEigenschaftSchreiben a, 14, EigenschaftValidieren(.DateCompleted, iDatum)
AufgabenEigenschaftSchreiben a, 15, .TotalWork 'in Minuten angegeben
AufgabenEigenschaftSchreiben a, 16, .ActualWork 'in Minuten angegeben
End With 'tiAufgabe
On Error GoTo 0
Next a
a = a - 1
' Tabelle formatieren
Set rExcelRange = wsExcel.Range(Cells(yOffset, xOffset + 1), Cells(yOffset + a, xOffset + UBound(Ueberschriften)))
With rExcelRange
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic
.Columns.AutoFit
End With 'rExcelRange
' Tabellen-Überschrift formatieren
Set rExcelRange = wsExcel.Range(Cells(yOffset, xOffset + 1), Cells(yOffset, xOffset + UBound(Ueberschriften)))
With rExcelRange
.BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic
.Interior.ColorIndex = 37
.Font.Bold = True
End With 'rExcelRange
Set rExcelRange = Nothing
Else
MsgBox "Es konnte keine neue Arbeitsmappe bzw. Tabelle erstellt werden!", vbCritical, "Fehler"
End If 'bExcelGeoeffnet
Else
MsgBox "Im Outlook-Ordner """ & arrOrdner(3, iOrdner\_) & " / " & arrOrdner(4, iOrdner\_) & """ liegen keine Aufgaben-Elemente vor!", vbCritical, "Fehler"
End If '.Items.Count\>0
End With 'ActiveExplorer.CurrentFolder
Set wsExcel = Nothing
Set wbExcel = Nothing
End Sub 'OutlookAufgabenImportieren
'##########################################################################################
Dies in ein Excel-VBA-Modul packen und die Main() starten.
Kristian
