VBAでやってみた１：Outlook送信済みメールの一括取得

１．概要

　VBA応用として実践的な内容を紹介します。第１回目はOutlookの送信済みメールの情報をExcelに転記するVBAです。
　注意点としてコードはOutlookに記載しており、Excelではございません。

２．業務内容

　工事業務ではメールのやり取りが多いためメールのやり取りをExcelに転記して管理しております。転記するのが面倒なためOutlookから下記情報を取得して指定のExcelファイルに記載します。
※送信元も転記可能です。

●送信日
●件名
●宛先
●CC
●メール本文
●添付ファイル数
●添付ファイル名

３．VBAの設計思想

サーバーの構成イメージは下記の通り

●指定サーバーパス内に工事フォルダが多数ある。
●工事フォルダ内に複数のフォルダに加えて 00. 管理台帳フォルダがある
●00. 管理台帳フォルダ内に管理台帳.xlsmファイルがある。

管理台帳ファイルは下記の通り（シート名は管理台帳シート）。

転記のイメージは下記の通り。

●メールを送信します。
●Outlookにボタンを設置してマクロを追加（ボタン追加は下記参照）
●ウィンドウが立ち上がるためフォルダ内でユニークな文字を入力(上記の例では工事Aフォルダを選択したい場合Aと選択)
●自動で送信したメール（最新メール）の転記が完了します。

Outlook/VBA: 自作マクロをリボンにボタンとして設置する方法 | 非IT企業に勤める中年サラリーマンのIT日記

４．コード（VBA）

コードは下記ですが7割くらい内容を忘れているため紹介だけとなります。
実行すると指定フォルダ内の管理台帳にOutlook情報が転記されます。

Dim fso As FileSystemObject
Set fso = New FileSystemObject ' インスタンス化

Dim pfl As Object
Set pfl = fso.GetFolder("管理したいフォルダのパス") ' 親フォルダを取得 fso.GetFolder関数で親フォルダの Folder オブジェクトを取得します。フォルダが存在しないときはエラーが発生します。※要修正


Dim Subjectsearch As String  '手動で追加 InputBoxの文字列取得
Dim Mledger As String
Subjectsearch = InputBox("検索したい文字列を入力してください。", "検索BOX", "文字列入力")
If Subjectsearch = "" Then ' InputBoxのキャンセル時にエラーを出さない
   Exit Sub
End If

Dim objOutlook As Outlook.Application '手動で追加：多分Outlookで使用するならなくてもよい。Excelからだと必須
Dim myNamespace As Outlook.NameSpace
Dim xlApp As Excel.Application  '手動で追加　Excel動作用
Dim objFolder As Object 'https://gallery.technet.microsoft.com/office/2417e70d-5785-4df2-899d-e74f5e04a22e
Dim j, num1, num2 As Long
Dim wbname As String
Dim ws As Object
Dim Attachnames As String

Set objOutlook = New Outlook.Application  'Newを使用してクラス： Outlook.Applicationをインスタンス化
Set myNamespace = objOutlook.GetNamespace("MAPI") 'OutlookのNamespaceオブジェクトを取得
Set xlApp = CreateObject("Excel.Application")   '手動で追加　Excel動作用

xlApp.Visible = True   '手動で追加

Set objFolder = myNamespace.GetDefaultFolder(5) 'GetDefaultFolderメソッド：Outlook既定のフォルダを取得| '3：削除済みフォルダ、5：送信済みフォルダ、：6：受信トレイ

Dim fl As Object '
Dim MyWs As Worksheet

For Each fl In pfl.SubFolders ' サブフォルダの一覧を取得 pfl.SubFoldersプロパティから、そのフォルダ内にある Folder オブジェクトの一覧を取得できます。
   If InStr(fl.Name, Subjectsearch) > 0 Then 'InStrが検索した文字列のインデックスを戻り値にするため、指定文字がないと0
       Mledger = fl.Path & "\00. 管理台帳\管理台帳.xlsm" '管理台帳があるサーバーパス※要修正
       xlApp.Workbooks.Open Filename:=Mledger
       wbname = fso.GetBaseName(Mledger) & "." & fso.GetExtensionName(Mledger)
      Set MyWs = xlApp.Workbooks(wbname).Worksheets("管理台帳シート") 'ここのSetステートメントでxlAppを含めておかないと下の行でオブジェクトw認識できない。※要修正
       j = MyWs.Cells(MyWs.Rows.Count, 2).End(xlUp).Row + 1  'Cell内のRowsの前にオブジェクト指定がないと””エラー：'Rows'メソッドは失敗しました:'_Global'オブジェクト発生（https://teratail.com/questions/261430）
      With MyWs '頭にxlAppを付けないとインデックス参照できないエラー発生
           .Cells(j, 2).Value = objFolder.Items(objFolder.Items.Count).SentOn
           .Cells(j, 3).Value = objFolder.Items(objFolder.Items.Count).Subject
           .Cells(j, 4).Value = objFolder.Items(objFolder.Items.Count).To
           .Cells(j, 5).Value = objFolder.Items(objFolder.Items.Count).CC
           .Cells(j, 6).Value = objFolder.Items(objFolder.Items.Count).Body
           num1 = objFolder.Items(objFolder.Items.Count).Attachments.Count
           .Cells(j, 7).Value = num1
           For num2 = 1 To num1
                Attachnames = Attachnames & objFolder.Items(objFolder.Items.Count).Attachments(num2).DisplayName & vbCrLf
           Next
           .Cells(j, 8).Value = Attachnames
      End With
'        Debug.Print (fl.Name) ' フォルダの名前 (TipsFolder) など：fl.Nameプロパティから､そのフォルダの名前を取得できます｡練習用コマンド
'        Debug.Print (fl.Path) ' フォルダのパス (D:\TipsFolder) など：fl.Pathプロパティから､そのフォルダのパスを取得できます｡練習用コマンド
   End If
Next

'xlApp.Workbooks(wbname).Close SaveChanges:=True '上書き保存＆ブックを閉じる

' 後始末
Set fso = Nothing

End Sub

あとがき

　多分こんなこと他社ではやってないだろうから需要はないだろうね・・
それにしてもExcel以外の操作をするVBAの良い情報が少なすぎてつらい・・・