web-dev-qa-db-ja.com

サブフォルダーを含むフォルダー内のすべてのOutlook電子メールを反復処理できますか？

多数の電子メールとサブフォルダーを含むフォルダーがあります。それらのサブフォルダ内には、より多くの電子メールがあります。

サブフォルダーのいずれかを含む、特定のフォルダー内のすべての電子メールを反復処理するVBAを作成したいと思います。アイデアは、すべての電子メールからSenderEmailAddressとSenderNameを抽出し、それを使って何かをすることです。

これらの2つのフィールドのみを使用してフォルダーをCSVとしてエクスポートしようとしましたが、これは機能しますが、サブフォルダーに保持されている電子メールのエクスポートはサポートされていません。したがって、いくつかのVBAを作成する必要があります。

車輪の再発明を始める前に、フォルダ名を指定して、そのフォルダ内のすべての電子メールのMailItemオブジェクトを取得する方法を示すコードスニペットまたはサイトへのリンクを持っている人はいますか。 そして 後続のサブフォルダ？

vbaoutlookoutlook-vbaoutlook-object-modelmailitem
14
Richard

このようなもの ...

 Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)

        Dim oFolder As Outlook.MAPIFolder
        Dim oMail As Outlook.MailItem

        For Each oMail In oParent.Items

        'Get your data here ...

        Next

        If (oParent.Folders.Count > 0) Then
            For Each oFolder In oParent.Folders
                processFolder oFolder
            Next
        End If
End Sub
24
76mel

これには、興味のあるすばらしいコードがたくさんあります。Outlook/ VBAでマクロとして実行してください。

Const MACRO_NAME = "OST2XLS"

Dim excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intVersion As Integer, _
    intMessages As Integer, _
    lngRow As Long

Sub ExportMessagesToExcel()
    Dim strFilename As String, olkSto As Outlook.Store
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        intMessages = 0
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        For Each olkSto In Session.Stores
            Set excWks = excWkb.Worksheets.Add()
            excWks.Name = "Output1"
            'Write Excel Column Headers
            With excWks
                .Cells(1, 1) = "Folder"
                .Cells(1, 2) = "Sender"
                .Cells(1, 3) = "Received"
                .Cells(1, 4) = "Sent To"
                .Cells(1, 5) = "Subject"
            End With
            lngRow = 2
            ProcessFolder olkSto.GetRootFolder()
        Next
        excWkb.SaveAs strFilename
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intMessages & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkMsg As Object, olkSub As Outlook.MAPIFolder
    'Write messages to spreadsheet
    For Each olkMsg In olkFld.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            excWks.Cells(lngRow, 1) = olkFld.Name
            excWks.Cells(lngRow, 2) = GetSMTPAddress(olkMsg, intVersion)
            excWks.Cells(lngRow, 3) = olkMsg.ReceivedTime
            excWks.Cells(lngRow, 4) = olkMsg.ReceivedByName
            excWks.Cells(lngRow, 5) = olkMsg.Subject
            lngRow = lngRow + 1
            intMessages = intMessages + 1
        End If
    Next
    Set olkMsg = Nothing
    For Each olkSub In olkFld.Folders
        ProcessFolder olkSub
    Next
    Set olkSub = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.Microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function
6
Jonathan Morningstar