Office - Word, Excel und Co. 9.753 Themen, 41.597 Beiträge

Hallo Forumsmitglieder,

ich habe in OL 2003 einen Ordner mit mehreren verschachtelten Unterordnern. Zum Durchsuchen, Archivieren, usw. benötige ich eine Listenübersicht. Dies erledigt nachstehendes Makro, welches ich im Web gefunden und dann verschiedentlich ergänzt habe.

Hierbei gibt es jedoch noch 2 Probleme:
1.) Der beinhaltende Ordner (z.B. "InFolder") wird nicht angezeigt, da ich nirgends - auch nicht bei MS - die entsprechende Property gefunden habe.
2.) Es werden immer nur die markierten Mails nach Excel exportiert. - Nicht jedoch alle Ordner und Unterordner mit den beinhalteteten Mails - sehr zeitaufwändig.

Beides gravierende Nachteile, will mann doch nach Projekten sortieren!

Hier nun das Makro, ich hoffe, jemand kann helfen:

Sub Export_Mails_Betreff_nach_Excel_ZEITABRECHNUNG()
Dim myOlExp As Outlook.Explorer
Dim MyOlsel As Outlook.Selection
Dim objItem As Object

Dim objWkb As Object 'Excel.Workbook
Dim objWks As Object 'Excel.Worksheet
Dim objExcel As Object 'Excel.Application
Dim i As Integer, j As Integer
'Eingefügt, um die Textkörperlänge zu begrenzen -&ampgt objItem.body
Dim Textkoerper As String
'Eingefügt, um den Ordnernamen mit auszugeben:
Dim objFolder



Set myOlExp = Application.ActiveExplorer
Set MyOlsel = myOlExp.Selection

'Set objExcel = New Excel.Application
Set objExcel = CreateObject("Excel.Application")
Set objWkb = objExcel.Workbooks.Add
Set objWks = objExcel.ActiveSheet

objWks.Cells(1, 1).Value = "Nr.: (EntryID:)."
objWks.Cells(1, 2).Value = "Absender (SenderName)"
objWks.Cells(1, 3).Value = "E-Mail-Adresse (Von:/ From:)"
objWks.Cells(1, 4).Value = "CC:"
objWks.Cells(1, 5).Value = "BCC:"
objWks.Cells(1, 6).Value = "Größe: (Size:)."
objWks.Cells(1, 7).Value = "Empfänger/An: (To:)"
objWks.Cells(1, 8).Value = "Betreff: (Subject)"
objWks.Cells(1, 9).Value = "Inhalt (Body)"
objWks.Cells(1, 10).Value = "Anzahl Anhänge: (Attachments.Count)"
'Don't process if it's not an e-mail - funktioniert leider nicht:
''If objItem.MessageClass &amplt&ampgt "IPM.Note" Then Exit Sub
''Don't process if there aren't attachments
'If objItem.Attachments.Count = 0 Then Exit Sub
'Q: http://www.planet-outlook.de/newsletter/Planet%20Outlook%20Newsletter%20Kw36.htm
objWks.Cells(1, 11).Value = "Nachrichtentyp: (MessageClass)"
objWks.Cells(1, 12).Value = "Formatierter Text: (HTML Body)"
objWks.Cells(1, 13).Value = "Erhalten von: (ReceivedByName)"
objWks.Cells(1, 14).Value = "Erhalten für: (ReceivedOnBehalfOfName)"
objWks.Cells(1, 15).Value = "Empfänger Namen: (ReplyRecipientNames)"
objWks.Cells(1, 16).Value = "Kategorien: (Categories)"
objWks.Cells(1, 17).Value = "Submitted"
objWks.Cells(1, 18).Value = "Session"
objWks.Cells(1, 19).Value = "Sensitivity"
objWks.Cells(1, 20).Value = "RemoteStatus"
objWks.Cells(1, 21).Value = "OutlookInternalVersion"
objWks.Cells(1, 22).Value = "OriginatorDeliveryReportRequested"
objWks.Cells(1, 23).Value = "Dringlichkeit: (Importance)"
objWks.Cells(1, 24).Value = "IsIPFax"
objWks.Cells(1, 25).Value = "InternetCodepage"
objWks.Cells(1, 26).Value = "Application"
objWks.Cells(1, 27).Value = "Erhalten am: (Received)"
objWks.Cells(1, 28).Value = "Erstellt am: (Creation Time)"
objWks.Cells(1, 29).Value = "Gesendet: (Sent on)"
objWks.Cells(1, 30).Value = "Zuletzt geändert: (LastModificationTime)"


