Hallo Forumsmitglieder,
seit längerem suche ich eine Lösung für ein – noch verbleibendes, kleines Restproblem und zwar: wie exportiere ich Mails von Outlook nach Excel und gebe AUCH aus, wie der direkte Folder-Name heißt?!? –
Ich habe in OL 2003 einen Mailordner mit sehr vielen verschachtelten Unterordnern (darin: versch. Projekte). Zum Durchsuchen, Archivieren, usw. benötige ich eine Listenübersicht. Dies erledigt nachstehendes Makro, welches ich im Web gefunden und dann verschiedentlich noch v.a. mit weiteren Feldern 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 beinhalteten Mails – dadurch sehr zeitaufwändig.
Beides gravierende Nachteile, will man 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 -> 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:smile:.“
objWks.Cells(1, 2).Value = „Absender (SenderName)“
objWks.Cells(1, 3).Value = „E-Mail-Adresse (Von:/ From:smile:“
objWks.Cells(1, 4).Value = „CC:“
objWks.Cells(1, 5).Value = „BCC:“
objWks.Cells(1, 6).Value = „Größe: (Size:smile:.“
objWks.Cells(1, 7).Value = „Empfänger/An: (To:smile:“
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 „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%20Out…
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, 118.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 -->
'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…
'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
'-> 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 (>2^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(off…
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/…
'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 & Dank!
PS:
Die Kommentare im Makro sind für die Fragestellung nicht relevant und dienen mir nur als Erinnerung.
Eine Übersicht über die möglichen Properties finden die VBA-Profis m.E. unter:
http://msdn.microsoft.com/en-us/library/aa210946(off…. - Es geht dort zwar nicht um ObjItem, sondern MailItem Object, aber es scheint größtenteils deckungsgleich. Wenn jemand die genaue Properties-Seite von MSDN noch findet, bitte hier angeben. - Vielen Dank!
Ich habe viel Zeit mit Recherchen verbracht, aber wirklich ALLE Felder werden kaum exportiert werden können. - Bei jeder Datenkonvertierung muss man sich damit abfinden, dass Daten bzw. sonstige Informationen wie Formatierungen verloren gehen.
Um mich nicht mit frenden Federn zu schmücken - der ganz grundlegende Code stammt von wohl Eric Legault (verm. 2006). - Vielen Dank an dieser Stelle!