Wahrscheinlich verursacht eine fehlerhafte Datei dieses Verhalten.
Sub readMailFiles()
Dim strPath As String, strFile As String
Dim lngRow As Long, lngIndex As Long, lngC As Long
Dim objOL As Object, objMail As Object, objFSO As Object
Dim vntNotImported() As Variant
With Sheets("Tabelle1")
strPath = .Range("A2").Text
If Dir(strPath, vbDirectory) <> "" Then
strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
strFile = Dir(strPath & "*.msg", vbNormal)
lngRow = 4
.Range("A4:F" & .Rows.Count).ClearContents
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOL = CreateObject("Outlook.Application")
Do While strFile <> ""
On Error Resume Next
Set objMail = objOL.CreateItemFromTemplate(strPath & strFile)
.Hyperlinks.Add anchor:=.Cells(lngRow, 1), _
Address:=strPath & strFile, TextToDisplay:=strFile
.Cells(lngRow, 2) = objFSO.getfile(strPath & strFile).DateLastModified
'ginge zwar auch, liefert aber oft unsinnige Daten!
'.Cells(lngRow, 2) = objMail.LastModificationTime
.Cells(lngRow, 3) = objMail.ReceivedTime
.Hyperlinks.Add anchor:=.Cells(lngRow, 4), _
Address:="MailTo:" & objMail.SenderEmailAddress, _
TextToDisplay:=objMail.SenderEmailAddress
.Hyperlinks.Add anchor:=.Cells(lngRow, 5), _
Address:="MailTo:" & objMail.Recipients(1).Address, _
TextToDisplay:=objMail.Recipients(1).Address
Err.Clear
On Error GoTo 0
strFile = Dir
lngRow = lngRow + 1
Loop
Else
MsgBox "Ungültiges Verzeichnis!", vbExclamation, "Hinweis"
End If
.Range("A:E").Columns.AutoFit
End With
Set objOL = Nothing
Set objMail = Nothing
End Sub