Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1148to1152
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

aus abgespeicherten Emails eine Liste erstellen

aus abgespeicherten Emails eine Liste erstellen
niitaka

Hallo zusammen,
für unsere Pfojektabwicklung versuche ich gerade, eine EMail-Datenbank in Excel zu erstellen!
Dazu wird der gewünschte Pfad eingegeben und darin nach allen abgespeicherten EMails im msg-Format gesucht.
Die Mails werden derzeit nur mit Ihrem Dateinamen inkl. Hyperlink in eine Excel-Liste eingetragen.
Ich bräuchte aber noch zusätzlich Sende/Empfangsdatum, Absender, Empfänger, Kopie-Empfänger und Betreff der einzelnen Mails.
Im Internet habe ich eine Funktion gefunden, welche mir die benötigten Informationen aus den Mails des Posteingangs von Outlook ausliest. Jedoch kann ich diese Lösung nicht auf abgespeicherte Mails anwenden.
Vielleicht könnt Ihr mir helfen. Anbei meine bisherigen Arbeitsergebnisse:
https://www.herber.de/bbs/user/69077.xls

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: aus abgespeicherten Emails eine Liste erstellen
14.04.2010 12:16:37
Andi
Hi niitaka,
man muss über Excel eine Outlookanwednung initieren. Veranschaulichung suche Create Object Outlook.
Die initierte Outlookapplication kannst Du unsichtbar im Hintergrund laufen lassen.
Über das Outlook Objekt liest Du die Properties (An: CC: etc) der msg Dateien aus .
Gruß Andi
AW: aus abgespeicherten Emails eine Liste erstellen
14.04.2010 12:43:30
niitaka
Kannst du mir ein Beispiel dazu geben?
Wie lade ich die Datei über den Dateipfad in das Objekt?
AW: aus abgespeicherten Emails eine Liste erstellen
15.04.2010 10:58:34
Andi
Hallo niitaka,
anbei Dirty Code, ohne Gewährleistung. Prinizip sollte aber ausreichend verständlich sein.
Public Function LeseEMailsProperties(MSGPfad As String, i As Long)
Dim OutlookAnwendung As Object
Dim EmailMSG As Object
Dim wb As Object
Set wb = ThisWorkbook.Sheets("Tabelle1")
If IsEmpty(OutlookAnwendung) Then
Set OutlookAnwendung = CreateObject("Outlook.Application")
End If
OutlookAnwendung.Visible = False
Set EmailMSG = OutlookAnwendung.Open(MSGPfad)
If Not IsEmpty(EmailMSG) Then
With EmailMSG
'Die Empfänger stehen in Spalte A ab Zeile 1
wb.Cells(i, 1) = .To 'E-Mail Adresse
'Der Betreff in Spalte B
wb.Cells(i, 2) = .Subject '"Betreffzeile"
'Der zu sendende Text in Spalte C
'Maximal 1024 Zeichen
'Der Text wird ohne Formatierung übernommen
wb.Cells(i, 3) = .Body
'Mail schliesen
.Close
End With
'Objectvariablen leeren
Set OutlookAnwendung = Nothing 'CreateObject("Outlook.Application")
Set EmailMSG = Nothing 'OutlookAnwendung.Open(MSGPfad)
Set wb = Nothing 'ThisWorkbook.Sheets("Tabelle1")
End Function
Gruß Andi
Anzeige
AW: aus abgespeicherten Emails eine Liste erstellen
20.04.2010 09:10:52
niitaka
Hallo Andi,
vielen Dank für deine Mail! ich konnte das Problem inzwischen (fast) lösen.
Es gibt jedoch noch ein paar offene Punkte:
  • archivieren der Mails dauert ewig lange (rund 600Mails in 30min)

  • wenn Terminanfragen, Terminbestätigungen oder Abstimmungsmails abgelegt sind, dann gibts eine Fehlermeldung (deswegen das goto ende)

  • Möchte den Body ohne Formatierung übernehmen, wie mache ich das?

  • 
    Sub ListFiles2()
    Dim olAnw As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim iCounter As Integer
    Dim sPath As String
    Dim MailDatum As String
    Dim MailEmpfängerName As String
    Dim MailAbsenderName As String
    Dim MailBetreff As String
    Dim MailCCName As String
    Dim Jahr As Integer
    Dim Monat As Integer
    Dim Tag As Integer
    Dim Zeit As String
    Set olAnw = CreateObject("Outlook.Application")
    Sheets("Archiv").Activate
    Range("A4:G65536").ClearContents
    If MsgBox("Verzeichnis ok?", vbYesNo + vbQuestion + vbDefaultButton1, "Frage") = vbNo Then
    sPath = GetDirectory("Bitte ein Verzeichnis auswählen:")
    Cells(1, 2).Value = sPath
    If sPath = "" Then Exit Sub
    Else
    sPath = Cells(1, 2).Value
    End If
    With Application.FileSearch
    .FileType = msoFileTypeExcelWorkbooks
    .LookIn = sPath
    .Execute
    .SearchSubFolders = True
    .Filename = "*.msg"
    If .Execute > 0 Then
    MsgBox "There were " & .FoundFiles.Count & " file(s) found."
    If MsgBox("Anzahl ok?", vbYesNo + vbQuestion + vbDefaultButton1, "Frage") = vbNo  _
    Then Exit Sub
    Application.ScreenUpdating = False
    For n = 1 To .FoundFiles.Count
    Set olMail = Nothing
    'On Error Resume Next
    On Error GoTo ende
    Set olMail = olAnw.CreateItemFromTemplate(.FoundFiles(n))
    MailDatum = olMail.ReceivedTime
    MailAbsenderName = olMail.SenderName
    MailEmpfängerName = olMail.To
    MailCCName = olMail.CC
    MailBetreff = olMail.Subject
    Cells(n + 3, 1) = MailDatum
    Cells(n + 3, 2) = Zeit
    Cells(n + 3, 3) = MailAbsenderName
    Cells(n + 3, 4) = MailEmpfängerName
    Cells(n + 3, 5) = MailCCName
    Cells(n + 3, 6) = MailBetreff
    Cells(n + 3, 7).Activate
    Cells(n + 3, 7).Value = Right(.FoundFiles(n), Len(.FoundFiles(n)) - Len(sPath))
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=.FoundFiles(n)
    ende:
    Next n
    Else
    MsgBox "There were no files found."
    End If
    End With
    Columns("A:H").EntireColumn.AutoFit
    ' Objekte eleminieren
    Set olMail = Nothing
    Set olAnw = Nothing
    Application.ScreenUpdating = True
    End Sub
    Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
    End Type
    Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
    ByVal pszPath As String) As Long
    Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
    Function GetDirectory(Optional msg) As String
    Dim bInfo As BROWSEINFO
    Dim Path As String
    Dim r As Long, x As Long, pos As Integer
    bInfo.pidlRoot = 0&
    If IsMissing(msg) Then
    bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
    Else
    bInfo.lpszTitle = msg
    End If
    bInfo.ulFlags = &H1
    x = SHBrowseForFolder(bInfo)
    Path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal Path)
    If r Then
    pos = InStr(Path, Chr$(0))
    GetDirectory = Left(Path, pos - 1)
    Else
    GetDirectory = ""
    End If
    End Function
    

    Anzeige

    304 Forumthreads zu ähnlichen Themen

    Anzeige
    Anzeige
    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige