【Outlook/VBA】Excelファイルを新規作成してメール情報を書き出して保存する

2023/12/16

以前、質問を受けて以下の記事のようなものを作ったのですが、同じ人からOutlook側で処理したいとの質問を改めて受けました。

質問来ていたのでそれに答えようと思います。質問内容をざっとまとめるとこんな感じです。 Outlookの特定のフォルダにメールが保存されているマクロでフォルダを指定して、そのフォルダ内の全てのメールにアクセス。メール本文から情報（メールアドレス、氏名、など）を抽出してExcelに転記マクロはOutlook側・Excel側どちらでも構わない。今回はExcelマクロからOutlookの特定フォルダにアクセスしてメールをゲットしたいと思います。上記の依頼のうち本文解析はプログラムを複雑にしてしまうので次の機会にします。ま...

依頼内容は以下の通り

前回と同じことをOutlook側のマクロで行いたい。（Outlookの特定フォルダのメール情報を抽出してExcelに転記）
所定のフォルダに「20231215資料.xlsx」というファイルを作成。
そのファイルに前回と同じ要領で書き出して保存。

ということで、やってみましょう。

1 Outlook上でVBAエディターを開く
2 Outlookのルートフォルダと対象のフォルダを確認
3 ソースコード
4 実行結果
5 Outlookにマクロ実行ボタンを設置

Outlook上でVBAエディターを開く

まずOutlook上でマクロを組む場合はExcelと同じく「開発」タブから「Visual Basic」をクリックするとエディターが現れます。デフォルトでは「開発」タブはないのでリボンの設定で表示させましょう。まあExcelマクロを触ったことある人はおなじみなので説明するまでもありませんが。

Visual Basic Editor（VBE）が現れたら標準モジュールを追加しましょう。

Outlookのルートフォルダと対象のフォルダを確認

OutlookをVBAで制御するにあたり確認しておかなきゃいけないのが、ルートフォルダ名です。

下図の場所を確認してください。だいたい自分のメールアドレスになっていると思いますが「OUTLOOK」のような文字になっているケースもあります。あと、今回は特定のフォルダ内のメールを対象とするので、「未決」というフォルダを作ってサンプルメールを投げておきました。

ソースコード

以下がソースコードです。これをVBEにコピペしましょう。もちろん、<ルートフォルダ名>と<対象フォルダ名>には適宜修正してください。

Sub OutlookToExcel()
   Dim r, idx As Long
   Set myapp = CreateObject("Outlook.Application")
   Set myFolder = myapp.Session.Folders("<ルートフォルダ名>").Folders("<対象フォルダ名>")

Dim ExcelApp As Object
   Set ExcelApp = CreateObject("Excel.Application")
   ExcelApp.Visible = True
   Set wb = ExcelApp.Workbooks.Add

wb.SaveAs FileName:="C:\Test\" & Format(Now(), "yyyymmdd") & "資料.xlsx"

'項目行
   wb.Worksheets("Sheet1").Range("A1").Value = "件名"
   wb.Worksheets("Sheet1").Range("B1").Value = "送信者"
   wb.Worksheets("Sheet1").Range("C1").Value = "メールアドレス"
   wb.Worksheets("Sheet1").Range("D1").Value = "受信日時"
   '列幅
   wb.Worksheets("Sheet1").Range("A1").ColumnWidth = 20
   wb.Worksheets("Sheet1").Range("B1").ColumnWidth = 10
   wb.Worksheets("Sheet1").Range("C1").ColumnWidth = 25
   wb.Worksheets("Sheet1").Range("D1").ColumnWidth = 17

r = 2
   For idx = myFolder.Items.Count To 1 Step -1
      wb.Worksheets("Sheet1").Cells(r, 1).Value = myFolder.Items(idx).Subject
      wb.Worksheets("Sheet1").Cells(r, 2).Value = myFolder.Items(idx).SenderName
      wb.Worksheets("Sheet1").Cells(r, 3).Value = myFolder.Items(idx).SenderEmailAddress
      wb.Worksheets("Sheet1").Cells(r, 4).Value = myFolder.Items(idx).ReceivedTime
      r = r + 1
   Next
End Sub