Excel VBA メール作成について 下記についてどのように記述したらいいか、教えて頂けると幸いで

Excel VBA メール作成について
下記についてどのように記述したらいいか、教えて頂けると幸いです。

・Excel表をコピーしたものを図としてメールに貼り付け
貼り付けした図のサイズが小さくなる為
サイズを調整したい。

・メール本文にPPT（\デスクトップ\PPT\3月.pptx）を
添付
【PictureTarget】の図の上に添付したい。

Excel D7セル
<div style ="font-size:9pt"><font face="Arial","ＭＳ ゴシック"><strong>TO<br>
CC</strong></font></div><br>
<div style ="font-size:12pt"><font face="Arial","ＭＳ ゴシック"><strong>確認<br><br>
○○　　予比　　　　【予比①】％　　 【前年差①】%<br>
○○　　予比　　　　【予比②】％　　 【前年差②】%<br>
</strong></font></div>
【PictureTarget】


Sub 検証()

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

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

mailObj.Display

Dim mailBody As String
mailBody = CreatemailBody1

With mailObj
.HTMLBody = mailBody
End With

ActiveSheet.Range("B2:BD49").CopyPicture

Dim objWRG As Word.Range
Set objWRG = mailObj.GetInspector.WordEditor.Range(0, 0)
With objWRG.Find
.Text = "【PictureTarget】"
.Execute
End With
objWRG.PasteSpecial

mailObj.BodyFormat = 3

End Sub


Function CreatemailBody1() As String

Dim Budget1, Budget2, difference1, difference2 As String
Dim Body As String

Budget1 = Range("D9")
Budget2 = Range("D10")
difference1 = Range("D14")
difference2 = Range("D15")

Body = Range("D7").Value
Body = Replace(Body, "【予比①】", Budget1)
Body = Replace(Body, "【予比②】", Budget2)

If difference1 < 0 Then difference1 = "<font color=""red"">" & difference1 & "</font>"
Body = Replace(Body, "【前年差①】", difference1)
If difference2 < 0 Then difference1 = "<font color=""red"">" & difference1 & "</font>"
Body = Replace(Body, "【前年差②】", difference2)

CreatemailBody1 = Body

End Function

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2022/03/17 17:11

＃１です。

なるほどですね。で、①はOKとして
②BodyFormatを変換すると書式が失われるは、お解りましたでしょうか、
失われて問題が生じているのであれば、先に変更してしまうのはどうでしょう。
コードにすると
With mailObj
.HTMLBody = mailBody
.Attachments.Add (？？？)
End With
mailObj.BodyFormat = 3
ActiveSheet.Range("B2:BD49").CopyPicture

ですが、これだと　【PictureTarget】と同じ位置の添付ファイルが挿入されると思われますので
添付ファイル挿入後にmailBody【PictureTarget】の上部に改行を入れる必要があると思いますが、少しややこしいと思いますので

WordEditorの文末に挿入するのは比較的簡単なので
考え方を変えて

添付ファイルを挿入する
改行を入れる
CopyPictureのターゲットテキストを挿入する

で出来ると思います。従って、D7セルの【PictureTarget】は不要になります

該当部分をコードにすると
mailBody = CreatemailBody1

With mailObj
.HTMLBody = mailBody
.Attachments.Add (CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\PPT\3月.pptx")
End With
mailObj.BodyFormat = 3

ActiveSheet.Range("B2:BD49").CopyPicture
Dim objWRG As Word.Range
Set objWRG = mailObj.GetInspector.WordEditor.Range(0, 0)
With objWRG
With .Application
.Selection.EndKey Unit:=6
.Selection.TypeText vbCrLf
.Selection.TypeText "【PictureTarget】"
End With
.Find.Text = "【PictureTarget】"
.Find.Execute
.PasteSpecial
.ShapeRange.Width = 500#
End With

この回答へのお礼

ありがとうございます。図の上部に添付ファイル挿入できました。1点、最初に私が記述したコードでは mailObj.BodyFormat = 3にしてもフォントやフォントサイズは変わらないままでしたが、頂いたコードで実行すると書式が失われました。書式をそのまま残すことはできないのでしょうか？

お礼日時：2022/03/18 01:59

No.5 回答者： Qchan1962 回答日時： 2022/03/19 00:39

＃４

文字オーバーになりそうでしたのでここで補足します
%は全角、半角にしていますのでコード内で変えてください

str4 = "予比　　　" & difference1 & " ％　　" & Budget1 & " %"
と str5の値が同じ場合は、うまく検索できないようなので
文字列が一意になるように工夫が必要になります。予比1　とか・・・
範囲取得が間違っているのかも。。
アプリケーション間の受け渡しがあるので必要に応じて
DoEvents　が必要かも知れませんね

合理的な汎用コードをかけるかも知れませんが、寄せ集めで失礼します

この回答へのお礼

詳しく追記頂きありがとうございます!!!1つずつ確認しながら実行してみます！！！

お礼日時：2022/03/19 01:27

No.4 回答者： Qchan1962 回答日時： 2022/03/19 00:12

こんばんは

＞Outlook2019 MSO 32ビット
ありがとうございます
＞図とPPTが重なってしまいました。
ひょっとして、
D7セルの【PictureTarget】は不要になりますので
削除していなかったのでは無いかと推測します。。
少し、Htmlフォーマットで設定されたものが、維持されるのか
テストしてみましたが、思考が崩壊して良く分かりませんでした
時間がある時に検証してみたいと思います。

提案してしまった
＞初めからリッチテキストで作成される方が良いように思います。
を過去の持ち合わせから改造して示します。

多分上手くいくと思います。
D7せるの値は要りません。げ、おそらく処理を色々されていると思いますのでどのように使えば良いか考える必要があるかも知れません。
同様に各アプリケーションの事前参照が必要です。
一応、ブロックごとに分けていますが、Bodyを作る時などの処理を
サブで行う場合は、変数をモジュールレベルなどにする必要があるかも知れません。
書式変換については、もう少しすっきりかける気がしますが、
逆に参考になるかも知れません。

まぁ、取り敢えずと言う事で
必要データ　 Range("D9") Budget2 = Range("D10")
Range("D14") Range("D15")
ステップ実行などで確認してみてください
Option Explicit
Sub Test1()
Dim oApp As Outlook.Application
Set oApp = New Outlook.Application
Dim objMAIL As Object
'アイテムの作成
Set objMAIL = oApp.CreateItem(olMailItem)
With objMAIL
.Display
.BodyFormat = 3
.To = "○○"
.CC = "○○"
.Subject = "○○件名"
.Body = ""　'ここではダメです
End With

'本文作成
Dim strBody As String
Dim str1 As String, str2 As String, str3 As String
Dim str4 As String, str5 As String
Dim Budget1, Budget2, difference1, difference2
Budget1 = Range("D9")
Budget2 = Range("D10")
difference1 = Range("D14")
difference2 = Range("D15")
str1 = "TO "
str2 = "CC "
str3 = "確認 "
str4 = "予比　　　" & difference1 & " ％　　" & Budget1 & " %"
str5 = "予比　　　" & difference2 & " ％　　" & Budget2 & " %"
strBody = str1 & vbCrLf & str2 & vbCrLf & vbCrLf & str3 & vbCrLf & vbCrLf
strBody = strBody & "○○　　" & str4 & vbCrLf & "△△　　" & str5 & vbCrLf & vbCrLf

'書式編集
Dim i As Integer
Dim objDoc As Object
Set objDoc = oApp.ActiveInspector.WordEditor
objDoc.Characters.First.InsertAfter (strBody)
objDoc.Content.Font.Name = "Arial"
For i = 0 To objDoc.Paragraphs.count
With objDoc.Range(i)
Select Case i
Case 0
.Find.Text = str1: .Find.Execute
.Font.Size = 9
Case 1
.Find.Text = str2: .Find.Execute
.Font.Size = 9
Case 4
.Find.Text = str3: .Find.Execute
With .Font
.Name = "ＭＳ ゴシック"
.Size = 12
.Bold = True
End With
Case 6
.Find.Text = str4: .Find.Execute
With .Font
.Name = "ＭＳ ゴシック"
.Size = 12
.Bold = True
End With
If difference1 < 0 Then
.Find.Text = Budget1: .Find.Execute
.Font.Color = vbRed
End If
Case 7
.Find.Text = str5: .Find.Execute
With .Font
.Name = "ＭＳ ゴシック"
.Size = 12
.Bold = True
End With
If difference2 < 0 Then
.Find.Text = Budget2: .Find.Execute
.Font.Color = vbRed
End If
End Select
Call resetFind(objDoc.Range.Find) '念のためFind_reSet
End With
Next

'添付ファイル
objMAIL.Attachments.Add _
(CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\PPT\3月.pptx")

'添付図
Dim objWRG As Word.Range
Set objWRG = objMAIL.GetInspector.WordEditor.Range(0, 0)
ActiveSheet.Range("B2:I10").CopyPicture
With objWRG
With objWRG.Application
.Selection.EndKey Unit:=6
.Selection.TypeText vbCrLf
.Selection.TypeText "【PictureTarget】"
End With
ActiveSheet.Range("B2:BD49").CopyPicture
.Find.Text = "【PictureTarget】": .Find.Execute
.PasteSpecial
End With

End Sub
Sub resetFind(ByRef Target As Find)
With Target
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Highlight = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
End Sub

この回答へのお礼

ありがとうございます。頂いたコード試してみます。D7セルは
○○　　予比　　　　【予比②】％　　 【前年差②】%<br>
</strong></font></div>で終わっており、【PictureTarget】は削除しています。原因不明です汗

お礼日時：2022/03/19 01:23

No.3 回答者： Qchan1962 回答日時： 2022/03/18 13:25

こんにちは

そうなりますか、やはりBodyFormatを変換すると書式が失われてしまうと言う事ですね。（HTMLで設定しリッチテキストに変換しているのですから
当然と言えば当然ですが）

Outlookを使わないのでバージョン情報をください。
すみませんが自己学習の為、少し時間をいただき試してみます

しかし、思うにロジック自体が破綻しているようにも思います。
添付図のように構成されたいのであれば、
初めからリッチテキストで作成される方が良いように思います。

この回答へのお礼

こんばんは。Outlook2019 MSO 32ビットです。リッチテキストでも大丈夫ですが、書式を設定したい場合はHTML→リッチテキストとネットに書いてあった為、HTMLにしました汗　又、教えて頂いたコードをいろいろ試したところ、下記だと書式は失われませんでしたーが図とPPTが重なってしまいました。

With mailObj
.HTMLBody = mailBody
End With
ActiveSheet.Range("B2:BD49").CopyPicture
Dim objWRG As Word.Range
Set objWRG = mailObj.GetInspector.WordEditor.Range(0, 0)
With objWRG
With .Application
.Selection.EndKey Unit:=6
.Selection.TypeText vbCrLf
.Selection.TypeText "【PictureTarget】"
End With
.Find.Text = "【PictureTarget】"
.Find.Execute
.PasteSpecial
.ShapeRange.Width = 500#
End With

　mailObj.BodyFormat = 3
　
With mailObj
.Attachments.Add (CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\PPT\3月.pptx")
End With

お礼日時：2022/03/18 23:33

No.1 回答者： Qchan1962 回答日時： 2022/03/17 12:23

こんにちは

①＞サイズを調整したい。
これに付いては、貼り付け後にサイズを調整する事が出来ます。
具体的なサイズが分からないので、この部分にコードを追加して
数値を調整してください。
数値については、現状サイズから算出する事も可能だと思います。
With objWRG.Find　以下を少し書き換えと追加しました

With objWRG
.Find.Text = "【PictureTarget】"
.Find.Execute
.PasteSpecial
.ShapeRange.Width = 100#
End With

.ShapeRange.Heightプロパティもありますので適時調整出来ると思います

②＞メール本文にPPT（\デスクトップ\PPT\3月.pptx）を添付
【PictureTarget】の図の上に添付したい。

ちょっとご質問の意味がわからないのですが、、
気になるのは、
mailObj.BodyFormat = 3　に変更しているからではないかと思います

多分、mailObj.BodyFormat = 2　HTML 形式　にしないと
（フォーマットを変えると）設定書式が失われると思いました。。

メールに添付ファイルを付ける場合

With mailObj
.HTMLBody = mailBody
.Attachments.Add (filePathString)
End With
で良いかと・・

変更すると書式が失われる？
記憶違いもあるかもなの、ご確認ください

あと、コードを読んで？？と思う事があります

Dim Budget1, Budget2, difference1, difference2 As String
これらの変数型はVariant,Variant,Variant,String となります
で、difference1, difference2の型は
If difference2 < 0 Then　としていつ事から数値型又はVariantにしなくてはエラーが返るはず？です
投稿するために添削されたものと推測しますが、確認してみてくださいね

この回答へのお礼

お返事ありがとうございます。
②については写真のように、本文に添付ファイルを貼り付けしたい為、HTML形式からリッチテキストに変更しております。変数型はエラーにならなかったので気づきませんでした（汗）御指摘ありがとうございます。

お礼日時：2022/03/17 13:09