Results 1 to 2 of 2
2015-09-22, 21:31 #1
- Join Date
- Sep 2015
- 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.
2015-09-23, 02:23 #2
- Join Date
- May 2002
- Canberra, Australian Capital Territory, Australia
- Thanked 439 Times in 362 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.
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 FunctionCheers,
[MS MVP - Word]