For i = 1 To MyOlsel.Count
Set objItem = MyOlsel.Item(i)
objWks.Cells(i + 1, 1).Value = objItem.EntryID
objWks.Cells(i + 1, 2).Value = objItem.SenderName
objWks.Cells(i + 1, 3).Value = objItem.SenderEmailAddress
'Ich habe in der MS Visual Basic Editor-Hilfe schon eine Möglichkeit gefunden den Body in HTML auszugeben --&ampgt
'aber dann wird mir der komplette Quelltext ausgedruck:
'Q: http://www.office-loesung.de/ftopic100074_0_0_asc.php
objWks.Cells(i + 1, 4).Value = objItem.CC
objWks.Cells(i + 1, 5).Value = objItem.BCC
objWks.Cells(i + 1, 6).Value = objItem.Size
objWks.Cells(i + 1, 7).Value = objItem.To
objWks.Cells(i + 1, 8).Value = objItem.Subject
'Funktioniert: If objItem.Class = olMail Then ' Only call this for MailItems - Q: http://vbaadventures.blogspot.com/2008_03_01_archive.html
'objWks.Cells(i + 1, 14).Value = objItem.Class
'Funktioniert, aber derzeit nicht sinnvoll:
'objWks.Cells(i + 1, 14).Value = objItem.BodyFormat
objItem.BodyFormat = olFormatHTML
'objWks.Cells(i + 1, 6).Value = objItem.BodyobjItem.Body - GEHT NICHT!
'lLenText = Len(objItem.Body)
'objWks.Cells(i + 1, 6).Value = ILenText
'TRIM Entfernt die führenden und die Leerzeichen am Ende aus dem Textkörper der E-Mail:
'Textkoerper = RTrim(LTrim(objItem.Body))
'Ab einer Feldlänge des Mailtextes (inkl. Leerzeichen!) von ca. 11558 (dav. 9879 Zeichen) gibt es einen
' Fehler in Office 2003 "Nicht genügend Speicher". Mit einer Feldlänge von 10910 funktioniert es noch
'-&ampgt muss begrenzt werden auf ca. diesen Wert mit LEFT.
'Allerdings wird bei der Mail an Dr. M. vom 13.12.08, 11:05h immer noch der Speicher-Fehler angezeigt.
'Er tritt am 1025 (&ampgt2^10) auf. Deshalb nur 1024:
Textkoerper = Left(RTrim(LTrim(objItem.Body)), 1024)
objWks.Cells(i + 1, 9).Value = Textkoerper
objWks.Cells(i + 1, 10).Value = objItem.Attachments.Count
objWks.Cells(i + 1, 11).Value = objItem.MessageClass
objWks.Cells(i + 1, 12).Value = Left(RTrim(LTrim(objItem.HTMLBody)), 1024)
objWks.Cells(i + 1, 13).Value = objItem.ReceivedByName
objWks.Cells(i + 1, 14).Value = objItem.ReceivedOnBehalfOfName
objWks.Cells(i + 1, 15).Value = objItem.ReplyRecipientNames
objWks.Cells(i + 1, 16).Value = objItem.Categories
objWks.Cells(i + 1, 17).Value = objItem.Submitted
objWks.Cells(i + 1, 18).Value = objItem.Session
objWks.Cells(i + 1, 19).Value = objItem.Sensitivity
objWks.Cells(i + 1, 20).Value = objItem.RemoteStatus
objWks.Cells(i + 1, 21).Value = objItem.OutlookInternalVersion
objWks.Cells(i + 1, 22).Value = objItem.OriginatorDeliveryReportRequested
objWks.Cells(i + 1, 23).Value = objItem.Importance
objWks.Cells(i + 1, 24).Value = objItem.IsIPFax
objWks.Cells(i + 1, 25).Value = objItem.InternetCodepage
'Q: http://msdn.microsoft.com/en-us/library/aa171439(office.11).aspx
objWks.Cells(i + 1, 26).Value = objItem.Application
objWks.Cells(i + 1, 27).Value = objItem.ReceivedTime
objWks.Cells(i + 1, 28).Value = objItem.CreationTime
objWks.Cells(i + 1, 29).Value = objItem.SentOn
'Funktioniert, aber Sinn unklar: http://www.eggheadcafe.com/software/aspnet/32354399/senden-als-vba-problemc.aspx
'objWks.Cells(i + 1, 13).Value = objItem.SentOnBehalfOfName
objWks.Cells(i + 1, 30).Value = objItem.LastModificationTime
objWks.Cells(i + 1, 31).Value = objFolder.Name

Set objItem = Nothing
Next

objExcel.Visible = True
Set objWks = Nothing
Set objExcel = Nothing
Set objWkb = Nothing
Set myOlExp = Nothing
Set MyOlsel = Nothing
End Sub


Gruss &amp Dank!