Outlook VBA：メールをExcelに出力する

June 2, 2024July 9, 2024

OutlookのメールをExcelに出力することができます。

いくつか例を用いて解説します。

特定のメールをExcelに出力する方法

やりたいこと

受信フォルダ内のメールの中で、タイトルに「history」が含まれるメールに対して、そのタイトルと受信日時をExcelに出力する。
出力先のExcelは、デスクトップに保存された「contents.xls」とする

サンプルコードは以下のとおり。

Sub ExportHistoryEmailsToExcel()

    ' Excelアプリケーションを宣言
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim row As Integer
    
    ' Excelを起動してブックとシートを作成
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Open("C:\Users\ユーザー名\Desktop\contents.xls")
    Set xlSheet = xlBook.Sheets(1)
    
    ' 行番号を初期化
    row = 1
    
    ' Outlookの受信トレイフォルダを取得
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olMail As Outlook.MailItem
    Dim olItems As Outlook.Items
    Dim i As Integer
    
    Set olApp = Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox)
    Set olItems = olFolder.Items
    
    ' 受信フォルダ内のメールをループ
    For i = 1 To olItems.Count
        If TypeName(olItems(i)) = "MailItem" Then
            Set olMail = olItems(i)
            
            ' メールのタイトルに「history」が含まれるかをチェック
            If InStr(olMail.Subject, "history") > 0 Then
                ' Excelシートにデータを書き込む
                xlSheet.Cells(row, 1).Value = olMail.Subject
                xlSheet.Cells(row, 2).Value = olMail.ReceivedTime
                row = row + 1
            End If
        End If
    Next i
    
    ' Excelファイルを保存して閉じる
    xlBook.Save
    xlBook.Close
    xlApp.Quit
    
    ' オブジェクトを解放
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    Set olMail = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing

    MsgBox "データがExcelファイルに出力されました。", vbInformation

End Sub

サブフォルダのメールをExcelに出力する方法

やりたいこと

受信フォルダ内の特定のフォルダ内メール全てに対して、タイトルと送信者をExcelに出力する。
特定のフォルダとは、「seihin」というフォルダの中にある「consumer」とする
出力先のExcelは、デスクトップに保存された「contents.xls」とする

サンプルコードは以下のとおり。

Sub ExportEmailsToExcel()
    ' Outlookオブジェクトの宣言
    Dim OutlookApp As Outlook.Application
    Dim Inbox As Outlook.Folder
    Dim ProductFolder As Outlook.Folder
    Dim ConsumerFolder As Outlook.Folder
    Dim MailItem As Outlook.MailItem
    Dim i As Integer

    ' Excelオブジェクトの宣言
    Dim ExcelApp As Object
    Dim Workbook As Object
    Dim Worksheet As Object

    ' Outlookアプリケーションの初期化
    Set OutlookApp = New Outlook.Application
    Set Inbox = OutlookApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set ProductFolder = Inbox.Folders("seihin")
    Set ConsumerFolder = ProductFolder.Folders("consumer")

    ' Excelアプリケーションの初期化
    Set ExcelApp = CreateObject("Excel.Application")
    Set Workbook = ExcelApp.Workbooks.Open(Environ("USERPROFILE") & "\Desktop\contents.xls")
    Set Worksheet = Workbook.Sheets(1)

    ' ヘッダー行の設定
    Worksheet.Cells(1, 1).Value = "タイトル"
    Worksheet.Cells(1, 2).Value = "送信者"

    ' メール情報の出力
    i = 2 ' データの開始行
    For Each MailItem In ConsumerFolder.Items
        ' メールの件名と送信者をExcelに出力
        Worksheet.Cells(i, 1).Value = MailItem.Subject
        Worksheet.Cells(i, 2).Value = MailItem.SenderName
        i = i + 1
    Next MailItem

    ' Excelファイルの保存と終了
    Workbook.Save
    Workbook.Close
    ExcelApp.Quit

    ' オブジェクトの解放
    Set Worksheet = Nothing
    Set Workbook = Nothing
    Set ExcelApp = Nothing
    Set ConsumerFolder = Nothing
    Set ProductFolder = Nothing
    Set Inbox = Nothing
    Set OutlookApp = Nothing

    MsgBox "メール情報をExcelに出力しました。", vbInformation
End Sub

サブフォルダにある特定のメールをExcelに出力する方法

やりたいこと

Outlookで実行するVBAマクロ
受信フォルダ内にある特定のフォルダ内の特定のメールを検索し、条件に合致するメールの件名と送信者と受信日時をExcelに出力する
特定のフォルダとは、受信フォルダ直下の「製品」フォルダの中にある「リリース」フォルダとする
特定のメールとは、本文に「リリース情報」の文字が含まれたものとする
出力先のExcelは、デスクトップに保存された「contents.xls」の「リリース履歴」シートとする
メール件名はB列、送信者はC列、受信日時はD列に出力すること

サンプルコードは以下のとおり。

Sub ExportReleaseInfoToExcel()
    ' Outlookオブジェクトの宣言
    Dim OutlookApp As Outlook.Application
    Dim Namespace As Outlook.Namespace
    Dim Inbox As Outlook.Folder
    Dim ProductFolder As Outlook.Folder
    Dim ReleaseFolder As Outlook.Folder
    Dim MailItem As Object
    
    ' Excelオブジェクトの宣言
    Dim ExcelApp As Object
    Dim Workbook As Object
    Dim Worksheet As Object
    Dim LastRow As Long
    
    ' Outlookアプリケーションの初期化
    Set OutlookApp = New Outlook.Application
    Set Namespace = OutlookApp.GetNamespace("MAPI")
    Set Inbox = Namespace.GetDefaultFolder(olFolderInbox)
    
    ' 「製品」フォルダと「リリース」フォルダの取得
    On Error Resume Next
    Set ProductFolder = Inbox.Folders("製品")
    If ProductFolder Is Nothing Then
        MsgBox "「製品」フォルダが見つかりません。", vbExclamation
        Exit Sub
    End If
    
    Set ReleaseFolder = ProductFolder.Folders("リリース")
    If ReleaseFolder Is Nothing Then
        MsgBox "「リリース」フォルダが見つかりません。", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    
    ' Excelアプリケーションの初期化
    Set ExcelApp = CreateObject("Excel.Application")
    Set Workbook = ExcelApp.Workbooks.Open(Environ("USERPROFILE") & "\Desktop\contents.xls")
    Set Worksheet = Workbook.Sheets("リリース履歴")
    
    ' 出力先の初期設定
    LastRow = Worksheet.Cells(Worksheet.Rows.Count, "B").End(xlUp).Row + 1

    ' 「リリース」フォルダ内のメールをループ
    For Each MailItem In ReleaseFolder.Items
        ' メールがMailItemであることを確認
        If TypeOf MailItem Is Outlook.MailItem Then
            ' 本文に「リリース情報」が含まれるかを確認
            If InStr(MailItem.Body, "リリース情報") > 0 Then
                ' メールの件名、送信者、受信日時をExcelに出力
                Worksheet.Cells(LastRow, 2).Value = MailItem.Subject
                Worksheet.Cells(LastRow, 3).Value = MailItem.SenderName
                Worksheet.Cells(LastRow, 4).Value = MailItem.ReceivedTime
                LastRow = LastRow + 1
            End If
        End If
    Next MailItem
    
    ' Excelファイルの保存と終了
    Workbook.Save
    Workbook.Close
    ExcelApp.Quit

    MsgBox "指定された条件のメール情報をExcelに出力しました。", vbInformation

    ' オブジェクトの解放
    Set Worksheet = Nothing
    Set Workbook = Nothing
    Set ExcelApp = Nothing
    Set ReleaseFolder = Nothing
    Set ProductFolder = Nothing
    Set Inbox = Nothing
    Set Namespace = Nothing
    Set OutlookApp = Nothing
End Sub

アクティブになっているメールをExcelに出力する方法

やりたいこと

Outlookで実行するVBAマクロ
選択された(アクティブになっている)メールの件名と送信者と受信日時と本文を、Excelに出力する
出力先のExcelは、デスクトップに保存された「contents.xls」の「リリース履歴」シートとする
メール件名はB列、送信者はC列、受信日時はD列、本文はE列に出力すること

サンプルコードは以下のとおり。

Sub ExportSelectedEmailToExcel()
    ' Outlookオブジェクトの宣言
    Dim OutlookApp As Outlook.Application
    Dim MailItem As Outlook.MailItem
    
    ' Excelオブジェクトの宣言
    Dim ExcelApp As Object
    Dim Workbook As Object
    Dim Worksheet As Object
    Dim LastRow As Long
    
    ' Outlookアプリケーションの初期化
    Set OutlookApp = New Outlook.Application
    
    ' 選択されたメールを取得
    On Error Resume Next
    Set MailItem = OutlookApp.ActiveExplorer.Selection.Item(1)
    On Error GoTo 0
    
    ' メールが選択されていることを確認
    If MailItem Is Nothing Then
        MsgBox "メールが選択されていません。", vbExclamation
        Exit Sub
    End If
    
    ' Excelアプリケーションの初期化
    Set ExcelApp = CreateObject("Excel.Application")
    Set Workbook = ExcelApp.Workbooks.Open(Environ("USERPROFILE") & "\Desktop\contents.xls")
    Set Worksheet = Workbook.Sheets("リリース履歴")
    
    ' 出力先の初期設定
    LastRow = Worksheet.Cells(Worksheet.Rows.Count, "B").End(xlUp).Row + 1
    
    ' メールの件名、送信者、受信日時、本文をExcelに出力
    Worksheet.Cells(LastRow, 2).Value = MailItem.Subject
    Worksheet.Cells(LastRow, 3).Value = MailItem.SenderName
    Worksheet.Cells(LastRow, 4).Value = MailItem.ReceivedTime
    Worksheet.Cells(LastRow, 5).Value = MailItem.Body
    
    ' Excelファイルの保存と終了
    Workbook.Save
    Workbook.Close
    ExcelApp.Quit
    
    MsgBox "選択されたメールの情報をExcelに出力しました。", vbInformation
    
    ' オブジェクトの解放
    Set Worksheet = Nothing
    Set Workbook = Nothing
    Set ExcelApp = Nothing
    Set MailItem = Nothing
    Set OutlookApp = Nothing
End Sub

Excelが開いているかをチェックする方法

「Excelを他の人が開いていて読み取り専用になっていて、出力できない、、、」なんてこともあるかと。

そこで、Excelの起動チェックする方法を紹介します。

前提

「AI.xlsm」のファイルは、「C:\Path\To\Excel2.xlsx」の場所にあらかじめ作成されている

やりたいこと

AI.xlsmが起動しているかどうかをチェックする関数
もしAI.xlsmが起動している場合は、戻り値としてTrueを返す。
もしAI.xlsmが起動していない場合は、戻り値としてFalseを返す。

Function IsWorkbookOpen(workbookName As String) As Boolean
    Dim xlApp As Object
    Dim wb As Object
    Dim wbOpen As Boolean
    
    On Error Resume Next
    ' Excelアプリケーションにアクセス
    Set xlApp = GetObject(, "Excel.Application")
    
    ' Excelが起動していない場合はFalseを返す
    If xlApp Is Nothing Then
        IsWorkbookOpen = False
        Exit Function
    End If
    
    wbOpen = False
    ' 開いているすべてのブックをチェック
    For Each wb In xlApp.Workbooks
        If wb.FullName = "C:\Path\To\AI.xlsm" Then
            wbOpen = True
            Exit For
        End If
    Next wb
    
    ' 結果を返す
    IsWorkbookOpen = wbOpen
    
    ' クリーンアップ
    Set wb = Nothing
    Set xlApp = Nothing
End Function

' この関数を使ってAI.xlsmが起動しているかをチェックする例
Sub CheckIfAIWorkbookIsOpen()
    If IsWorkbookOpen("C:\Path\To\AI.xlsm") Then
        MsgBox "AI.xlsmが起動しています。"
    Else
        MsgBox "AI.xlsmは起動していません。"
    End If
End Sub

よかったらシェアしてね！

URLをコピーしました！

URLをコピーしました！