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
复制代码 |