none
VBAでメールにテキストと画像を挿入するも、Outlookのメール上で、順番が反転してしまいます RRS feed

  • 質問

  • ご教授頂きたく、投稿致しました。

    下記のVBAコードを記載しましたが、完成のOutlookのメール上では、Range("B3:B15").Copyの画像が先に表示され、その後に、Range("B2")のテキストが表示されてしまいます。

    順番を逆にしたいのですが、上手く行かず、お手本のコードをご教授頂けますでしょうか?

    宜しくお願い致します。

    Option Explicit

    Sub SendoutEmails()

    Dim objOutlook As Outlook.Application
    Dim i
    Dim rowMax As Long
    Dim wsList As Worksheet
    Dim wsMail As Worksheet
    Dim objMail As Outlook.MailItem
    Dim objOL As New Outlook.Application
    Dim myItem As Worksheet
    Dim Mail As Worksheet
    Dim oApp As Outlook.Application

    Set objOutlook = New Outlook.Application
    Set wsList = ThisWorkbook.Sheets("送信先")
    Set wsMail = ThisWorkbook.Sheets("メール内容")
    Set myItem = ThisWorkbook.Sheets("送信先")
    Set oApp = CreateObject("Outlook.Application")
    Set objMail = oApp.CreateItem(0)

    With wsList
        '送信先の件数
        rowMax = .Cells(Rows.Count, 1).End(xlUp).Row

        '送信先の件数分繰り返す
        For i = 2 To rowMax
            Set objMail = objOutlook.CreateItem(olMailItem)
            With wsMail
                objMail.To = wsList.Cells(i, 3).Value       'メール宛先
                objMail.BCC = wsList.Cells(i, 4).Value       'BCC宛先
                objMail.Subject = .Range("B1").Value        'メール件名
                objMail.BodyFormat = 3 ' 3 リッチテキスト型、2 HTML
                objMail.Body = wsList.Cells(i, 1).Value & vbCrLf & wsList.Cells(i, 2).Value & " 様" & vbCrLf & vbCrLf & .Range("B2").Value & vbCrLf


    objMail.Display

    Range("B3:B15").Copy
    With oApp.ActiveInspector.WordEditor.Windows(1).Selection.Paste
    Application.CutCopyMode = False
    End With

        End With
        Next i

    End With

    End Sub

    2020年7月16日 12:36

すべての返信

  • エディタ部分をWordのオブジェクトとして操作してみる
    With wsList
        '送信先の件数
        rowMax = .Cells(Rows.Count, 1).End(xlUp).Row
        
        '送信先の件数分繰り返す
        For i = 2 To rowMax
            Set objMail = objOutlook.CreateItem(olMailItem)
            With wsMail
                objMail.To = wsList.Cells(i, 3).Value       'メール宛先
                objMail.BCC = wsList.Cells(i, 4).Value       'BCC宛先
                objMail.Subject = .Range("B1").Value        'メール件名
                objMail.BodyFormat = 3 ' 3 リッチテキスト型、2 HTML
    
                Dim head As String
                head = objMail.Body = wsList.Cells(i, 1).Value & vbCrLf & wsList.Cells(i, 2).Value & " 様" & vbCrLf & vbCrLf & .Range("B2").Value & vbCrLf
                 
                Dim insp As Outlook.Inspector
                Set insp = objMail.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 = head
                    
                    wrange.MoveEnd Word.WdUnits.wdStory 'カーソルを最後に
                    wrange.Start = wrange.End
                                        
                    Range("B3:B15").Copy 'このRangeはどのシートか不確定
                    wrange.Paste
                    
                Else
                    objMail.Body = head
                End If
                
                objMail.Display
            End With
        Next i
    
    End With

    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    2020年7月16日 14:33
  • gekka さん

    早々にご返信頂きまして、誠にありがとう御座いました。早速、トライしてみました。

    大変恐れ入りますが、下記も再度ご検討頂けると、非常に助かります。

    メールに上部に「False」と「フッタ情報(よくあるメール署名)」が表示され、
     Dim head As String
     head = objMail.Body = wsList.Cells(i, 1).Value & vbCrLf & wsList.Cells(i, 2).Value & " 様" & vbCrLf & vbCrLf & .Range("B2").Value & vbCrLf
     の部分が表示されませんでした。

    それ以降の情報は、問題無く表示されました。

    お手数をお掛け致しますが、再度ご教授頂けますでしょうか?

    何卒、宜しくお願い申し上げます。

    2020年7月17日 3:41
  • コピペミスしてました。
    objMail.Bodyの部分が不要です。

    Dim head As String
    head = wsList.Cells(i, 1).Value & vbCrLf & wsList.Cells(i, 2).Value & " 様" & vbCrLf & vbCrLf & .Range("B2").Value & vbCrLf
    

    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    2020年7月17日 3:56
  • gekka さん 再度ご確認頂きまして、誠にありがとう御座います。

    無事に、下記の部分は表示されるようになりました!

    Dim head As String head = objMail.Body = wsList.Cells(i, 1).Value & vbCrLf & wsList.Cells(i, 2).Value & " 様" & vbCrLf & vbCrLf & .Range("B2").Value & vbCrLf

    ただ、最後に1点だけ、上記の表示後に、メールのヘッダ(署名)部分が表示された後に、Range("B3:B15").Copyの部分が表示されます。

    他のコードだと、メールのヘッダ(署名)部分が勝手に挿入されることは、無かったのですが、表示させない何か良い方法は御座いますでしょうか?

    何度も申し訳御座いませんが、最後にご教授頂けると助かります。

    何卒、宜しくお願い致します。
    2020年7月17日 4:43
  • Word.Documentが取れたらあとはWordのマクロと同じ考えをすればいいのです

    'wrange.MoveEnd Word.WdUnits.wdStory 'カーソルを最後に
    'wrange.Start = wrange.End
    Call wrange.Move(WdUnits.wdCharacter, Len(head))

    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    2020年7月18日 3:41