VBAでWordの画像の差し替え

Question

実現したいこと

VBAでWordの画像の差し替えをしたい

前提

wordVBAで画像の差し替えを行うプログラムを作っています。
画像は行内ではありません。

発生している問題・エラーメッセージ

画像を差し替えることができず困っています。
おそらく18行目部分が誤っているものだと思われます。
Selection.ShapeRange.Fill.UserPicture picpath

該当のソースコード

Sub picreplace()
    Dim doc As Document
    Dim shape   As shape
    
    Set doc = ActiveDocument
    
    Dim picpath As String
    picpath = "ファイルパス"
    
    Dim j As Byte
    
    For j = 1 To ActiveDocument.Shapes.Count
    
        Set shape = doc.Shapes(j)
        
        If shape.Type = msoPicture Then
            shape.Select
            Selection.ShapeRange.Fill.UserPicture picpath
   
        End If
        
        Set shape = Nothing
    Next j
    
    Set doc = Nothing
    
    
End Sub

試したこと

差し替え前の画像を選択することはできているようです。

追記

    If shape.Type = msoPicture Then
        shape.Select
        shleft = shape.Left
        shtop = shape.Top
        shape.Delete
        doc.Shapes.AddPicture FileName:=picpath, Left:=shleft, Top:=shtop
        
    End If

上記のように、削除したあと同じ位置に追加する処理に変更したのですが、変更される画像と変更されない画像があります。

Comments

[bebebe_]

変更されるものとされないものがあるのであればされないもののTypeが「msoPicture」ではないということはないですか？

[hana_87]

ご指摘ありがとうございます。
if文の中でmsoPictureの数を出力する処理を仮で挿入してみたところ、変更したい画像の個数と同じ数が出力されたので、変更したい画像はすべてmsoPictureだと思われます。

[bebebe_]

状況が再現できないので原因がわかりませんがIF内を「shape.Select Replace:=False」だけにした場合変更されない画像も選択されますか？

[hana_87]

コメントありがとうございます。
IF内を「shape.Select Replace:=False」だけにした場合、変更されない画像を含む変更したい画像のすべてが選択されます。

Answer 1

1つの文書内にあるすべての画像を全く同一の画像に差し替えようとしています。

以上のコメントを受けて、次のように変更しました（2023/06/27 10:53）。

Sub ResetAllPicturesInActiveDocument()

    Dim strPicturePath As String
    Dim lngResetCount As Long

    strPicturePath = "C:\FolderName\FileName.png"

    Dim wrdShape As Word.Shape

    For Each wrdShape In ActiveDocument.Shapes
        Select Case wrdShape.Type
            Case msoPicture, msoLinkedPicture
                If ResetPicture(wrdShape, strPicturePath) Is Nothing Then
                    Exit Sub
                End If
                lngResetCount = lngResetCount + 1
            Case Else
                '何もしない
        End Select
    Next

    If lngResetCount > 0 Then
        MsgBox "この文書の描画レイヤーの図を " & lngResetCount & " 個差し替えました。", _
               vbInformation, _
               "実行完了 (ResetAllPicturesInActiveDocument)"
    Else
        MsgBox "この文書の描画レイヤーに挿入されている図はありません。", _
               vbInformation, _
               "実行完了 (ResetAllPicturesInActiveDocument)"
    End If

End Sub

