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