嘻皮客娱乐学习网
标题:
应用宏批量更改PPT中外部链接的路径
[打印本页]
作者:
xipick
时间:
2020-7-31 17:29
标题:
应用宏批量更改PPT中外部链接的路径
office2010 ppt中引用excel中的图表,拷贝到别的电脑后,链接地址改变,需要逐个更改源文件,可以在PPT中应用宏来实现。
可以更改插入的OLE对象,图表(Charts)的路径。
Sub ChangeOLELinks()
' Note: this will only work in PPT 2000 and later
Dim oSld As Slide
Dim oSh As Shape
Dim sOldPath As String
Dim TpOldPath As String 'Temp Old Path, used to get file name without path
Dim sNewPath As String
Dim i As Integer, j As Integer
'Get the old path of OLE objects
For Each oSh In ActivePresentation.Slides(1).Shapes
If oSh.Type = msoLinkedOLEObject Or oSh.Type = msoChart Then
TpOldPath = oSh.LinkFormat.SourceFullName
If TpOldPath <> "" Then Exit For
End If
Next
If TpOldPath = "" Then
MsgBox ("Cannot find Linked OLE Object or Chart Object. Procedure terminated.")
Exit Sub
End If
'Remove the FileName in the Path if the file is stored in LOCAL and uses back slash ""
For i = 1 To Len(TpOldPath)
If InStr(i, TpOldPath, "") > 0 Then
i = InStr(i, TpOldPath, "")
j = i
End If
Next i
If j > 0 Then
TpOldPath = Left(TpOldPath, j - 1)
Else
'Remove the FileName in the Path if the file is stored in SERVER and uses forward slash "/"
For i = 1 To Len(TpOldPath)
If InStr(i, TpOldPath, "/") > 0 Then
i = InStr(i, TpOldPath, "/")
j = i
End If
Next i
TpOldPath = Left(TpOldPath, j - 1)
End If
sOldPath = InputBox(prompt:="Please enter the OLD OLE Link Path", Default:=TpOldPath)
sNewPath = InputBox("Please enter the NEW OLE Link Path", Default:=ActivePresentation.Path)
On Error GoTo ErrorHandler
For Each oSld In ActivePresentation.Slides
For Each oSh In oSld.Shapes
' Change only linked OLE objects
If oSh.Type = msoLinkedOLEObject Or oSh.Type = msoChart Then
On Error Resume Next
' Verify that file exists
If Len(Dir$(Replace(oSh.LinkFormat.SourceFullName, sOldPath, sNewPath))) > 0 Then
oSh.LinkFormat.SourceFullName = Replace(oSh.LinkFormat.SourceFullName, sOldPath, sNewPath)
Else
MsgBox ("File is missing; cannot relink to a file that isn't present")
End If
On Error GoTo ErrorHandler
End If
Next ' shape
Next ' slide
MsgBox ("Done!")
NormalExit:
Exit Sub
ErrorHandler:
MsgBox ("Error " & Err.Number & vbCrLf & Err.Description)
Resume NormalExit
End Sub
复制代码
欢迎光临 嘻皮客娱乐学习网 (http://www.xipick.com/)
Powered by Discuz! X3.3