Function ResetPicture(TargetShape As Word.Shape, NewPicturePath As String) As Word.Shape
On Error GoTo Err_ResetPicture

    If Dir(NewPicturePath) = "" Then
        MsgBox "指定されたパス""" & NewPicturePath & """に該当するファイルが見つかりません。", _
               vbExclamation, _
               "ファイル参照エラー (ResetPicture)"
        Exit Function
    End If

    Dim strShapeName As String
    Dim varLeftRelative As Variant
    Dim varRelativeHorizontalPosition As Variant
    Dim varLeft As Variant
    Dim varTopRelative As Variant
    Dim varRelativeVerticalPosition As Variant
    Dim varTop As Variant
    
    With TargetShape
        Select Case .Type
            Case msoPicture, msoLinkedPicture
                '何もしない
            Case Else
                MsgBox "図形""" & .Name & """は図ではありません。", _
                       vbExclamation, _
                       "オブジェクト参照エラー (ResetPicture)"
                Exit Function
        End Select
        
        .Select
        strShapeName = .Name
        varLeftRelative = .LeftRelative
        varRelativeHorizontalPosition = .RelativeHorizontalPosition
        If .LeftRelative = wdShapePositionRelativeNone Then
            varLeft = .Left
        End If
        varTopRelative = .TopRelative
        varRelativeVerticalPosition = .RelativeVerticalPosition
        If .TopRelative = wdShapePositionRelativeNone Then
            varTop = .Top
        End If
    End With
    
    Application.ScreenUpdating = False
    
    Dim wrdNewShape As Word.Shape
    
    Set wrdNewShape = ActiveDocument.Shapes.AddPicture(FileName:=NewPicturePath, _
                                                       LinkToFile:=False)
    
    With TargetShape
        .LeftRelative = wdShapePositionRelativeNone
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
        .TopRelative = wdShapePositionRelativeNone
        .RelativeVerticalPosition = wdRelativeVerticalPositionPage
    End With
    
    With wrdNewShape
        
        .WrapFormat.Type = TargetShape.WrapFormat.Type
        
        .LeftRelative = wdShapePositionRelativeNone
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
        .Left = TargetShape.Left
        
        .TopRelative = wdShapePositionRelativeNone
        .RelativeVerticalPosition = wdRelativeVerticalPositionPage
        .Top = TargetShape.Top
        
        .LeftRelative = varLeftRelative
        .RelativeHorizontalPosition = varRelativeHorizontalPosition
        If .LeftRelative = wdShapePositionRelativeNone Then
            .Left = varLeft
        End If
        
        .TopRelative = varTopRelative
        .RelativeVerticalPosition = varRelativeVerticalPosition
        If .TopRelative = wdShapePositionRelativeNone Then
            .Top = varTop
        End If
        
        Do While .ZOrderPosition > TargetShape.ZOrderPosition
            .ZOrder msoSendBackward
        Loop
    
    End With
    
Exit_ResetPicture:
On Error Resume Next
    
    If Not wrdNewShape Is Nothing Then
        TargetShape.Delete
        wrdNewShape.Name = strShapeName
        Set ResetPicture = wrdNewShape
    End If
    
    Application.ScreenUpdating = True
    
    Exit Function

Err_ResetPicture:

    MsgBox Err.Number & ": " & Err.Description, _
           vbCritical, _
           "実行時エラー (ResetPicture)"

    If Not wrdNewShape Is Nothing Then
        wrdNewShape.Delete
        Set wrdNewShape = Nothing
    End If
    
    Resume Exit_ResetPicture
End Function

Comments

[hana_87]

ご回答ありがとうございます。
こちらのコードを実行したところ、画像が1つ差し替わりました。
勉強不足で申し訳ございません。
複数個の画像を変更したいため、
Set wrdShape = Selection.ShapeRange.Item(1)
を(2)に変更したところ、「プロシージャの呼び出しまたは引数が不正です」と出てしまいました。

[sk.exe]

> 複数個の画像を変更したい

1つの文書内にある複数個の（全ての、または何らかの条件に該当する、あるいは複数選択された）図を、全く同一の画像に差し替えようとされているのでしょうか（何のために？）。

[hana_87]

書き方が悪く申し訳ございません。
1つの文書内にあるすべての画像を全く同一の画像に差し替えようとしています。
理由といたしましては、文中にあるQRコードの変更です。

[hana_87]

ありがとうございます。
解決いたしました。

Answer 2

この回答はGPT-4による自動生成回答です

以下のコードで画像の差し替えができるはずです。Selection.ShapeRange.Fill.UserPicture picpath の代わりに、shape.Fill.UserPicture picpath を使用しています。

Sub picreplace()
    Dim doc As Document
    Dim shape As Shape
    
    Set doc = ActiveDocument
    
    Dim picpath As String
    picpath = "ファイルパス"
    
    Dim j As Byte
    
    For j = 1 To ActiveDocument.Shapes.Count
    
        Set shape = doc.Shapes(j)
        
        If shape.Type = msoPicture Then
            shape.Fill.UserPicture picpath
        End If
        
        Set shape = Nothing
    Next j
    
    Set doc = Nothing
End Sub

このコードを使用して、Word文書内の画像を指定したファイルパスの画像に差し替えることができます。ただし、picpath には差し替えたい画像の正しいファイルパスを指定してください。

Comments

[hana_87]

こちらのコードに変更しても、画像は差し替わりませんでした。