Question

我有一个Word文档，其中包含多个图像的完整文件路径（例如C：\ Users \ Name \ Documents \ Test Logos \ alphatest.png）。我正在尝试创建一个宏来将每个文本文件路径替换为它所指的内联形状的图像。该脚本还调整图像大小。我无法使用Set语句为内联形状对象变量分配有效引用。

（（现在，我通过在Word文档中的文本之前和之后手动放置＆＃34; QQQ＆＃34;然后让脚本搜索侧面为＆的文本来查找Word文档中的文件路径＃34; QQQ。＆＃34;因此，在Word文档中，每个文件路径如下所示：＆＃34; QQQC：\ Users \ Name \ Documents \ Test Logos \ alphatest.pngQQQ＆＃34;。这是一个临时的kludge并且似乎不是错误的来源。））

Sub InsertAndResizeLogos()
'
' InsertAndResizeLogos Macro
' Insert logos at the correct place in the document, resize to less than 1 inch tall and 2 inches wide.
'
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Text = "QQQ*QQQ"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        Do While .Execute
            While Selection.Find.Found
                Dim imagePath As String
                Debug.Print Replace(Selection.Text, "QQQ", "")
                imagePath = Replace(Selection.Text, "QQQ", "")
                imagePath = Replace(imagePath, "\", "//")
                imagePath = Replace(imagePath, vbCr, "")
                Debug.Print imagePath

                Dim SHP As InlineShape
                Set SHP = Selection.InlineShapes.AddPicture(FileName:=imagePath, LinkToFile:=False, SaveWithDocument:=True)
                    SHP.LockAspectRatio = True
                    SHP.Height = InchesToPoints(1)
                If SHP.Width > InchesToPoints(2) Then
                    SHP.Width = InchesToPoints(2)
                End If
            Wend
        Loop
    End With

End Sub

如果我没有将文件路径字符串转换为VBA的首选格式（即从脚本中删除此行：）

                imagePath = Replace(imagePath, "\", "//")

然后脚本成功梳理Word文档，找到第一个文件路径，并用正确的图像替换它。但是它会抛出一个＆＃34;运行时错误5152：这不是一个有效的文件名。＆＃34;在＆＃34; Set＆＃34;线和休息。

如果我将文件路径字符串转换为VBA格式，方法是将文件路径字符串转换为VBA格式，那么它不能成功插入图像并抛出一个＆＃34;运行时错误91：对象变量或没有设置块变量＆＃34;在SHP.LockAspectRation = True line和break。

似乎我将文件路径输入到带有//的Set语句中，它就无法再找到图像了。这是我可以通过错误处理解决的问题，还是我犯了一个更基本的错误？

（（如果我在脚本中设置文件路径，（即imagePath = C：\ Users \ Name \ Documents \ Test Logos \ alphatest.png），脚本将成功遍历整个记录并用QQQ替换所有带有该图像的文本。））

解

以下是正确运行的最终代码：

Sub InsertAndResizeLogos() ' ' InsertAndResizeLogos Macro ' Insert logos at the correct place in the document, resize to less than 1 inch tall and 2 inches wide. ' Application.ScreenUpdating = False Dim i As Long, j As Long, StrNm As String, StrErr As String, iShp As InlineShape With Selection 'ActiveDocument.Range With .Find .ClearFormatting .Text = "*.[A-Za-z]{3}>" .Forward = True .Wrap = wdFindContinue .Format = False .MatchWildcards = True .Execute End With Do While .Find.Found StrNm = .Text If Dir(StrNm) = "" Then j = j + 1: StrErr = StrErr & vbCr & StrNm Else i = i + 1 Set iShp = .InlineShapes.AddPicture(FileName:=StrNm, LinkToFile:=False, SaveWithDocument:=True) With iShp .LockAspectRatio = True .Height = InchesToPoints(1) If .Width > InchesToPoints(2) Then .Width = InchesToPoints(2) End With End If .Collapse wdCollapseEnd .Find.Execute Loop End With Application.ScreenUpdating = True MsgBox i & " images added." & vbCr & j & " image files not found:" & StrErr End Sub

问题似乎与从Selection.Text而不是.Find.Found.Text
中提取文件路径有关。
这主要使用Macropod下面建议的方法，虽然应用于Selection而不是Document.Range来维护＆＃34;用图像替换文本＆＃34;功能。出于某种原因，无论在我调用它的过程中的何处，Find.Execute的ReplaceWith参数和Find的替换属性都拒绝工作。

Answer 1

以下适用于我。

我正在使用*png来识别以.png结尾的字符串。

我正在使用

Right$(imagePath, Len(imagePath) - InStr(1,imagePath,":\") + 2)

提取保存文件路径的字符串，假设您的文件路径沿着C：\等等。您可以根据自己的目的发展此逻辑。

我删除了另一个循环，只允许.Execute继续，直到False。

Sub Test

    Selection.HomeKey Unit:=wdStory

    With Selection.Find
        .ClearFormatting
        .Text = "*png"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True

        Do While .Execute

                Dim imagePath As String
                imagePath = Selection.Range.Text
                imagePath = Right$(imagePath, Len(imagePath) - InStr(1,imagePath,":\") + 2)

                Dim SHP As InlineShape
                Set SHP = Selection.InlineShapes.AddPicture(FileName:=imagePath, LinkToFile:=False, SaveWithDocument:=True)
                    SHP.LockAspectRatio = True
                    SHP.Height = InchesToPoints(1)

                If SHP.Width > InchesToPoints(2) Then
                    SHP.Width = InchesToPoints(2)
                End If
        Loop

    End With

End Sub

参考：

https://superuser.com/questions/1009085/find-all-instances-of-a-text-and-make-it-a-hyperlink-with-a-macro

Answer 2

你不需要所有QQQ的迂回曲折。你也不需要：

imagePath =替换（imagePath，＆＃34; \＆＃34;，＆＃34; //＆＃34;）

但是如果缺少一个或多个图像文件，您应该在代码中添加错误检查。尝试：

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, StrNm As String, StrErr As String, iShp As InlineShape
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "C:\\Users\\*.[A-Za-z]{3}>"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    StrNm = .Text
    If Dir(StrNm) = "" Then
      j = j + 1: StrErr = StrErr & vbCr & StrNm
    Else
      i = i + 1
      Set iShp = .InlineShapes.AddPicture(FileName:=StrNm, LinkToFile:=False, SaveWithDocument:=True, Range:=.Duplicate)
      With iShp
        .LockAspectRatio = True
        .Height = InchesToPoints(1)
        If .Width > InchesToPoints(2) Then .Width = InchesToPoints(2)
      End With
    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
MsgBox i & " images added." & vbCr & j & " image files not found:" & StrErr
End Sub

Word VBA - 从文档

2 个答案: