[[20220619181414]]　『【Outlook VBA】メール本文にExcel表を挿入し作成』（稔）　ページの最後に飛ぶ

『【Outlook VBA】メール本文にExcel表を挿入し作成/送信する方法』（稔）

ub Outlookのメールを新規作成する_Excelデータと表を取得()

    'Outlook用の定義
    Dim objMail As Object

    'Excel用の定義
    Dim appExl As Excel.Application
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
     Dim objSheet As Worksheet
    Dim lnContactCount As Long

    '表貼り付け用定義
    Dim objTableRG As Range
    Dim objWRG As Word.Range
    Dim strPastePos As String
    Dim i As Long
Dim olitem
    'Excelのブックとワークシートのオブジェクトを設定します。
    Set appExl = CreateObject("Excel.Application")

    'Excelウインドウを表示させます。非表示としたい場合はFalseを設定してください。
    appExl.Visible = True

    '指定したExcelブックを開き、オブジェクトに設定します。パスは環境にあわせて変更してください。
    Set wbBook = appExl.Workbooks.Open("C:\Users\user\Desktop\営業成績.xlsm")

    '表があるシート名と範囲を指定します。
    Set objSheet = wbBook.Sheets("山下6月度")
    Set objTableRG = objSheet.Range("A1:B6")

    '表貼り付けの位置となる文字列を指定します。""内の文字列は適宜変更してください。
    strPastePos = "＜表挿入位置＞"

     'Excelブック1シート目をオブジェクトに設定します。
    Set wsSheet = wbBook.Worksheets(1)

    '取得結果を記述する行番号を指定します。2行目のセルから開始されることになります。
    lnContactCount = 2                   '  lnContactCount= Activecell.ROW 'アクティブセルだけ開始

    If MsgBox("Outlookメールを作成しますか？", vbYesNo + vbQuestion, "確認") = vbYes Then

        '一覧の件数分繰り返します。
        For i = lnContactCount To wsSheet.Cells(1, 1).End(xlDown).Row

            'メールを作成します。
            Set objMail = CreateItem(olMailItem)

            With objMail

                .BodyFormat = 3 ' 「3」の場合リッチテキスト型となります。「1」はテキスト型、「2」は HTML型となります。
                .Subject = wsSheet.Cells(i, 1) '件名を指定します。
                .body = wsSheet.Cells(i, 2) '本文を指定します。
                .To = wsSheet.Cells(i, 3) 'Toを指定します。
                .CC = wsSheet.Cells(i, 4) 'CCを指定します。

 ' If .BodyFormat = olFormatHTML Then  '改行↓にする。
            '    .htmlBody = ActiveCell
                'Excel表貼り付け処理----ここから

                '本文に表貼り付けの位置を示す文字があるかチェックします。
                If InStr(.body, strPastePos) Then

                    'Excel表をコピーします。
                    objTableRG.Copy

                    'メールアイテムをWordEditor経由で編集します。
                    Set objWRG = .GetInspector.WordEditor.Range(0, 0)

                    '対象位置の文字列を選択します。
                    objWRG.Find.Text = strPastePos
                    objWRG.Find.Execute

                    '予定表本文へ貼り付けます。
                    objWRG.Paste
                End If
                'Excel表貼り付け処理----ここまで

                '宛先が空欄であるか判定します。
                If wsSheet.Cells(i, 3) = "" Then
                    .Display  'メールを表示します。
                Else
                    .Display 'メールを表示します。
                  '  .Send  'メールを送信します。
                End If
           End With
    Next

    Else
        MsgBox "処理を中断します"
    End If

    'Excelウインドウを閉じます。
     appExl.Quit

    'オブジェクトを解放します。

    Set olitem = Nothing
    Set wbBook = Nothing
    Set wsSheet = Nothing
    Set objTableRG = Nothing
    Set objWRG = Nothing

    MsgBox "Outlookメールの作成が完了しました！", vbInformation

End Sub
　　　　
　　　　　　A1　　　　　　　　　B1　　　　　　　　C1

件名業務日報（2021年12月10日）本文　　　　　To

　　　　　　A2　　　　　　　　　B2　　　　　　　　C2　　hn・・＠gmail
業務日報（2021年12月10日） "宛先各位

　　　　　　　　　　　　　　　　　本日の業務内容について以下の通り報告　　　　　　
　　　　　　　　　　　　　　　　　いたします。
　　　　　　　　　　　　　　　
　　　　　　　　　　　　　　　　　　
　　　　　　　　　　　　　　　　　　＜表挿入位置＞

　　　　　　　　　　　　　　　　　
　　　　　　　　　　　　　　　　　　以上／営業部山下
デスクトップ上に営業成績のファイルがあり山下6月度のｼ-ﾄがあります。
＜表挿入位置＞に営業成績の表が貼りつきません。コードがわるいのでしょうか？参照設定はEXCEL、WORD、OUTLOOK16.0 OLE　AUTo、script RUNtime してます。　表が貼りつかず、＜表挿入位置＞そのままの文字列になてしまいます。

＜使用 Excel：Excel2010、使用 OS：unknown ＞

 'メールアイテムをWordEditor経由で編集します。
                    Set objWRG = .GetInspector.WordEditor.Range(0, 0)
                    '対象位置の文字列を選択します。
                    objWRG.Find.Text = strPastePos
                    objWRG.Find.Execute
