Question

我需要使用VBA修改三种类型文件（word，power point和excel）的一些超链接。我找到了足够的例子，所以我有一个几乎可以工作的脚本，除了处理pptx文件的子：

Sub pptxHyperLinkReplace(FileLoc As String) 'For power point
    Dim PPTapp As PowerPoint.Application
    Dim oSl As Slide
    Dim oHl As Hyperlink
    Dim sSearchFor As String
    Dim sReplaceWith As String
    Dim oSh As Shape
    sSearchFor = "http://europortal.ema.com/pws"
    If sSearchFor = "" Then Exit Sub End If
    sReplaceWith = "https://euro.sp.ema.com/BU/PWS/home"
    If sReplaceWith = "" Then Exit Sub End If
    On Error Resume Next
    Set PPTapp = CreateObject("PowerPoint.Application")
    Set PPT = PPTapp.Presentations.Open(FileName:=FileLoc, _
        ReadOnly:=msoFalse, WithWindow:=msoTrue)
    PPT.Activate
    For Each oSl In PPT.Slides
        MsgBox (oSl.Hyperlinks.Count)
        For Each oHl In oSl.Hyperlinks
            oHl.Address = Replace(oHl.Address, sSearchFor, sReplaceWith)
            oHl.SubAddress = Replace(oHl.SubAddress, sSearchFor, sReplaceWith)
        Next    ' hyperlink
        ' 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
    PPT.Save
    PPT.Close
    'Set PPT = Nothing
    PPTapp.Quit
    Set PPTapp = Nothing
End Sub

在此部分之前一切正常：For Each oHl In oSl.Hyperlinks 消息框MsgBox (oSl.Hyperlinks.Count)向我显示每张幻灯片的正确超链接数，但似乎oHl对象仍为空，例如 For Each 无法正常工作。我从word文件（docm）中的脚本运行此子。如果我直接在pptx文件中尝试原始脚本，我想修改超链接，它使用完全相同的语法。

那么我做错了什么？

Answer 1

我取得了一些进展。现在该脚本打开一个文件窗口以选择主文件夹，并打开该文件夹和所有子文件夹中的所有单词，power point，excel文档，替换部分超链接并检查新链接是否在此文档中正常工作，制作出一个excel表中包含来自所有文件的断开链接。

现在，当我在SharePoint文件夹上运行时，电源点演示文稿出现问题（＆＃34; 电源点无法打开文件 ＆＃34; - 这一行= If PPT Is Nothing Then Set PPT = PPTapp.Presentations.Open(fileName:=FileLoc, ReadOnly:=msoFalse, WithWindow:=msoFalse)）。所有其他文件类型在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

使用VBA修改来自不同类型文件（pptx; docx; xlsx）的超链接

1 个答案: