[Excel][Outlook] VBAでメールに画像を貼り付ける例

0.README.md

[Excel][Outlook] VBAでメールに画像を貼り付ける例

Excel VBAにて、本文中に画像を埋め込んだOutlook用メールを作成する例。
※元ネタはこちら

予め、ActiveSheet上に

のようなデータを作ってあることを想定。
※"＜画像挿入位置＞"という文字列を、画像に置換

のようなメールが作成できる(はず)。

ソースコード

• 例1：エクセルのWorksheet上にあるShapeをコピーしてメール本文に貼り付ける
• 例2：外部の画像ファイルを読み込んでメール本文に貼り付ける

それぞれ、Subプロシージャ冒頭にある DebugFlag を True にしておくと、メールを作成した状態でStop。
※DebugFlag を False に書き換えると、メール作成後にそのまま送信されるので注意
※例2を試す場合は、TargetFilePath を任意の画像ファイルへのパスに置き換えること

参考

• 【Outlook VBA】メール本文にExcelの画像を挿入し作成/送信する方法！ - エク短｜Extan.jp
• image - How to send a shape object from Excel in the body of an Email? - Stack Overflow

Mod_AddImageMailExample.vba

Option Explicit

' 「Microsoft Outlook 16.0 Object Library」「Microsoft Word 16.0 Object Library」に参照設定しておく

Sub 画像付きメール作成例()
' エクセルのShapeをコピーして貼り付け
    Const DebugFlag As Boolean = True
    Const ImageInsertMark As String = "＜画像挿入位置＞"
    Dim TargetSheet As Worksheet: Set TargetSheet = ActiveSheet
    Dim MailTo As String: MailTo = TargetSheet.Range("A2").Value
    Dim MailSubject As String: MailSubject = TargetSheet.Range("B2").Value
    Dim MailText As String: MailText = TargetSheet.Range("C2").Value
    Dim TargetShape As Shape: Set TargetShape = TargetSheet.Shapes("図 1")
    Dim Ol_App As Outlook.Application
    On Error Resume Next
    Set Ol_App = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set Ol_App = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    Dim Ol_MailItem As Outlook.MailItem: Set Ol_MailItem = Ol_App.CreateItem(OlMailItem)
    With Ol_MailItem
        .To = MailTo
        .Subject = MailSubject
        .BodyFormat = olFormatRichText
        .Body = MailText
        .Display ' [備忘] 予め.Displayしておかないと.GetInspector.WordEditorアクセス時に「実行時エラー '-1975500795 (8a404005)'」発生
        
        Dim Wd_Doc As Word.Document: Set Wd_Doc = .GetInspector.WordEditor
        If Not (Wd_Doc Is Nothing) Then
            Dim Wd_Range As Word.Range: Set Wd_Range = Wd_Doc.Range(0, 0)
            Dim Wd_Shape As Word.Shape
            TargetShape.CopyPicture Appearance:=xlScreen, Format:=xlPicture ' エクセルの図をクリップボードにコピー
            With Wd_Range.Find
                .ClearFormatting
                
                ' [備忘] Range.Find.Excuteで文字列を画像に一括置換することもできる
                ' [TODO] ただしこの場合、「image???.wmz」のような余分な添付ファイルが送信されてしまう模様(回避方法は不明)
'                .Replacement.ClearFormatting
'                .Execute FindText:=ImageInsertMark, ReplaceWith:="^c", Replace:=wdReplaceAll ' 検索文字列(プレースホルダー)をクリップボード中の図に置換
'                For Each Wd_Shape In Wd_Doc.Shapes
'                    With Wd_Shape.WrapFormat
'                        .Type = wdWrapTopBottom
'                        .AllowOverlap = False
'                    End With
'                Next

                .Text = ImageInsertMark ' 検索文字列(プレースホルダー)の指定
                Do While .Execute
                    Wd_Range.Paste ' 見つかった検索文字列をクリップボード中の図に置換
                     ' [備忘] .Pasteして文字列→画像に置換後は、Rangeの位置をずらさないと次の文字列が正しく検索されない模様
