1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29
| Sub RelinkGraphics()
On Error Resume Next
If ActiveDocument.Path = "" Then
MsgBox "Save your document in a folder of your choice, then try again.", , "Find graphics and copy them to folder where document is stored"
Exit Sub
End If
For Each myShape In ActiveDocument.InlineShapes
If myShape.LinkFormat.Type <> wdLinkTypePicture Then GoTo EndOfMyShape
'If myShape.LinkFormat.SourcePath = ActiveDocument.Path Then GoTo EndOfMyShape
MyFileWas = Dir(myShape.LinkFormat.SourceFullName)
myfileisnow = "..\Pictures\" & myShape.LinkFormat.SourceName
If myfileisnow <> "" Then
myShape.LinkFormat.SourceFullName = myfileisnow
myShape.LinkFormat.Update
ElseIf MyFileWas <> "" Then
FileCopy myShape.LinkFormat.SourceFullName, ActiveDocument.Path & Application.PathSeparator & myShape.LinkFormat.SourceName
myShape.LinkFormat.SourceFullName = ActiveDocument.Path & Application.PathSeparator & myShape.LinkFormat.SourceName
myShape.LinkFormat.Update
Else
MsgBox "Couldn't locate " & myShape.LinkFormat.SourceFullName
End If
EndOfMyShape:
ActiveDocument.UndoClear
Next myShape
End Sub |
Partager