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

初めての投稿です。教えて頂けると幸いです。
宜しくお願い致しますm(_ _)m
 
Excel VBA メール（outlook）作成について
本文の中にExcel でコピーした表を上下に2つ
図として貼り付けをしたいです。
 
Range("D7")セル
（本文）<br><br>
【PT1】<br><br>
【PT2】
 
【PT1】【PT2】をそれぞれ図に置き換えたところ、
それぞれの位置に上手く置き換えができず、
【PT1】の位置に【PT2】の図だけが貼り付けされていました。
 
 

Dim outlookObj As Outlook.Application
  Set outlookObj = New Outlook.Application
 
  Dim mailObj As Outlook.MailItem
  Set mailObj = outlookObj.CreateItem(olMailItem)
 
  mailObj.Display
 
  Worksheets("リスト").Activate
 
  Dim mailBody As String
  mailBody = CreatemailBody
 
  With mailObj
    .To = Range("D5")
    .CC = Range("D6")
    .Subject = Range("D4")
    .HTMLBody = mailBody
  End With
 
    Dim objWRG As Word.Range
    Set objWRG = mailObj.GetInspector.WordEditor.Range(0, 0)
    With objWRG
        Worksheets("1").Range("A1:Z30").CopyPicture
        .Find.Text = "【PT1】"
        .Find.Execute
        .PasteSpecial
        .ShapeRange.Width = 900#
      Worksheets("2").Range("A3:AZ28").CopyPicture
        .Find.Text = "【PT2】"
        .Find.Execute
        .PasteSpecial
        .ShapeRange.Width = 900#
    End With
 
End Sub
 
Function CreatemailBody() As String
 
    Dim Body As String
    Dim Day As String
 
    Body = Range("D7")
    Body = Replace(Body, "【月】", Day)
    CreatemailBody = Body
 
End Function

Word の Find を使っていますよね。
 
Word の Find は 検索対象が見つかった場合、Rangeオブジェクトの対象が変わります。
 
 

Sub TEST1()
  Dim wrd As Word.Application
  Dim doc As Word.Document
  Dim rng As Word.Range
 
  Set wrd = CreateObject("Word.Application")
  Set doc = wrd.Documents.Add
  wrd.Visible = True

  rng.Text = Worksheets("リスト").Range("D7")
 
  Set rng = doc.Content
  rng.Find.Execute FindText:="【PT1】", ReplaceWith:="AA"
  rng.Find.Execute FindText:="【PT2】", ReplaceWith:="BB"
End Sub

学習目的でトライしてみました。
方法のテストなので、前提は少し変えています。そちらでよしなに修正してください。
# 日頃outlookは使いませんので、少し怪しいです。そのおつもりで。
 

Option Explicit
Rem　OutlookとWordを参照設定してください。
Sub test()
    Dim outlookObj As Outlook.Application
    Set outlookObj = New Outlook.Application

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

    mailObj.Display

    Dim ws As Worksheet
    Set ws = Worksheets("リスト")

    Dim mailBody As String
    mailBody = "本文" & "<br><br>" _
            & "【PT1】" & "<br><br>" _
            & "【PT2】" & "<br><br>" _
            & "署名"
    ''CreatemailBody

    With mailObj
        .BodyFormat = 2     'olFormatHTML
        .To = ws.Range("D5")
        .CC = ws.Range("D6")
        .Subject = ws.Range("D4")
        .HTMLBody = mailBody
    End With

    Dim doc As Object
    Set doc = mailObj.GetInspector.WordEditor
    Dim word As Object
    Set word = doc.Parent
    
    Dim objWRG As word.Range
    Set objWRG = doc.Range(0, 0)
    objWRG.Select
    
    Dim sel As word.Selection
    Set sel = word.Selection
   
    Dim f As Object
    With sel
        Worksheets(1).Range("A1:C3").CopyPicture
        Set f = .Find
        f.Text = "【PT1】"
        f.Execute
        .PasteSpecial Placement:=wdInLine
        
        Worksheets(1).Range("A5:C7").CopyPicture
        f.Text = "【PT2】"
        f.Execute
        .PasteSpecial Placement:=wdInLine
    End With
    'Stop
End Sub

返信ありがとうございます。
Sub TEST1()で1ステップずつ実行したところ、
rng.Text = Worksheets("メールリスト").Range("D7")が
『実行エラー91　オブジェクト変数またはwithブロック変数が設定されていません。』
と表示されました。
 