'                    Wd_Range.SetRange 0, 0 ' 先頭から検索し直す場合
                    Wd_Range.Start = Wd_Range.End ' 後ろにずらす場合
                Loop
            End With
        End If
        .BodyFormat = olFormatHTML ' RTF→HTML変換
        ' [備忘] RichText(RTF)→HTMLの変換をしておかないと画像が正しく添付されない場合がある
        ' ※ RTF→HTMLに切り替えると、テキストの書式設定は失われることに留意する必要あり
        If DebugFlag Then
            Stop
            .Close olPromptForSave
        Else
            If MailTo <> "" Then .Send
        End If
    End With
    Set Ol_MailItem = Nothing
    Set Ol_App = Nothing
End Sub

Mod_AddImageMailExample2.vba

Option Explicit

' 「Microsoft Outlook 16.0 Object Library」「Microsoft Word 16.0 Object Library」に参照設定しておく

Sub 画像付きメール作成例2()
' 外部の画像ファイルから読み込み
    Const DebugFlag As Boolean = True
    Const ImageInsertMark As String = "＜画像挿入位置＞"
    Dim TargetSheet As Worksheet: Set TargetSheet = ActiveSheet
    Dim MailTo As String: MailTo = TargetSheet.Range("A2").Value
    Dim MailSubject As String: MailSubject = TargetSheet.Range("B2").Value
    Dim MailText As String: MailText = TargetSheet.Range("C2").Value
    Dim TargetFilePath As String: TargetFilePath = ThisWorkbook.Path & "\" & "qrcode_memo.furyutei.com.png"
    Dim Ol_App As Outlook.Application
    On Error Resume Next
    Set Ol_App = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set Ol_App = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    Dim Ol_MailItem As Outlook.MailItem: Set Ol_MailItem = Ol_App.CreateItem(OlMailItem)
    With Ol_MailItem
        .To = MailTo
        .Subject = MailSubject
        .BodyFormat = olFormatRichText
        .Body = MailText
        .Display ' [備忘] 予め.Displayしておかないと.GetInspector.WordEditorアクセス時に「実行時エラー '-1975500795 (8a404005)'」発生
        Dim Wd_Doc As Word.Document: Set Wd_Doc = .GetInspector.WordEditor
        If Not (Wd_Doc Is Nothing) Then
            Dim Wd_Range As Word.Range: Set Wd_Range = Wd_Doc.Range(0, 0)
            Dim Wd_InlineShape As Word.InlineShape
            Dim Wd_Shape As Word.Shape
            With Wd_Range.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = ImageInsertMark ' 検索文字列(プレースホルダー)の指定
                Do While .Execute
                    Wd_Range.Delete ' 見つかった検索文字列は削除
                    Set Wd_InlineShape = Wd_Range.InlineShapes.AddPicture(TargetFilePath, LinkToFile:=False, SaveWithDocument:=True)
                    
                    ' ※画像サイズの調整が必要であれば、例えば以下の4行のようにする
'                    With Wd_InlineShape
'                        .ScaleHeight = 30 ' 画像高さの元の図形との比率(%)
'                        .ScaleWidth = 30 ' 画像幅の元の図形との比率(%)
'                    End With
                    
                    ' ※ InlineShape→Shapeに変換する場合は以下の4行を有効に
'                    Set Wd_Shape = Wd_InlineShape.ConvertToShape
'                    With Wd_Shape.WrapFormat
'                        .Type = wdWrapTopBottom
'                        .AllowOverlap = False
'                    End With
                Loop
            End With
        End If
        .BodyFormat = olFormatHTML ' RTF→HTML変換
        ' [備忘] RichText(RTF)→HTMLの変換をしておかないと画像が正しく添付されない場合がある
        ' ※ RTF→HTMLに切り替えると、テキストの書式設定は失われることに留意する必要あり
        If DebugFlag Then
            Stop
            .Close olPromptForSave
        Else
            If MailTo <> "" Then .Send
        End If
    End With
    Set Ol_MailItem = Nothing
    Set Ol_App = Nothing
End Sub