我在MS Word中有一个宏，它将页眉和页脚以及任何符合主文档要求的文本替换为目录中的所有其他文档。 这非常有效。
我还让宏工作在文档中选择InlineShape并将其替换为主文档中的内联形状。 我遇到的问题是尝试使用Shape（文本背后的图像集）进行此操作。
选择和替换功能似乎不起作用，当我让它们工作时，图像不会被替换在文档中的相同位置。
任何帮助都会受到赞赏，因为我疯狂地试图让它发挥作用!!
由于
Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String
Dim wdDocSrc As Document, wdDocTgt As Document, HdFt As HeaderFooter
Dim aStory As Range
Dim aField As Field
Dim oldFilename As String
Dim bmRange As Range
Dim Response As Integer
Dim i As Long
Dim imgLogo As InlineShapes
Set wdDocSrc = ActiveDocument
strDocNm = wdDocSrc.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
'Check the user has selected the correct directory to rebrand - if no Exit sub
Response = MsgBox(prompt:="Are you sure you want to apply template changes to: " & strFolder & "!", Buttons:=vbYesNo, Title:="Tom's Rebranding Tool")
If Response = vbNo Then Exit Sub
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDocTgt
'Replace text as per table in template
Dim oRow As Row
Dim oCell As Cell
a = 2
b = 1
x = 2
y = 2
For Each oRow In ActiveDocument.Tables(1).Rows
Replace1 = ActiveDocument.Tables(1).Cell(a, b)
Insert1 = ActiveDocument.Tables(1).Cell(x, y)
scellTExt = Replace1
dcellTExt = Insert1
scellTExt = Left$(Replace1, Len(Replace1) - 2)
dcellTExt = Left$(Insert1, Len(Insert1) - 2)
With .Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = scellTExt
.Replacement.Text = dcellTExt
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
'add 1 to the row number when looping through table
a = a + 1
x = x + 1
End With
Next oRow
'Set the header in the wdDocTgt the same as in wdDocSrc
For Each HdFt In .Sections.First.Headers
If HdFt.Exists Then
If wdDocSrc.Sections.First.Headers(HdFt.Index).Exists Then
HdFt.Range.FormattedText = wdDocSrc.Sections.First.Headers(HdFt.Index).Range.FormattedText
End If
End If
Next
'Set the footer in the wdDocTgt the same as in wdDocSrc
For Each HdFt In .Sections.First.Footers
If HdFt.Exists Then
If wdDocSrc.Sections.First.Footers(HdFt.Index).Exists Then
HdFt.Range.FormattedText = wdDocSrc.Sections.First.Footers(HdFt.Index).Range.FormattedText
'FILE NAME CODE
'Check if the DocName bookmark exists
If wdDocTgt.Bookmarks.Exists("DocName") = True Then
'If DocName bookmark does exist do this
Set bmRange = wdDocTgt.Bookmarks("DocName").Range
'NEW gets the name of the target document and removed the .doc extension
oldFilename = wdDocTgt.name
If Right(oldFilename, 5) = ".docx" Then
oldFilename = Left(oldFilename, Len(oldFilename) - 5)
ElseIf Right(oldFilename, 4) = ".doc" Then
oldFilename = Left(oldFilename, Len(oldFilename) - 4)
'Update bmRange (DocName bookmark) with the file name with no extension
bmRange.Text = oldFilename
End If
End If
If wdDocTgt.Bookmarks.Exists("DocName2") = True Then
'If DocName bookmark does exist do this
Set bmRange = wdDocTgt.Bookmarks("DocName2").Range
'set bmRange as blank so as to no duplicate the name
bmRange.Text = " "
'NEW gets the name of the target document and removed the .doc extension
oldFilename = ""
oldFilename = wdDocTgt.name
If Right(oldFilename, 5) = ".docx" Then
oldFilename = Left(oldFilename, Len(oldFilename) - 5)
ElseIf Right(oldFilename, 4) = ".doc" Then
oldFilename = Left(oldFilename, Len(oldFilename) - 4)
'Update bmRange (DocName bookmark) with the file name with no extension
bmRange.Text = oldFilename
End If
End If
'END FILE NAME CODE
End If
End If
Next
'IMAGE CHANGE
'Select and copy the InlineShape in the template
wdDocSrc.InlineShapes(1).Select
With Selection
.Copy
End With
'Select the inlineshape in the letter, delete it and paste (already copied the
'image in the code above) then loop for every inline image in the document.
For i = wdDocTgt.InlineShapes.Count To 1 Step -1
wdDocTgt.InlineShapes(i).Select
With Selection
.Delete
.PasteSpecial
End With
Next i
'Select and copy the SHAPES in the template
wdDocSrc.Shapes(1).Select
With Selection
.Copy
End With
'Select the SHAPE in the letter, delete it and paste (already copied the
'image in the code above) then loop for every inline image in the document.
'Save changes to the wdDocTgt and close it
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Wend
MsgBox "Macro Complete"
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub