我已经取得了一些进展。现在脚本打开一个文件对话框窗口来选择主文件夹，并将打开该文件夹和所有子文件夹中的所有 word、power point、excel 文档，替换部分超链接并检查新链接是否在此文档中有效，制作一个 excel包含所有文件中断开的链接的表。
现在，当我在 SharePoint 文件夹上运行 power point 演示文稿时出现问题（“Power point 无法打开文件”-at this line= @ 987654321@）。所有其他文件类型都在 SharePoint 位置正确处理，如果我在本地文件夹上运行它，即使 PowerPoint 也可以毫无问题地打开。
那么我对 power point 文件做错了什么？
完整代码如下：
'Replace hyperlinks(in word/ppt/excel) in selected folder and all subfolders
Sub HyperReplace()
ThisWorkbook.Activate
Cells(1, 1).Select
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "\\euro.blablabla.com@SSL\DavWWWRoot\BU\PWS\home\ResourceManagement\Competences\Site Owners Documents\test\"
.AllowMultiSelect = False
If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub
folderpath = .SelectedItems(1)
If (Left$(folderpath, 5) = "https") Then
folderpath = Mid$(folderpath, 7, 32) & "@SSL/DavWWWRoot" & Mid$(folderpath, 39, Len(folderpath) - 32)
folderpath = Replace(folderpath, "/", "\")
End If
End With
Call GetFilesInFolder(CStr(folderpath), True)
MsgBox "operation end, please view", vbInformation
End Sub
Sub GetFilesInFolder(SourceFolderName As String, Subfolders As Boolean)
'--- For Example:Folder Name= "D:\Folder Name\" and Flag as Yes or No
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim fileName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'--- This is for displaying, whereever you want can be configured
For Each FileItem In SourceFolder.Files
fileName = FileItem.Path
If (Right$(fileName, 4) = "pptx" Or Right$(fileName, 3) = "ppt") Then
pptxHyperLinkReplace (fileName)
ElseIf (Right$(fileName, 4) = "docx" Or Right$(fileName, 3) = "doc") Then
ReplaceWordHyperlinks (fileName)
ElseIf (Right$(fileName, 4) = "xlsx" Or Right$(fileName, 4) = "xls") Then
ExcelHyperLinkChange (fileName)
'Else: MsgBox ("Noo ,îi bai!")
End If
Next FileItem
'--- This is the Function to go each and Every Folder and get the Files. This is a Nested-Function Calling.
If Subfolders = True Then
For Each SubFolder In SourceFolder.Subfolders
Call GetFilesInFolder(SubFolder.Path, True)
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
`
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub MakeExcelBrokenLinksList(Filelocation As String, HLink As String, Optional ByVal NoBrokenLinks As Integer, Optional ByVal NoGoodLinks As Integer, Optional ByVal WLinks As Boolean = False)
ThisWorkbook.Activate
Cells(ActiveCell.Row + 1, 1).Select
ActiveCell.Value = Filelocation
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = HLink
If WLinks = True Then
ActiveCell.EntireRow.Interior.ColorIndex = 8
Cells(ActiveCell.Row, 3).Select
ActiveCell.Value = NoGoodLinks
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = NoBrokenLinks
Cells(ActiveCell.Row + 1, 1).Select
End If
End Sub
'For word
Sub ReplaceWordHyperlinks(FileLoc As String)
Dim WordApp As Word.Application
Dim Doc As Word.Document
Dim HL As Word.Hyperlink
Dim target As String
Dim repl As String
Dim DocBrokenLinks As Integer
' target = InputBox("Find address", "Replace Hyperlink")
target = "http://europortal.blabalabla.com/pws"
If Len(target) = 0 Then Exit Sub
' repl = InputBox("Replace address", "Replace Hyperlink")
repl = "https://euro.sp.ema.blabalabla.com/BU/PWS/home"
If Len(repl) = 0 Then Exit Sub
DocBrokenLinks = 0
If WordApp Is Nothing Then Set WordApp = New Word.Application
If Doc Is Nothing Then Set Doc = Documents.Open(fileName:=FileLoc, Visible:=False)
Doc.Activate
For Each HL In Doc.Hyperlinks
If (Len(HL.Address) > 248) Then
Call MakeExcelBrokenLinksList(FileLoc, HL.Address)
HL.Address = Left(HL.Address, 248)
End If 'make sure that replaced link not exceeding max size of string
With HL
If InStr(LCase(.Address), LCase(target)) _
Or InStr(LCase(.TextToDisplay), LCase(target)) Then
.Address = Replace(.Address, target, repl)
.TextToDisplay = Replace(.TextToDisplay, target, repl)
.ScreenTip = Replace(.ScreenTip, target, repl)
.Range.Fields.Update
End If
End With
'Test if hyperlink is working
If IsURLGood(HL.Address) = False Then
Call MakeExcelBrokenLinksList(FileLoc, HL.Address)
DocBrokenLinks = DocBrokenLinks + 1
End If
Sleep (250)
'Application.Wait (Now + TimeValue("0:00:01")) 'only on excel
Next 'hyperlink
Call MakeExcelBrokenLinksList(Doc.Name, "TOTAL Hyperlinks: ", DocBrokenLinks, Doc.Hyperlinks.Count - DocBrokenLinks, True)
Doc.Save
'ActiveWindow.Close
Doc.Close
Set Doc = Nothing
WordApp.Quit
Set WordApp = Nothing
End Sub
'For power point
Sub pptxHyperLinkReplace(FileLoc As String)
Dim PPTapp As PowerPoint.Application
Dim PPT As PowerPoint.Presentation
Dim oSl As PowerPoint.Slide
Dim oHl As PowerPoint.Hyperlink
Dim oSh As PowerPoint.Shape
Dim sSearchFor As String
Dim sReplaceWith As String
Dim PptBrokenLinks As Integer
Dim PptLinks As Integer
sSearchFor = "http://europortal.ema.blababal.com/pws"
If sSearchFor = "" Then
Exit Sub
End If
sReplaceWith = "https://euro.sp.ema.blababal.com/BU/PWS/home"
If sReplaceWith = "" Then
Exit Sub
End If
PptBrokenLinks = 0
If PPTapp Is Nothing Then Set PPTapp = New PowerPoint.Application
If PPT Is Nothing Then Set PPT = PPTapp.Presentations.Open(fileName:=FileLoc, ReadOnly:=msoFalse, WithWindow:=msoFalse)
For Each oSl In PPT.Slides
For Each oHl In oSl.Hyperlinks
If (Len(oHl.Address) > 248) Then
Call MakeExcelBrokenLinksList(FileLoc, oHl.Address)
oHl.Address = Left(oHl.Address, 248)
End If 'replaced link not exceeding max size of string
oHl.Address = Replace(oHl.Address, sSearchFor, sReplaceWith)
oHl.SubAddress = Replace(oHl.SubAddress, sSearchFor, sReplaceWith)
'Test if hyperlink is working
If IsURLGood(oHl.Address) = False Then
Call MakeExcelBrokenLinksList(FileLoc, HL.Address)
PptBrokenLinks = PptBrokenLinks + 1
End If
Sleep (250)
Next ' hyperlink
PptLinks = PptLinks + oSl.Hyperlinks.Count
' fix OLE links and movie/sound linkes too
' For Each oSh In oSl.Shapes
' If oSh.Type = msoLinkedOLEObject _
' Or oSh.Type = msoMedia Then
' oSh.LinkFormat.SourceFullName = Replace(oSh.LinkFormat.SourceFullName, sSearchFor, sReplaceWith)
' End If
' Next 'shape
Next ' slide
Call MakeExcelBrokenLinksList(PPT.Name, "TOTAL Hyperlinks: ", PptBrokenLinks, PptLinks - PptBrokenLinks, True)
PPT.Save
PPT.Close
Set PPT = Nothing
PPTapp.Quit
Set PPTapp = Nothing
End Sub
'For excel
Sub ExcelHyperLinkChange(FileLoc As String)
Dim XlSXapp As Excel.Application
Dim xlsxBook As Excel.Workbook
Dim xlsxSheet As Excel.Worksheet
Dim oHl As Excel.Hyperlink
Dim sSearchFor As String
Dim sReplaceWith As String
Dim ExcelBrokenLinks As Integer
Dim ExcelLinks As Integer
sSearchFor = "http://europortal.ema.blababal.com/pws"
If sSearchFor = "" Then
Exit Sub
End If
sReplaceWith = "https://euro.sp.ema.blababal.com/BU/PWS/home"
If sReplaceWith = "" Then
Exit Sub
End If
ExcelBrokenLinks = 0
If XlSXapp Is Nothing Then Set XlSXapp = New Excel.Application
If xlsxBook Is Nothing Then Set xlsxBook = XlSXapp.Workbooks.Open(fileName:=FileLoc, ReadOnly:=msoFalse)
For Each xlsxSheet In xlsxBook.Worksheets
For Each oHl In xlsxSheet.Hyperlinks
If (Len(oHl.Address) > 248) Then
Call MakeExcelBrokenLinksList(FileLoc, oHl.Address)
oHl.Address = Left(oHl.Address, 248)
End If 'replaced link not exceeding max size of string
oHl.Address = Replace(oHl.Address, sSearchFor, sReplaceWith)
oHl.TextToDisplay = Replace(oHl.TextToDisplay, sSearchFor, sReplaceWith)
'Test if hyperlink is working
If IsURLGood(oHl.Address) = False Then
Call MakeExcelBrokenLinksList(FileLoc, oHl.Address)
ExcelBrokenLinks = ExcelBrokenLinks + 1
End If 'link is working
Sleep (250)
Next ' hyperlink
ExcelLinks = ExcelLinks + xlsxSheet.Hyperlinks.Count
Next xlsxSheet ' sheet
Call MakeExcelBrokenLinksList(xlsxBook.Name, "TOTAL Hyperlinks: ", ExcelBrokenLinks, ExcelLinks - ExcelBrokenLinks, True)
xlsxBook.Save
xlsxBook.Close
Set xlsxBook = Nothing
XlSXapp.Quit
Set XlSXapp = Nothing
End Sub
Private Function IsURLGood(url As String) As Boolean
' Test the URL to see if it is good
Dim request As New WinHttpRequest
On Error GoTo IsURLGoodError
If ((Len(url) > 1) And (Left(url, 4) <> "mail")) Then
request.Open "GET", url
request.Send
If (request.Status = 200 Or request.Status = 401) Then
IsURLGood = True
Else
IsURLGood = False
End If
Else: IsURLGood = True
End If ' link is not empty
Exit Function
IsURLGoodError:
IsURLGood = False
End Function