Question

我有许多超链接的工作簿。最近工作簿已移到另一个位置（一个文件夹“更深”）。因此，所有超链接都搞砸了，现在是：

file:///\\company\common\shared\VRS\Program Files\documents\example.doc

代替

file:///\\company\common\shared\VRS\documents\example.doc

我正在尝试编写宏以从所有超链接中删除\ Program Files \部分。在here中找到了一些示例； here; here (stackoverflow)和here (another stackoverflow)。

问题是所有解决方案都不起作用（什么都没有改变），而且我不知道我在做什么错。

我尝试过的代码：

Sub EditHyperlinks()
    Dim lnkH As Hyperlink
    Dim sOld As String
    Dim sNew As String

    sOld = "file:///\\company\common\shared\VRS\Program Files\documents\"
    sNew = "file:///\\company\common\shared\VRS\documents\"

    For Each lnkH In ActiveSheet.Hyperlinks
        lnkH.Address = Replace(lnkH.Address, sOld, sNew)
        lnkH.TextToDisplay = Replace(lnkH.TextToDisplay, sOld, sNew)
    Next
End Sub

Sub FixHyperlinks2()
    Dim wks As Worksheet
    Dim hl As Hyperlink
    Dim sOld As String
    Dim sNew As String

    Set wks = ActiveSheet
    sOld = "file:///\\company\common\shared\VRS\Program Files\documents\"
    sNew = "file:///\\company\common\shared\VRS\documents\"
    For Each hl In wks.Hyperlinks
        hl.Address = Replace(hl.Address, sOld, sNew)
    Next hl
End Sub

 Sub FindReplaceHLinks(sFind As String, sReplace As String, _
        Optional lStart As Long = 1, Optional lCount As Long = -1)

        Dim rCell As Range
        Dim hl As Hyperlink

        For Each rCell In ActiveSheet.UsedRange.Cells
            If rCell.Hyperlinks.Count > 0 Then
                For Each hl In rCell.Hyperlinks
                    hl.Address = Replace(hl.Address, sFind, sReplace, lStart, lCount, vbTextCompare)
                Next hl
            End If
        Next rCell
    End Sub

    Sub Doit()

        FindReplaceHLinks "file:///\\company\common\shared\VRS\Program Files\documents\", "file:///\\company\common\shared\VRS\documents\"    
    End Sub

 Sub test()
        Dim hLink As Hyperlink
        Dim wSheet As Worksheet

        For Each wSheet In Worksheets
           For Each hLink In wSheet.Hyperlinks
                hLink.Address = Replace(hLink.Address, "file:///\\company\common\shared\VRS\Program Files\documents\", "file:///\\company\common\shared\VRS\documents\")
            Next hLink
        Next
    End Sub

请注意，我试图写出地址（可能）是所有可能的变体：开头file：/// \; \并且没有任何\

有人可以指出我正确的方向吗？

P.S。也许我应该提到文件在本地网络目录中。

Answer 1

像这样的事情应该起作用，您想要在\上分割文本，寻找文本条目，然后备份字符串。

Function FixFileNames(FileName As String) As String
    Dim i As Long
    Dim testarr As Variant
    Dim fixedString As String

    testarr = Split(FileName, "\", , vbBinaryCompare)

    For i = LBound(testarr) To UBound(testarr)
        If Not testarr(i) = "Program Files" Then fixedString = fixedString & "\" & testarr(i)
    Next

    FixFileNames = Right$(fixedString, Len(fixedString) - 1)
End Function

Sub Tester()
    Debug.Print FixFileNames("file:///\\company\common\shared\VRS\Program Files\documents\example.doc")
End Sub

Replace（x，y，z）在超链接上不起作用

1 个答案: