スキルアップ・問題解決なら、モーグにおまかせ！

マクロ初心者です。以下の構文でoutlookのMailをexcel内の図を貼り付けて作成したいのですが、なぜかoutlookがアクティブになるときとならない時があります。タスクバーのアイコンは点滅するのでMail自体は作成できているのですが、sendkeyで図が張り付けることができません。解決策はないのでしょうか？
 
Sub Mail_Click()
 
    ThisWorkbook.Save
    Worksheets("sheet1").Protect UserInterfaceOnly:=True
 
    Dim toaddress, ccaddress, bccaddress As String
    Dim subject, mailBody, credit As String
    Dim oapp As Object, objmail As Object
     
    If Worksheets("sheet2").Range("B101") = 0 Then
        MsgBox "処理を終了します。", 0, "メッセージ"
        Exit Sub
    End If
     
    Set oapp = CreateObject("Outlook.Application")
    Set objmail = oapp.CreateItem(0)
                        oapp.ActiveWindow.WindowState = 2
 
    Dim i
        For i = Cells(Rows.Count, 6).End(xlUp).Row To 4 Step -1
            If Cells(i, 6) = "" Then
                GoTo Continue
            End If
                Range(Cells(i, 2), Cells(i, 8)).Select
                Selection.Delete xlShiftUp
Continue:
            Next
 
    toaddress = Worksheets("Mail").Range("B1").Value
    ccaddress = Worksheets("Mail").Range("B2").Value
    subject = Worksheets("Mail").Range("B3").Value
    mailBody = Worksheets("Mail").Range("B4").Value
    credit = Worksheets("Mail").Range("B5").Value
 
    With objmail
        .To = toaddress
        .CC = ccaddress
        .subject = subject
        .BodyFormat = 2
        .Body = mailBody & vbCrLf & vbCrLf & vbCrLf & credit
        .Display
        .GetInspector.Display (False)
    End With
 
    Dim ENDROW As Long
          ENDROW = Cells(Rows.Count, 5).End(xlUp).Row
 
        Range(Cells(4, 2), Cells(ENDROW, 2)).Value = Range(Cells(4, 2), Cells(ENDROW, 2)).Value
 
    Set wdDoc = ActiveInspector.WordEditor
    With wdDoc.Windows(1).Document.Range.Font
        .Name = "Meiryo UI"
        .Size = 10
    End With
        Worksheets("sheet1").Activate
        Range(Cells(3, 2), Cells(ENDROW, 8)).CopyPicture
     With oapp.ActiveInspector.WordEditor.Windows(1).Selection
        Application.Wait [Now()] + 1 / 86400
        SendKeys ("^{down 2}")
        SendKeys ("^v")
        SendKeys ("{ENTER}")
        SendKeys ("^{down 4}")
     End With
 
     Application.CutCopyMode = False
      
     Set oapp = Nothing
     Set objmail = Nothing
     
End Sub

昨日、以下のコメントをしましたが、その後全く音沙汰無いので、興味を失ったと見なして削除しました。
 

引用:
質問に対する考え方だけですが、
・SendKeysは不安定なことで定評があります。これは避けたほうがよいでしょう。
・別の方法を検討して下さい。

    With Worksheets("sheet1")
        .Range(.Cells(3, 2), .Cells(ENDROW, 8)).CopyPicture
    End With
    With oapp.ActiveInspector.WordEditor.Windows(1).Selection
        .Paste
    End With

のようにすることで図のコピー貼り付けができると思います。
貼り付け位置の調整などはそちらで工夫してください。

Sub Mail_Click()
    Dim oapp    As Object
    Dim objmail As Object
    Dim wdDoc   As Object
    Dim toaddress$, ccaddress$, bccaddress$  '$は As Stringと同一の意味
    Dim subject$, mailBody$, credit$

    Set oapp = CreateObject("Outlook.Application")
    Set objmail = oapp.CreateItem(0)
  
    With Worksheets("Mail")
        toaddress = .Range("B1").Value
        ccaddress = .Range("B2").Value
        subject = .Range("B3").Value
        mailBody = .Range("B4").Value
        credit = .Range("B5").Value
    End With
  
    With objmail
        .Display
        .BodyFormat = 2     'olFormatHTML
        .To = toaddress
        .CC = ccaddress
        .subject = subject
        '.Body = mailBody & vbCrLf & vbCrLf & vbCrLf & credit 'あとで纏めて書き込む。
        .GetInspector.Display (False) '既定値なら実行する必要なし？
    End With

    Dim ENDROW As Long
    With Worksheets("sheet1")
        ENDROW = Cells(Rows.Count, 5).End(xlUp).Row
        .Range(.Cells(4, 2), .Cells(ENDROW, 2)).Value =  _
               .Range(.Cells(4, 2), .Cells(ENDROW, 2)).Value
    End With

    Set wdDoc = oapp.ActiveInspector.WordEditor   
    With wdDoc.Windows(1).Document.Range.Font
        .Name = "Meiryo UI"
        .Size = 10
    End With

    With Worksheets("sheet1")
        .Range(.Cells(3, 2), .Cells(ENDROW, 8)).CopyPicture
    End With
    
    With oapp.ActiveInspector.WordEditor.Windows(1).Selection
        .TypeText mailBody & vbCrLf & vbCrLf
        .Paste              'Pictureを貼り付け
        .TypeText vbCrLf
        .TypeText credit & vbCrLf
    End With

    Set objmail = Nothing
    Set oapp = Nothing
End Sub