 |
VBA Outlook 全てのフォルダ出力する
Outlookでフォルダ出力。
フォルダ出力して、メールも出力してみたいなVBAを書いたので、
フォルダ出力部分だけ改良して投稿。
まぁ、そのうち何かに使えるかな。
流れ
１．Outlookアプリケーションオブジェクト作成
Set objOutlook = CreateObject(“Outlook.Application”)
２．NameSpaceオブジェクト取得
Set objNamespace = objOutlook.GetNamespace(“MAPI”)
NameSpace オブジェクト (Outlook)
GetNamespace メソッド (Outlook)
３．Folderオブジェクト取得
Set objFolderInbox = objNamespace.GetDefaultFolder(olFolderInbox)
GetDefaultFolder メソッド (Outlook)
oldefaultfolders 列挙 (Outlook)
Folders オブジェクト (Outlook)
４．ぐるぐる回してオブジェクト表示
１．～４．を実行する感じ。
サブフォルダも取得するって事で、サブフォルダを取得する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画面で、[ツール]-[デジタル署名] の順に選択し、署名をアタッチます。
これやらないと、Outlook再起動時に、VBA使用できなくなります。
