[VBA, Outlook] Auflisten aller Emails eines bestimmten Ordners (+ rekursiv)
Gepostet am: Nov 27, 2013 5:34:0 PM
Wenn man Emails bearbeiten möchte, benötigt man hin und wieder eine Lösung, die über alle Outlook-Elemente eines Ordners (rekursiv) iteriert.
Nachfolgendes Beispiel, wie man rekursiv über alle Ordner inklusive Unterordner alle Email-Betreffs ausgeben kann.
Aufruf:
> call GetListOfEmails(true)
GetListOfEmails()
Public Sub GetListOfEmails(Optional bRecursive As Boolean = True)Dim myFolder As Outlook.MAPIFolder Set myFolder = GetFolder("\\xyz@abc.com\Posteingang")Call GetItemsOfFolder(myFolder)If bRecursive = True Then Call GetItemsOfSubFolder(myFolder, bRecursive)End IfEnd SubPublic Sub GetItemsOfSubFolder(MAPIFolder As Outlook.MAPIFolder, Optional bRecursive As Boolean = True) Debug.Print "Der Ordner " & MAPIFolder.FolderPath & " enthält " & MAPIFolder.Folders.Count & " Elemente"If MAPIFolder.Folders.Count > 0 Then Dim myFolder As Outlook.MAPIFolder For Each myFolder In MAPIFolder.Folders Call GetItemsOfFolder(myFolder) If bRecursive = True Then Call GetItemsOfSubFolder(myFolder) End If NextEnd IfEnd SubPublic Sub GetItemsOfFolder(MAPIFolder As Outlook.MAPIFolder)Dim myEmail As Outlook.MailItem Dim myObj As Object Debug.Print "Der Ordner " & MAPIFolder.FolderPath & " enthält " & MAPIFolder.Items.Count & " Elemente"For Each myObj In MAPIFolder.Items If TypeName(myObj) = "MailItem" Then Set myEmail = myObj Debug.Print " " & myEmail.Subject End IfNextEnd Sub
Die Funktion, die aus einem OrdnerPfad (MAPIFolder.FolderPath) wieder ein Objekt macht, gibt es im Internet.
GetFolder(strFolderPath)
Public Function GetFolder(strFolderPath As String) As Outlook.MAPIFolder ' strFolderPath needs to be something like ' "Public Folders\All Public Folders\Company\Sales" or ' "Personal Folders\Inbox\My Folder" Dim objApp As Outlook.Application Dim objNS As Outlook.NameSpace Dim colFolders As Outlook.Folders Dim objFolder As Outlook.MAPIFolder Dim arrFolders() As String Dim i As Long On Error Resume Next strFolderPath = Replace(strFolderPath, "\\", "") strFolderPath = Replace(strFolderPath, "/", "\") arrFolders() = Split(strFolderPath, "\") Set objApp = Application Set objNS = objApp.GetNamespace("MAPI") Set objFolder = objNS.Folders.Item(arrFolders(0)) If Not objFolder Is Nothing Then For i = 1 To UBound(arrFolders) Set colFolders = objFolder.Folders Set objFolder = Nothing Set objFolder = colFolders.Item(arrFolders(i)) If objFolder Is Nothing Then Exit For End If Next End If Set GetFolder = objFolder Set colFolders = Nothing Set objNS = Nothing Set objApp = NothingEnd Function
Links: