Option Explicit
Option Base 1
Dim Ueberschriften As Variant
Dim appExcel As Excel.Application
Dim wbExcel As Excel.Workbook
Dim wsExcel As Excel.Worksheet
Const ExcelDateiname As String = "Outlook-Aufgaben_2.xls"
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 AufgabenEigenschaftSchreiben(AufgID_ As Integer, EigID_ As Integer, Eigenschaft_ As Variant)
Application.ScreenUpdating = True
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
End Sub
Function EigenschaftValidieren(Eigenschaft_ As Date, Typ_ As Integer) As Variant
Select Case Typ_
Case iDatum
If (Eigenschaft_ <= 0) Or (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
Case iWichtigkeit
Select Case Eigenschaft_
Case olImportanceLow
EigenschaftValidieren = "Niedrig"
Case olImportanceNormal
EigenschaftValidieren = "Normal"
Case olImportanceHigh
EigenschaftValidieren = "Hoch"
End Select
Case iVertraulichkeit
Select Case Eigenschaft_
Case olNormal
EigenschaftValidieren = "Normal"
Case olPersonal
EigenschaftValidieren = "Persönlich"
Case olPrivate
EigenschaftValidieren = "Privat"
Case olConfidential
EigenschaftValidieren = "Vertraulich"
End Select
End Select
End Function
Sub OutlookAufgabenExportieren()
Application.ScreenUpdating = True
Dim a As Integer
Dim e As Variant
Dim tiAufgabe As TaskItem
Dim bExcelGeoeffnet As Boolean
Dim rExcelRange As Excel.Range
With ActiveExplorer.CurrentFolder
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
Set appExcel = CreateObject("Excel.Application")
appExcel.Visible = True
Set wbExcel = appExcel.Workbooks.Add
If wbExcel.Worksheets.Count > 0 Then
Set wsExcel = wbExcel.Worksheets(1)
Else
Set wsExcel = wbExcel.Worksheets.Add
End If
bExcelGeoeffnet = (Err.Number = 0)
On Error GoTo 0
If bExcelGeoeffnet Then
AufgabenEigenschaftSchreiben 0, 0, 0
For a = 1 To .Items.Count
On Error Resume Next
Set tiAufgabe = .Items(a)
With tiAufgabe
AufgabenEigenschaftSchreiben a, 1, .Subject
AufgabenEigenschaftSchreiben a, 2, .Body
AufgabenEigenschaftSchreiben a, 3, EigenschaftValidieren(.CreationTime, iDatum)
AufgabenEigenschaftSchreiben a, 4, EigenschaftValidieren(.LastModificationTime, iDatum)
AufgabenEigenschaftSchreiben a, 5, .IsRecurring
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
AufgabenEigenschaftSchreiben a, 12, EigenschaftValidieren(.ReminderTime, iDatum)
AufgabenEigenschaftSchreiben a, 13, .Owner
AufgabenEigenschaftSchreiben a, 14, EigenschaftValidieren(.DateCompleted, iDatum)
AufgabenEigenschaftSchreiben a, 15, .TotalWork
AufgabenEigenschaftSchreiben a, 16, .ActualWork
End With
On Error GoTo 0
Next a
a = a - 1
End If
On Error Resume Next
wbExcel.SaveAs "C:\Documents and Settings\CHFRABEN\Desktop\test.xls"
Set wsExcel = Nothing
Set wbExcel = Nothing
Set appExcel = Nothing
End If
End With
End Sub