この辺がよくわかりません。Webサイトからのコードですが、うまく活用できません。申し訳ありません。
（稔） 2022/06/19(日) 20:51

        With objMail
            .Display
 と新規メール作成画面をすぐに表示するようにして、
 ステップ実行して確認してみてはどうですか？
 できているように思いますが、ご自身でよく確認することですね。

 ExcelとWordの参照設定は実行していますね？

（γ） 2022/06/19(日) 23:48

やはり表は貼りつきません。＜表挿入位置＞の文字れのままです。何かの設定ができていないのでしょうか？本当に残念です。誰かお助けを！！！
（稔） 2022/06/20(月) 20:15

私の手元では正常動作するので如何ともしがたいです。
お力になれずすみません。
（γ） 2022/06/20(月) 20:41

参考にしたサイトはこちらですか？
【Outlook VBA】メール本文にExcel表を挿入し作成/送信する方法！｜エク短
http://extan.jp/?p=6692

上記サイトを参考にされているのであれば、このコードは「Outlook」に設定する事になっているのではないでしょうか？
（説明途中に「Outlook側へVBAを実装します」という文言あり）

今、Outlookに貼り付けて試されているという事で良いでしょうか？？
（you） 2022/06/20(月) 21:22

Outlookに貼り付けて試しましたが表のｺﾋﾟ-ができず＜表挿入位置＞の文字列のままでした。
申し訳ありません。何か作業環境設定に不備があるのでしょうか？
（稔） 2022/06/21(火) 05:44

 念のための確認です。

 |        With objMail
 |             .Display
 |  と新規メール作成画面をすぐに表示するようにして、
 |  ステップ実行して確認してみてはどうですか？
 と書きましたが、これは実行してもらっていますか？

 ↓これらのコードは実際に通っていますか？（実行されていますか？）
    'メールアイテムをWordEditor経由で編集します。
    Set objWRG = .GetInspector.WordEditor.Range(0, 0)
    '対象位置の文字列を選択します。
    objWRG.Find.Text = strPastePos
    objWRG.Find.Execute
    '予定表本文へ貼り付けます。
    objWRG.Paste
 その時に、メール作成画面を見て、なにか動きはありませんか？

（γ） 2022/06/21(火) 06:20

ステップ実行して新規メール作成画面をにてもやはり以下のコードが実行されないです。

  '本文に表貼り付けの位置を示す文字があるかチェックします。
                If InStr(.Body, strPastePos) Then

                    'Excel表をコピーします。
                    objTableRG.Copy

                    'メールアイテムをWordEditor経由で編集します。
                    Set objWRG = .GetInspector.WordEditor.Range(0, 0)

                    '対象位置の文字列を選択します。
                    objWRG.Find.Text = strPastePos
                    objWRG.Find.Execute

                    '予定表本文へ貼り付けます。
                    objWRG.Paste
                End If
（稔） 2022/06/21(火) 07:35

'本文に表貼り付けの位置を示す文字があるかチェックします。

                If InStr(.Body, strPastePos) Then

このコードに問題があるのでしょうか？

（稔） 2022/06/21(火) 07:39

    Debug.Print .Body
    Debug.Print strPastePos
    If InStr(.Body, strPastePos) Then
 と2行を挿入して、内容を確認して.BodyのなかにstrPastePosが現れるか確認してください。
 ＜＞の全角半角になどに注意してください。
（γ） 2022/06/21(火) 08:43

これも念のために申し上げるが、
出力はイミディエイトウインドウにされるので、それを見て下さい。
（γ） 2022/06/21(火) 09:11

ありごとうございます。原因がわかりました。>半角で書いたつもりがコードをの最後が＞全角なっていました。

イミディエイトウィンドウで見て念入りに調べたら

宛先各位

本日の業務内容について以下の通り報告いたします。

<表挿入位置＞☜全角になっていました。

以上／営業部山下

<表挿入位置>
（稔） 2022/06/21(火) 09:37

あなたの提示されたコードでは、
| '表貼り付けの位置となる文字列を指定します。""内の文字列は適宜変更してください。
| strPastePos = "＜表挿入位置＞"
と全角になっていますが、今回の

 Debug.Print strPastePos
の結果では半角になっている。

話に整合性がないので大変戸惑いますが、
まあこだわっても仕方がないですな。
解決したのでよしということですね。

ちなみに、
＞ステップ実行して新規メール作成画面をにてもやはり以下のコードが実行されないです。
「やはり」と言われても、
そこが実行されていない旨の記述は一度もなかったはずですが。

それらのステップが実行されていなければ、
表が貼り付けられるわけがないじゃないですか。
最初からステップ実行したりして確認していただいていれば、
もっと早くに原因が解明できていたでしょうね。

お疲れさま。

（γ） 2022/06/21(火) 09:57

コメント返信：

[ 一覧(最新更新順) ]

[[20220619181414]] 『【Outlook VBA】メール本文にExcel表を挿入し作成』（稔） ページの最後に飛ぶ

[[20220619181414]]　『【Outlook VBA】メール本文にExcel表を挿入し作成』（稔）　ページの最後に飛ぶ