Results 1 to 2 of 2
  1. #1
    New Lounger
    Join Date
    Sep 2015
    Posts
    10
    Thanks
    1
    Thanked 0 Times in 0 Posts

    Word macro - check text of hyperlink matches URL, based on approved list

    I'd like to write a macro that searches for hyperlinks and checks that a stated text matches a stated a URL. To explain further: I work with different documents every day, but there are some common hyperlinks in many of them. For example, many documents refer to "Materials and equipment lists", which always links to the same URL. Rather than having to click each and every one of these 'standard' URLs, I'd like a macro that highlights the ones that are correct (or not correct).

    I'm thinking, something like a list in Excel, where column A is the text to display and column B is the address, would be perfect. I have a macro that does a find/replace/highlight of normal words and phrases, using lists based in Excel. Initially, I thought I could perhaps tweak that, but I can't see how to search URL addresses in Word.

  2. #2
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Try the following macro. It checks all hyperlinks in the document against column A of your workbook and, if the hyperlinks have sub-addresses, it checks those against column B of your workbbok (the address and its sub-address must be on the same row). Any hyperlinks in the document that aren't matched against what you have in the workbook get highlighted. The workbook to use is defined on the 'StrWkBkNm =' line - as coded it looks for a 'Hyperlinks.xls' workbook in your Documents folder. Similarly, the worksheet in that workbook to use is defined on the 'StrWkSht =' line.
    Code:
    Sub BulkFindReplace()
    Application.ScreenUpdating = True
    Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
    Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean, HLnk As Hyperlink
    Dim xlPriAddList, xlSubAddList, i As Long, j As Long, bSubAdd As Boolean
    StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\Hyperlinks.xls"
    StrWkSht = "Sheet1"
    If Dir(StrWkBkNm) = "" Then
      MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
      Exit Sub
    End If
    ' Test whether Excel is already running.
    On Error Resume Next
    bStrt = False ' Flag to record if we start Excel, so we can close it later.
    Set xlApp = GetObject(, "Excel.Application")
    'Start Excel if it isn't running
    If xlApp Is Nothing Then
      Set xlApp = CreateObject("Excel.Application")
      If xlApp Is Nothing Then
        MsgBox "Can't start Excel.", vbExclamation
        Exit Sub
      End If
      ' Record that we've started Excel.
      bStrt = True
    End If
    On Error GoTo 0
    'Check if the workbook is open.
    bFound = False
    With xlApp
      'Hide our Excel session
      If bStrt = True Then .Visible = False
      For Each xlWkBk In .Workbooks
        If xlWkBk.FullName = StrWkBkNm Then ' It's open
          Set xlWkBk = xlWkBk
          bFound = True
          Exit For
        End If
      Next
      ' If not open by the current user.
      If bFound = False Then
        ' Check if another user has it open.
        If IsFileLocked(StrWkBkNm) = True Then
          ' Report and exit if true
          MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
          If bStrt = True Then .Quit
          Exit Sub
        End If
        ' The file is available, so open it.
        Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm)
        If xlWkBk Is Nothing Then
          MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
          If bStrt = True Then .Quit
          Exit Sub
        End If
      End If
      ' Process the workbook.
      With xlWkBk.Worksheets(StrWkSht)
        ' Find the last-used row in column A.
        ' Add 1 to get the next row for data-entry.
        iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
        ' Output the captured data.
        For i = 1 To iDataRow
          ' Skip over empty fields to preserve the underlying cell contents.
          If Trim(.Range("A" & i)) <> vbNullString Then
            xlPriAddList = xlPriAddList & "|" & Trim(.Range("A" & i))
            xlSubAddList = xlSubAddList & "|" & Trim(.Range("B" & i))
          End If
        Next
        xlPriAddList = xlPriAddList & "|": xlSubAddList = xlSubAddList & "|"
      End With
      If bFound = False Then xlWkBk.Close False
      If bStrt = True Then .Quit
    End With
    ' Release Excel object memory
    Set xlWkBk = Nothing: Set xlApp = Nothing
    With ActiveDocument
      'Check all Hyperlinks
      For Each HLnk In .Hyperlinks
        With HLnk
          'Does this one's address appear in our lookup list
          If InStr(xlPriAddList, .Address) > 0 Then
            'Does it have a sub-address?
            If .SubAddress <> "" Then
              bSubAdd = False
              'Check whether the corresponding sub-address appears in our lookup list
              For i = 1 To UBound(Split(xlPriAddList, "|"))
                If Split(xlPriAddList, "|")(i) = .Address Then
                  If Split(xlSubAddList, "|")(i) = .SubAddress Then bSubAdd = True
                End If
              Next
              'If the sub-address doesn't match any address in our lookup list, higlight the hyperlink
              If bSubAdd = False Then .Range.HighlightColorIndex = wdRed
            End If
          Else
            'If the address isn't in our lookup list, higlight the hyperlink
            .Range.HighlightColorIndex = wdRed
          End If
        End With
      Next
    End With
    Next
    Application.ScreenUpdating = True
    End Sub
    
    Function IsFileLocked(strFileName As String) As Boolean
      On Error Resume Next
      Open strFileName For Binary Access Read Write Lock Read Write As #1
      Close #1
      IsFileLocked = Err.Number
      Err.Clear
    End Function
    Cheers,

    Paul Edstein
    [MS MVP - Word]

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •