Hallo zusammen,
vielleicht könnt Ihr mir ja mal wieder weiterhelfen?
Ich möchte aus frei wählbaren Outlook-Ordnern Daten wie Mail-Adresse, Datum, Betreff, Empfänger usw. auslesen.
Dazu habe ich dieses Makro im Netz gefunden. Das funktioniert leider nicht immer, kann aber nicht feststellen warum. Ich vermute dass es beim Auslesen des Betreffs manchmal zu dieser Fehlermeldung kommt: Laufzeitfehler: 13 Typen unverträglich.
An dieser Stelle kommt die Fehlermeldung "Next objMsg"
Woran kann dies liegen bzw. wie kann man das Makro dazu bewegen komplett durchzulaufen und keine Informationen zu verschlucken?
Wäre nett wenn mir jemand einen Tipp geben könnte!
Vielen Dank dafür!
vielleicht könnt Ihr mir ja mal wieder weiterhelfen?
Ich möchte aus frei wählbaren Outlook-Ordnern Daten wie Mail-Adresse, Datum, Betreff, Empfänger usw. auslesen.
Dazu habe ich dieses Makro im Netz gefunden. Das funktioniert leider nicht immer, kann aber nicht feststellen warum. Ich vermute dass es beim Auslesen des Betreffs manchmal zu dieser Fehlermeldung kommt: Laufzeitfehler: 13 Typen unverträglich.
An dieser Stelle kommt die Fehlermeldung "Next objMsg"
Woran kann dies liegen bzw. wie kann man das Makro dazu bewegen komplett durchzulaufen und keine Informationen zu verschlucken?
Code:
'Benötigt den Verweis auf Microsoft Outlook Object Library
Sub MailsImportieren()
Dim objOutlook As Outlook.Application
Dim objnSpace As Namespace
Dim objFolder As MAPIFolder
Dim objMsg As MailItem
Dim LRow As Long
Dim myAr() As Variant
Set objOutlook = New Outlook.Application
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.PickFolder ''' Dialog
With Sheets("Outlook") 'Tabellennamen anpassen !!!!!!!
'Zellen leer machen für neue Daten
.Range("A2:D" & .Rows.Count).Clear
'Überschrift
.Cells(1, 1) = "Absender"
.Cells(1, 2) = "Datum"
.Cells(1, 3) = "Betreff"
.Cells(1, 4) = "Empfänger"
.Range("A1:D1").Font.Bold = True
'Array Dimensionieren
ReDim myAr(1 To objFolder.Items.Count, 1 To 4)
'Mails aus Ordner lesen
For Each objMsg In objFolder.Items
LRow = LRow + 1
myAr(LRow, 1) = objMsg.SenderEmailAddress 'Mail- Adresse
myAr(LRow, 2) = objMsg.ReceivedTime 'Datum
myAr(LRow, 3) = objMsg.Subject 'Betreff
myAr(LRow, 4) = objMsg.To 'Empfänger
Next objMsg
'Daten in Zellen schreiben
.Range("A2").Resize(LRow, 4) = myAr
'Breite der Spalten anpassen
.Columns("A:D").EntireColumn.AutoFit
End With
End Sub
Wäre nett wenn mir jemand einen Tipp geben könnte!
Vielen Dank dafür!
Mit freundlichen Grüßen / Best regards
//
----------o00o---°(_)°---o00o----------------------
Erich
//
----------o00o---°(_)°---o00o----------------------
Erich