VBA初心者な為、どう対処したらいいか教えて頂けると幸いです。
宜しくお願い致しますm(_ _)m

[quote="simple"]様　ありがとうございます。
2つの表をメールに貼り付けできました。
ただし.ShapeRange.Width = 500#を追加しても
表のサイズが変更されませんでした。
 
対処法をご存知であれば教えて頂けると幸いです。
宜しくお願い致します。
　

Sub test()
    Dim f As Object
    With sel
        Worksheets(1).Range("A1:C3").CopyPicture
        Set f = .Find
        f.Text = "【PT1】"
        f.Execute
        .PasteSpecial Placement:=wdInLine
        [b].ShapeRange.Width = 500#[/b]

        
        Worksheets(1).Range("A5:C7").CopyPicture
        f.Text = "【PT2】"
        f.Execute
        .PasteSpecial Placement:=wdInLine
        [b].ShapeRange.Width = 500#[/b]
    End With
    'Stop
End Sub

inlineshapeというので操作するとよいみたいですね。
「Wordに張り付けた図のサイズをまとめて変更する！」
http://office2007vba.blog96.fc2.com/blog-entry-12.html
を参考にトライしてみてください。

wa-nn さんの引用:
返信ありがとうございます。
Sub TEST1()で1ステップずつ実行したところ、
rng.Text = Worksheets("メールリスト").Range("D7")が
『実行エラー91　オブジェクト変数またはwithブロック変数が設定されていません。』
と表示されました。
 
VBA初心者な為、どう対処したらいいか教えて頂けると幸いです。
宜しくお願い致しますm(_ _)m

その後いかがですか？
参考記事をもとにして、以下のようにするとよいと思います。
 

    Worksheets(1).Range("A5:C7").CopyPicture
    f.Text = "【PT2】"
    f.Execute
    .PasteSpecial Placement:=wdInLine

    Dim k As Long
    .WholeStory
    For k = 1 To .InlineShapes.Count
        .InlineShapes(k).LockAspectRatio = msoTrue  '縦横の比率を保持
        .InlineShapes(k).Width = 200    '適当に。単位はポイント(≒0.3528mm）
    Next

    For k = 1 To doc.InlineShapes.Count
        doc.InlineShapes(k).LockAspectRatio = msoTrue  '縦横の比率を保持
        doc.InlineShapes(k).Width = 200    '適当に。単位はポイント(≒0.3528mm）
    Next

simple さんの引用:
inlineshapeというので操作するとよいみたいですね。
「Wordに張り付けた図のサイズをまとめて変更する！」
http://office2007vba.blog96.fc2.com/blog-entry-12.html
を参考にトライしてみてください。

Suzu さんの引用:

wa-nn さんの引用:
返信ありがとうございます。
Sub TEST1()で1ステップずつ実行したところ、
rng.Text = Worksheets("メールリスト").Range("D7")が
『実行エラー91　オブジェクト変数またはwithブロック変数が設定されていません。』
と表示されました。
 
VBA初心者な為、どう対処したらいいか教えて頂けると幸いです。
宜しくお願い致しますm(_ _)m

 
すみません。
 
  rng.Text = Worksheets("リスト").Range("D7")
　　　↓
  Set rng = doc.Content
  rng.Text = Worksheets("リスト").Range("D7")
 
としてください。

simple さんの引用:
その後いかがですか？
参考記事をもとにして、以下のようにするとよいと思います。
 

    Worksheets(1).Range("A5:C7").CopyPicture
    f.Text = "【PT2】"
    f.Execute
    .PasteSpecial Placement:=wdInLine

としたあとで、

    Dim k As Long
    .WholeStory
    For k = 1 To .InlineShapes.Count
        .InlineShapes(k).LockAspectRatio = msoTrue  '縦横の比率を保持
        .InlineShapes(k).Width = 200    '適当に。単位はポイント(≒0.3528mm）
    Next

とするとよいと思います。
それは、以下のようにしても同じことになります。

    For k = 1 To doc.InlineShapes.Count
        doc.InlineShapes(k).LockAspectRatio = msoTrue  '縦横の比率を保持
        doc.InlineShapes(k).Width = 200    '適当に。単位はポイント(≒0.3528mm）
    Next