Excel VBA メール作成について 本文の中にExcel でコピーした図を上下に2つ 貼り付けを

Excel VBA メール作成について
本文の中にExcel でコピーした図を上下に2つ
貼り付けをしたいです。

Range("D7")セル
（本文）<br><br>
【PT1】<br><br>
【PT2】

【PT1】【PT2】をそれぞれ図に置き換えたところ、
それぞれの位置に上手く置き換えができず、【PT1】の位置に【PT2】の図だけが貼り付けされていました。

詳しい方教えて頂けると幸いです。
宜しくお願い致します。

*************************************************************
Dim outlookObj As Outlook.Application
Set outlookObj = New Outlook.Application

Dim mailObj As Outlook.MailItem
Set mailObj = outlookObj.CreateItem(olMailItem)

mailObj.Display

Worksheets("リスト").Activate

Dim mailBody As String
mailBody = CreatemailBody

With mailObj
.To = Range("D5")
.CC = Range("D6")
.Subject = Range("D4")
.HTMLBody = mailBody
End With

Dim objWRG As Word.Range
Set objWRG = mailObj.GetInspector.WordEditor.Range(0, 0)
With objWRG
Worksheets("1").Range("A1:Z30").CopyPicture
.Find.Text = "【PT1】"
.Find.Execute
.PasteSpecial
.ShapeRange.Width = 900#
Worksheets("2").Range("A3:AZ28").CopyPicture
.Find.Text = "【PT2】"
.Find.Execute
.PasteSpecial
.ShapeRange.Width = 900#
End With

End Sub

Function CreatemailBody() As String

Dim Body As String
Dim Day As String

Body = Range("D7")
Body = Replace(Body, "【月】", Day)
CreatemailBody = Body

End Function

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2023/06/15 14:52

こんにちは

Find.Textの【PT1】【PT2】は　本文中にある　として

Set objWRG = mailObj.GetInspector.WordEditor.Range(0, 0)
は　一度貼り付けた後に再セットが必要なようです
（私はそのようにしました）

Dim objWRG As Word.Range
Set objWRG = mailObj.GetInspector.WordEditor.Range(0, 0)
With objWRG
Worksheets("1").Range("A1:Z30").CopyPicture
.Find.Text = "【PT1】"
.Find.Execute
.PasteSpecial
.ShapeRange.Width = 900#
End With
Set objWRG = mailObj.GetInspector.WordEditor.Range(0, 0)
Worksheets("2").Range("A3:AZ28").CopyPicture
.Find.Text = "【PT2】"
.Find.Execute
.PasteSpecial
.ShapeRange.Width = 900#
End With
Set objWRG = Nothing

この回答へのお礼

ありがとうございます✨上手く表を貼り付けできました。

お礼日時：2023/06/18 00:14

No.2 回答者： Qchan1962 回答日時： 2023/06/15 15:45

なんか＃１　コピペで作ったコード違和感があって　昔作ったファイルを探しました

実際には　この様な書き方をしていました
With mailObj.GetInspector.WordEditor
With .Range(0, 0)
'貼り付け処理
End With
With .Range(0, 0)
'貼り付け処理
End With
End With