本文が最後に表示されてしまいます。

質問

以下内容でＶＢＡを組んで、メールにコピペさせたんですが
本文が下に行き、コピーしたグラフが先に表示されます。
どうにか、
　"お疲れ様です。" & vbCrLf _
& "このメールと同時にプリンターに同様の用紙が印刷されます。" & vbCrLf _
& "印刷された用紙で、前確ＦＡＸを送信してください。" &vbCrLf _
& "尚、以下内容で、前確ＦＡＸ送信いたします。"
の部分を本文のトップに持って来れないでしょうか？

ＶＢＡは下記のように書いております。

Sub Outlookforexcel() '※１

Dim oApp As Object
Dim myNameSpace As Object
Dim myFolder As Object

Dim objMAIL As Object 'メールのオブジェクト
Dim strMOJI As String '本文

'outlook 起動
Set oApp = CreateObject("Outlook.Application")

Set myNameSpace = oApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(6) '規定のフォルダーを指定

'メールアイテムの作成
Set objMAIL = oApp.CreateItem(0) 'olMailItem=0 直値はいけないと思いつつ、
objMAIL.BodyFormat = 3 'olFormatRichText=3 で リッチテキスト形式へ
'宛先・件名・本文 などのデータを代入する
objMAIL.To = Range("O1") '宛先 .TO セルO3から代入
objMAIL.Cc = Range("O2")
objMAIL.Subject = "【確認ＦＡＸ】印刷終了以下内容で送信します。" '.Subjectで件名

strMOJI = "お疲れ様です。" & vbCrLf _
& "このメールと同時にプリンターに同様の用紙が印刷されます。" & vbCrLf _
& "印刷された用紙で、確認ＦＡＸを送信してください。" & vbCrLf _
& "尚、以下内容で、確認ＦＡＸ送信いたします。"
DoEvents
objMAIL.Body = strMOJI '本文の初期化
DoEvents

objMAIL.Display '画面表示(Mail入力、編集画面を表示)
DoEvents

'Outlook貼り付けのコマンドをコマンドバーから探す
Dim oCBs As Object
Dim oCtl As Object

'今起動中のobjMAIL(メール作成中)のコマンドバーを取り出すよ
Set oCBs = objMAIL.GetInspector.CommandBars

'ループで貼り付けの文字を探す、、、
Dim I As Long 'カウンター
For I = 1 To 35000
'コントロール I 番目を取り出す
Set oCtl = oCBs.FindControl(, I)

If Not (oCtl Is Nothing) Then 'オブジェクトが空じゃなければ
'文字列でコマンド名を比較する
Debug.Print ".Caption " & oCtl.Caption
If oCtl.Caption = "貼り付け(&P)" Then
' ↑で見つけたら oCtlはそのままで、ループを抜ける。
Exit For 'これ以上はループしないでいいので。
End If
End If
Next

'コピー(Excelから)と貼り付け(Outlookへ)処理

Range("A1:I80").Select 'Excel
Selection.Copy
DoEvents

oCtl.Execute '↑で見つけたoCtl 貼り付けコマンド(outlook)を実行
DoEvents

objMAIL.send '送信箱へ ※セキュリティの警告メッセージが出るよ

'ここで、普通はオブジェクトの開放など、後始末をする。
Set oCtl = Nothing
Set oCBs = Nothing

End Sub

回答No.1

Wendy02

こんばんは。

少し、手直ししてみました。★の部分が換えた部分です。

'-------------------------------------------
Sub Outlookforexcel() '※１

　　Dim oApp As Object
　　Dim myNameSpace As Object
　　Dim myFolder As Object

　　Dim objMAIL As Object 'メールのオブジェクト
　　Dim strMOJI As String '本文

　　'outlook 起動
　　Set oApp = CreateObject("Outlook.Application")

　　Set myNameSpace = oApp.GetNamespace("MAPI")
　　Set myFolder = myNameSpace.GetDefaultFolder(6) '規定のフォルダーを指定

　　'メールアイテムの作成
　　Set objMAIL = oApp.CreateItem(0) 'olMailItem=0 直値はいけないと思いつつ、
　　objMAIL.BodyFormat = 3　　　　　 'olFormatRichText=3 で リッチテキスト形式へ
　　'宛先・件名・本文 などのデータを代入する
　　objMAIL.To = Range("O1")　　　'宛先 .TO　セルO3から代入
　　objMAIL.Cc = Range("O2")
　　objMAIL.Subject = "【確認ＦＡＸ】印刷終了以下内容で送信します。"　　　　'.Subjectで件名

　　strMOJI = "お疲れ様です。" & vbCrLf _
　　　　　　& "このメールと同時にプリンターに同様の用紙が印刷されます。" & vbCrLf _
　　　　　　& "印刷された用紙で、確認ＦＡＸを送信してください。" & vbCrLf _
　　　　　　& "尚、以下内容で、確認ＦＡＸ送信いたします。" & vbCrLf　'←-★ここに改行を加える
　　DoEvents
　　objMAIL.Body = strMOJI '本文の初期化
　　DoEvents

　　objMAIL.Display　 '画面表示(Mail入力、編集画面を表示)
　　DoEvents

　　'Outlook貼り付けのコマンドをコマンドバーから探す
　　Dim oCBs As Object
　　Dim oCtl As Object

　　'今起動中のobjMAIL(メール作成中)のコマンドバーを取り出すよ
　　Set oCBs = objMAIL.GetInspector.CommandBars
　　Set oCtl = oCBs.FindControl(, 22)　'★これだけでよい
　　'ループで貼り付けの文字を探す、、、
'　　Dim I As Long　'カウンター
'　　For I = 1 To 35000
'　　　 'コントロール I 番目を取り出す
'　　　 Set oCtl = oCBs.FindControl(, I)
'
'　　　 If Not (oCtl Is Nothing) Then　　　　　 'オブジェクトが空じゃなければ
'　　　　　 '文字列でコマンド名を比較する
'　　　　　　Debug.Print ".Caption " & oCtl.Caption
'　　　　　　If oCtl.Caption = "貼り付け(&P)" Then
'　　　　　　　　' ↑で見つけたら oCtlはそのままで、ループを抜ける。
'　　　　　　　　Exit For　'これ以上はループしないでいいので。
'　　　　　　End If
'　　　 End If
'　　Next

　　'コピー(Excelから)と貼り付け(Outlookへ)処理

　　'Range("A1:I80").Select　　　　'Excel
　　ActiveSheet.ChartObjects(1).Select　'★グラフなら、こちらになる

　　Selection.Copy
　　DoEvents
　　CreateObject("Wscript.Shell").SendKeys "^{END}"　'★文末へ
　　oCtl.Execute
　　DoEvents

　　objMAIL.send　 '送信箱へ ※セキュリティの警告メッセージが出るよ

　　'ここで、普通はオブジェクトの開放など、後始末をする。
　　Set oCtl = Nothing
　　Set oCBs = Nothing
　　Set oApp = Nothing　'★解放を加える
End Sub

お礼

ありがとうございます。

早速実行した。
最初は、他にも印刷のマクロも組んでるので、うまくいかなかったですが
DoEventsで、解決しました。

どうもありがとうございます。