|
Hallo zusammen.
Ich möchte Outlook Aufgaben ins Excel exportieren. Dafür habe ich auch ein VBA-Programm von Herrn Kristian Zarse (Link zum Makro http://www.wer-weiss-was.de/theme156/article2012892.html) gefunden. Ich habe es ein wenig nach meinem "Gut-Dünken" angepasst und es funktioniert so weit.
Der Ablauf ist nun so: Neues Excel-File wird geöffnet, Aufgaben inkl. aller Angaben werden eingefügt und das File wird gespeichert. In meinem Fall als test.xls.
Ich möchte nun aber gerne das Excel-Sheet nun weiterbearbeiten. z.B. leere Zeilen entfernen, Titel einfügen etc. Ich bin aber bis jetzt noch nicht darauf gekommen wie ich solche Schritte in dem erstellten Excel Sheet machen kann. Egal wo ich den Befehl einfüge es tut sich nichts in dem "test.xls"
Kann mir jemand kurz erklären wie ich dieses Sheet wieder "aktiviere" und beispielsweise eine Zeile "grün" markiere?
Hier nun also mal mein VBA. Ich danke schon im Voraus und Grüsse aus der Schweiz
SwissVBABeginner
Option Explicit
Option Base 1
'####################################################################################
'Artikel: http://www.wer-weiss-was.de/cgi-bin/forum/showarticl...
'Kristian Zarse, 27.04.2004
'####################################################################################
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" 'ggf. mit Pfad angeben, sonst wird im Standard-Excel-Ordner gespeichert
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 'AufgID=0
End Sub 'AufgabenEigenschaftSchreiben
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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 '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 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") 'Excel öffnen
appExcel.Visible = True
Set wbExcel = appExcel.Workbooks.Add 'neue Arbeitsmappe anlegen
If wbExcel.Worksheets.Count > 0 Then
Set wsExcel = wbExcel.Worksheets(1) 'erste Tabelle auswählen bzw. ...
Else
Set wsExcel = wbExcel.Worksheets.Add '... neue Tabelle anlegen
End If 'Count>0
bExcelGeoeffnet = (Err.Number = 0)
On Error GoTo 0
If bExcelGeoeffnet Then
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
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 'OutlookAufgabenExportieren
|