エクセルVBAでメール本文中に画像を挿入する方法
エクセルVBAを使ってアウトルックメールにてメール送信するマクロを作っています。
本文中に画像を挿入する方法をググってますがなかなか出てきません。添付ファイルではなく、本文と本文の間に画像を差し込むイメージです。
メール送信先、本文は同じエクセルのContentsシート、画像はPictシートに格納しています。
Option Explicit
Sub SendMail_HTML()
Dim contents As Worksheet
Dim maillist As Worksheet
Dim mailaddress As String, honbun1 As String, honbun2 As String, mailbody As String, strstyle As String
Dim i As Long
Set contents = ThisWorkbook.Worksheets("Contents")
Set maillist = ThisWorkbook.Worksheets("List")
' Picture
Dim pict_sheet As Worksheet
Set pict_sheet = ThisWorkbook.Worksheets("pict_sheet")
'プログラム3｜Outlookアプリケーションを起動
Dim outlookObj As Outlook.Application
Dim myMail As Outlook.MailItem
Set outlookObj = CreateObject("Outlook.Application")
For i = 2 To 3
' Email and name setting from Content Sheet
client_name = maillist.Range("B" & i).Value
mailaddress = maillist.Range("C" & i).Value
Set myMail = outlookObj.CreateItem(olMailItem)
'Mail content setting
myMail.BodyFormat = 2
myMail.To = mailaddress
myMail.Subject = contents.Range("B3").Value
honbun1 = Replace(contents.Range("B6").Value, vbLf, "<br>")
Dim insp As Outlook.Inspector
Set insp = myMail.GetInspector
If insp.EditorType = olEditorWord Then
Dim doc As Word.Document 'Microsoft Wordを参照
Set doc = insp.WordEditor
Dim wrange As Word.Range
Set wrange = doc.Range(0, 0) 'カーソルを先頭に
'wrange.Text = honbun1
wrange.MoveEnd Word.WdUnits.wdStory 'カーソルを最後に
wrange.Start = wrange.End
pict_sheet.Shapes("pict1").Copy 'Pict sheetに入っているpict1を指定
wrange.Paste
End If
honbun2 = Replace(contents.Range("B8").Value, vbLf, "<br>")
myMail.HTMLBody = honbun1 & hoonbun2
myMail.Display
'Send mail
'mymail.Display 'メール表示(ここでは誤送信を防ぐために表示だけにして、メール送信はしない)
myMail.Save '下書き保存
myMail.Send
maillist.Range("D" & i).Value = "Sent:" & Now()
' Release object
Set myMail = Nothing
Next
'プログラム12｜オブジェクト解放
Set myMail = Nothing
Set outlookObj = Nothing
End Sub
