应用宏批量更改PPT中外部链接的路径

office2010 ppt中引用excel中的图表，拷贝到别的电脑后，链接地址改变，需要逐个更改源文件,可以在PPT中应用宏来实现。
可以更改插入的OLE对象，图表(Charts)的路径。

1. Sub ChangeOLELinks()
   
2. 
   
3. ' Note: this will only work in PPT 2000 and later
   
4. 
   
5.     Dim oSld As Slide
   
6.     Dim oSh As Shape
   
7.     Dim sOldPath As String
   
8.     Dim TpOldPath As String    'Temp Old Path, used to get file name without path
   
9.     Dim sNewPath As String
   
10.     Dim i As Integer, j As Integer
    
11.      
    
12.     'Get the old path of OLE objects
    
13.     For Each oSh In ActivePresentation.Slides(1).Shapes
    
14.         If oSh.Type = msoLinkedOLEObject Or oSh.Type = msoChart Then
    
15.             TpOldPath = oSh.LinkFormat.SourceFullName
    
16.             If TpOldPath <> "" Then Exit For
    
17.         End If
    
18.     Next
    
19. 
    
20. If TpOldPath = "" Then
    
21.         MsgBox ("Cannot find Linked OLE Object or Chart Object. Procedure terminated.")
    
22.         Exit Sub
    
23.     End If
    
24. 
    
25.     'Remove the FileName in the Path if the file is stored in LOCAL and uses back slash ""
    
26.     For i = 1 To Len(TpOldPath)
    
27.         If InStr(i, TpOldPath, "") > 0 Then
    
28.             i = InStr(i, TpOldPath, "")
    
29.             j = i
    
30.         End If
    
31.     Next i
    
32.      
    
33.     If j > 0 Then
    
34.         TpOldPath = Left(TpOldPath, j - 1)
    
35.     Else
    
36.     'Remove the FileName in the Path if the file is stored in SERVER and uses forward slash "/"
    
37.         For i = 1 To Len(TpOldPath)
    
38.             If InStr(i, TpOldPath, "/") > 0 Then
    
39.                 i = InStr(i, TpOldPath, "/")
    
40.                 j = i
    
41.             End If
    
42.         Next i
    
43.         TpOldPath = Left(TpOldPath, j - 1)
    
44.     End If
    
45.    
    
46.     sOldPath = InputBox(prompt:="Please enter the OLD OLE Link Path", Default:=TpOldPath)
    
47.     sNewPath = InputBox("Please enter the NEW OLE Link Path", Default:=ActivePresentation.Path)
    
48. 
    
49.     On Error GoTo ErrorHandler
    
50. 
    
51.     For Each oSld In ActivePresentation.Slides
    
52.         For Each oSh In oSld.Shapes
    
53.             ' Change only linked OLE objects
    
54.             If oSh.Type = msoLinkedOLEObject Or oSh.Type = msoChart Then
    
55.                 On Error Resume Next
    
56.                 ' Verify that file exists
    
57.                 If Len(Dir$(Replace(oSh.LinkFormat.SourceFullName, sOldPath, sNewPath))) > 0 Then
    
58.                      oSh.LinkFormat.SourceFullName = Replace(oSh.LinkFormat.SourceFullName, sOldPath, sNewPath)
    
59.                      
    
60.                 Else
    
61.                       MsgBox ("File is missing; cannot relink to a file that isn't present")
    
62.                 End If
    
63.                 On Error GoTo ErrorHandler
    
64.              End If
    
65.         Next    ' shape
    
66.     Next    ' slide
    
67.      
    
68. MsgBox ("Done!")
    
69. 
    
70. NormalExit:
    
71.     Exit Sub
    
72. ErrorHandler:
    
73.     MsgBox ("Error " & Err.Number & vbCrLf & Err.Description)
    
74.     Resume NormalExit
    
75. 
    
76. End Sub

复制代码