none
Outlook subfolders zusätzlich auslesen

    Frage

  • 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

    Montag, 26. Mai 2014 08:19

Alle Antworten