Word VBA select Shape(1) and InlineShape(1) HELP

Hi all,

I have a macro in MS Word that replaces the header and footer and any text that matches requirements from a master document into all other documents in a a directory.
This works perfectly.

I have also got the macro working to select the InlineShape in the documents and replace it with an inline shape from the master document.
The problem I'm having is trying to do this with a Shape (image set behind text).

The select and replace functions dont seem to work and when I have got them working the image isnt replaced in the same place in the document.

Any help would be appreciated as I'm going crazy trying to get this to work!!

Thanks



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

Hi, Thanks for your help.
The code you have given i now replacing the shapes image however it also adds another copy of the image where the InLineShapes version of it is as well! I need to differentiate between the both shapes as they are in different places and formatted differently in some documents.

Hi,

There is a mix of images in my documents of types:
Behind Text
Infront of Text
Inline

I need a way to select each type individually. - My Inline works (code below) but I can not get it to work with any other types of image.

Please Login or Register  to view this content.