VBA Outlook 全てのフォルダ出力する

  • マウスコンピューター/G-Tune
  • VBA Outlook 全てのフォルダ出力する

    Outlookでフォルダ出力。
    フォルダ出力して、メールも出力してみたいなVBAを書いたので、
    フォルダ出力部分だけ改良して投稿。
    まぁ、そのうち何かに使えるかな。

    流れ

    1.Outlookアプリケーションオブジェクト作成
    Set objOutlook = CreateObject(“Outlook.Application”)

    2.NameSpaceオブジェクト取得
    Set objNamespace = objOutlook.GetNamespace(“MAPI”)

    NameSpace オブジェクト (Outlook)
    GetNamespace メソッド (Outlook)

    3.Folderオブジェクト取得
    Set objFolderInbox = objNamespace.GetDefaultFolder(olFolderInbox)

    GetDefaultFolder メソッド (Outlook)
    oldefaultfolders 列挙 (Outlook)
    Folders オブジェクト (Outlook)

    4.ぐるぐる回してオブジェクト表示

    1.~4.を実行する感じ。

    サブフォルダも取得するって事で、サブフォルダを取得するFunctionを再帰してます。
    ちなみに、MSのヘルプは、確認したほうが一読した方が良いっす。

    ソース

    この画像のフォルダを取得する。

    Outlookのディレクトリ構成

    
    '**********************************
    'VBAの実行結果には、責任取りません。
    '使用時は自己責任でお願いします。
    '**********************************
    
    Public Sub Main()
        
        '------------------
        '変数宣言
        '------------------
        Dim objOutlook      As Outlook.Application 'Outlookアプリケーションオブジェクト
        Dim objNamespace    As Outlook.NameSpace   'NameSpaceオブジェクト
        Dim objFolderInbox  As Variant             'Folderオブジェクト
        
        Dim sDirLine        As String              'ディレクトリ階層の表示用
        Dim sDirSubLine     As String              'サブディレクトリ階層の表示用
        
        On Error GoTo Error
        
        'ディレクトリ階層の表示用
        sDirLine = Space(4) & "|--- "
        
        'サブディレクトリ階層の表示用
        sDirSubLine = Space(4) & "|" & sDirLine
            
        '------------------
        '各オブジェクト作成
        '------------------
        'Outlookオブジェクト作成
        Set objOutlook = CreateObject("Outlook.Application")
        
        'Outlookは、MAPIだけだってよ。
        Set objNamespace = objOutlook.GetNamespace("MAPI")
        
        'Folderオブジェクト取得
        Set objFolderInbox = objNamespace.GetDefaultFolder(olFolderInbox)
            
        
        'ルートディレクトリを出力
        Debug.Print objFolderInbox
        
        'サブディレクトリ分ループ
        For Each oFolder In objFolderInbox.Folders
            
            'サブディレクトリ出力
            Debug.Print sDirLine & oFolder
    
            'サブディレクトリ出力
            If GetMailSubFolder(oFolder, _
                                sDirSubLine) = False Then
                
                GoTo Error
            
            End If 'GetMailSubFolder
    
        Next
    
        Set objOutlook = Nothing
        Set objNamespace = Nothing
        Set objFolderInbox = Nothing
        
        Exit Sub
        
    Error:
    
        Set objOutlook = Nothing
        Set objNamespace = Nothing
        Set objFolderInbox = Nothing
                    
        MsgBox "失敗"
    
    End Sub
    
    Public Function GetMailSubFolder(objSubFolder As Variant, _
                                     sDirLine As String) As Boolean
    
        '------------------
        '変数宣言
        '------------------
        Dim sDirSubLine As String 'サブディレクトリ階層の表示用
        
        On Error GoTo Error
        
        'サブディレクトリ階層の表示用
        sDirSubLine = Space(4) & "|" & sDirLine
        
        
        'サブディレクトリ分ループ
        For Each oSubFolder In objSubFolder.Folders
            
            'サブディレクトリ出力
            Debug.Print sDirLine & oSubFolder
            
            'ディレクトリ出力のためメソッド再帰
            If GetMailSubFolder(oSubFolder, _
                                sDirSubLine) = False Then
        
                GoTo Error
            
            End If 'GetMailSubFolder
        
        Next
      
        GetMailSubFolder = True
        Exit Function
    Error:
        GetMailSubFolder = False
    End Function
    
    '*******************************************************************************
    'ループカウンタを使用して何かをしたい場合は、
    'For Each をFor に変更するとかで対応します。
    '一応、書いときます。
    '*******************************************************************************
    
        'Dim iLcn As Long          'ループ用
    
        'オブジェクト分ループ
        'For iLcn = 1 To objFolder.Folders.count
            
            'ディレクトリを出力
        '    Debug.Print sDirLine & objFolder.Folders(iLcn)
    
            'ディレクトリ出力のためメソッド再帰
        '    If GetMailSubFolder(objFolder.Folders(iLcn), _
                               sDirSubLine) = False Then
               
        '        GetMailSubFolder = False
                    
        '        Exit Function
                
        '    End If 'GetMailSubFolder
            
        'Next iLcn
    
    



    実行画面

    実行結果

    補足-フォルダの表示順

    実行結果のフォルダ出力順は、実行環境によって出力順が異なる場合があります。
    詳しく調べて無いので予想ですが、Outlookのオブジェクト作成順(EntryID順)に出力されているからだと思います。

    EntryIDは、ソースの下記部分を修正すると出力できます。

    フォルダーの EntryID プロパティ (Outlook)

    
    Debug.Print sDirLine & oFolder 
       
         ↓
    
    Debug.Print sDirLine & oFolder & "  " & oFolder.EntryID
    
    

    補足-デジタル証明書

    VBAは、デジタル証明書がないと継続して使用できないため、
    下記のページを参考にデジタル証明書を作成してください。

    VBAのデジタル証明書の話。(備忘)

    その後、VBA画面で、[ツール]-[デジタル署名] の順に選択し、署名をアタッチます。
    これやらないと、Outlook再起動時に、VBA使用できなくなります。

    関連記事

    ページ上部へ戻る