Hallo,
ich habe folgendes Problem bzw folgende Frage:
mein Makro liest in Outlook Ordner aus und kopiert sie in ein Excelsheet, nur bisher habe ich es noch nicht geschafft, die Unterorder (Subfolders) mit auszulesen. Kennt jemand eine Möglichkeit, wie ich ich die Unterordner beim auslesen automatisch mit einbeziehe und kopiere? Vielen Dank im voraus!
Hier der Code
Sub Outlookauslesen()
Dim objOutlook As Outlook.Application
Dim objnSpace As Namespace
Dim objFolder As MAPIFolder
Dim objMsg As Object 'MailItem
Dim olFolder As Outlook.MAPIFolder
Dim LRow As Long
Dim myAr() As Variant
Dim counter As Integer
Set objOutlook = New Outlook.Application
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.PickFolder
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("Done")
With Sheets("Ordner1") 'Tabellennamen anpassen
'Tabellblatt löschen
.Range("A2:C" & .Rows.Count).Clear
'Titels
.Cells(1, 1) = "Absender"
.Cells(1, 2) = "Datum"
.Cells(1, 3) = "Betreff"
.Cells(1, 4) = "Kategorie"
.Range("A1:C1").Font.Bold = True
'Array festlegen
ReDim myAr(1 To objFolder.Items.Count, 1 To 4)
'Mails aus Ordner lesen
Debug.Print "Items im Folder"; objFolder.Items.Count
On Error GoTo ErrorHandler
For counter = 1 To objFolder.Items.Count
Set objMsg = objFolder.Items(counter)
LRow = LRow + 1
If Not objMsg = Empty Then
myAr(LRow, 1) = objMsg.SenderEmailAddress
myAr(LRow, 2) = objMsg.ReceivedTime
myAr(LRow, 3) = objMsg.Subject
myAr(LRow, 4) = objMsg.Categories
Else
myAr(LRow, 1) = "Interner Lesefehler - Objekt ist initial."
myAr(LRow, 4) = counter
End If
Next counter
'Daten in Zellen kopieren
.Range("A2:A3000").Resize(LRow, 4) = myAr
'Breite der Spalten formatieren
.Columns("A:D").EntireColumn.AutoFit
End With