Hi gladiator,
I may have a solution for your problem in the attached file, which uses Internet Explorer Automation to check the validity of your hyperlinks. The code was tested on a Vista 32 bit system, Using Excel 2003, and Internet Explorer 8, with Verizon Fios Internet (Northern NJ). On my system it took one to two seconds to test each URL.
There are 4 types of Hyperlinks in Excel that I know of:
a. URLs
b. mailto
c. Link to an external file
d. Link to a cell inside the Excel sheet
The code only checks URLs, but identifies the other types of hyperlinks.
The following items in the VBA code can be modified to customize the file to a specific spreadsheet without having any programming skills:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'The following 6 lines can be changed to Specific Worksheet Requirements
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const sSourceWorksheetNAME = "Sheet1"
Public Const sHyperlinkDataCOLUMN = "D"
Public Const nStartRowDATUM = 6 'One row BEFORE The start row
Public Const sDomainNameNotFoundDisplayCELL = "D25"
Public Const sUrlNotFoundDisplayCELL = "D26"
Public Const sUrlIsAFileDisplayCELL = "D27"
The following items in the VBA code can be modifed if the error messages for SPECIFIC SITUATIONS returned by your Internet Provider differ from the messages I received. There are command buttons in the Worksheet to test for each of the three error situations.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'The following 3 lines can be changed to be consistent with Error Messages
'returned by your Internet Service Provider and Your Specific Browser
'Original messages were derived from: Vista 32 Bit, Internet Explorer 8, Verizon ISP (Northern New Jersey)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const sBadDOmainNameSUBSTRING = "search.dnsassist.verizon.net"
Public Const sUrlNotFoundSUBSTRING = "http_404"
Public Const sUrlIsAFileSUBSTRING = "ieframe.dll/dnserror.htm"
Lewis
Complete code follows (64 bit CONDITIONAL COMPILATION not tested):
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'The following 6 lines can be changed to Specific Worksheet Requirements
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const sSourceWorksheetNAME = "Sheet1"
Public Const sHyperlinkDataCOLUMN = "D"
Public Const nStartRowDATUM = 6
Public Const sDomainNameNotFoundDisplayCELL = "D25"
Public Const sUrlNotFoundDisplayCELL = "D26"
Public Const sUrlIsAFileDisplayCELL = "D27"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'The following 3 lines can be changed to be consistent with Error Messages
'returned by your Internet Service Provider and Your Specific Browser
'Original messages were derived from: Vista 32 Bit, Internet Explorer 8, Verizon ISP (Northern New Jersey)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const sBadDOmainNameSUBSTRING = "search.dnsassist.verizon.net"
Public Const sUrlNotFoundSUBSTRING = "http_404"
Public Const sUrlIsAFileSUBSTRING = "ieframe.dll/dnserror.htm"
#If VBA7 And Win64 Then
' 64 bit Excel
'NOTE: The following line is supposed to be RED in 32 bit Excel
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongLong)
#Else
' 32 bit Excel
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
#If VBA7 And Win64 Then
' 64 bit Excel
'NOTE: The following line is supposed to be RED in 32 bit Excel
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
#Else
' 32 bit Excel
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
#End If
Private Const SW_MAXIMIZE = 3
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Sub ClearColorsOHyperlinkCells()
'This clears color from all 'contiguous cell with hyperlinks' in a specific column
Dim ws As Worksheet
Dim iRow As Long
Dim bNeedMore As Boolean
Dim sValue As String
'Create the Worksheet object
Set ws = Sheets(sSourceWorksheetNAME)
iRow = nStartRowDATUM 'one row before the start row
bNeedMore = True
While bNeedMore
'Increment the input row number
iRow = iRow + 1
'Get the value in the cell
sValue = Trim(ws.Cells(iRow, sHyperlinkDataCOLUMN).Text)
If Len(sValue) = 0 Then
'Exit if there is no data in the cell
bNeedMore = False
Else
'Clear color from the cell
ws.Cells(iRow, sHyperlinkDataCOLUMN).Interior.ColorIndex = xlNone
End If
Wend
'Clear the worksheet objet
Set ws = Nothing
End Sub
Sub CheckHyperlinkValidity()
'This checks the validity of Hyperlinks located in a specific column
Dim ie As Object
Dim ws As Worksheet
Dim iRow As Long
Dim myRGB_Cyan As Long
Dim myRGB_Green As Long
Dim myRGB_Magenta As Long
Dim myRGB_Red As Long
Dim myRGB_Yellow As Long
Dim bNeedMore As Boolean
Dim sDocumentUrl As String
Dim sUrl As String
Dim sUrlActive As String
Dim sUrlStatusBarText As String
Dim sUrlLocationName As String
Dim sValue As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Initialization
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
myRGB_Cyan = RGB(0, 255, 255) 'No Hyperlink
myRGB_Green = RGB(0, 255, 0) 'Valid URL Hyperlink
myRGB_Magenta = RGB(255, 0, 255) 'Valid Domain Name - URL cannot be found
myRGB_Red = RGB(255, 0, 0) 'Bad Domain Name
myRGB_Yellow = RGB(255, 255, 0) 'Hyperlink, but NOT URL
'Verify that the Source Data Sheet Exists
If LjmSheetExists(sSourceWorksheetNAME) = False Then
MsgBox "TERMINATING. Source Worksheet DOES NOT EXIST." & vbCrLf & _
"Sheet Name: '" & sSourceWorksheetNAME & "'"
Exit Sub
End If
'Clear the colors (if any) from the Hyperlink Cells
Call ClearColorsOHyperlinkCells
'Create the Worksheet object
Set ws = Sheets(sSourceWorksheetNAME)
'Enable the 'ESC' Key Error Handler
'This also means any RUNTIME ERROR will jump to the Error Handler
On Error GoTo ERROR_HANDLER
Application.EnableCancelKey = xlErrorHandler
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create the Internet Explorer Object
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ShowWindow ie.hwnd, SW_SHOWMINIMIZED
On Error GoTo ERROR_HANDLER
Debug.Print "Starting at " & Now()
iRow = nStartRowDATUM 'one row before the start row
bNeedMore = True
While bNeedMore
'Increment the input row number
iRow = iRow + 1
'Get the value in the cell
sValue = Trim(ws.Cells(iRow, sHyperlinkDataCOLUMN).Text)
If Len(sValue) = 0 Then
'Exit if there is no data in the cell
bNeedMore = False
ElseIf ws.Cells(iRow, sHyperlinkDataCOLUMN).Hyperlinks.Count > 0 Then
sUrl = Cells(iRow, sHyperlinkDataCOLUMN).Hyperlinks(1).Address
'Debug.Print Format(iRow, "00000 ") & "Address=" & sUrl
'Debug.Print Format(iRow, "00000 ") & "Sub_adr=" & Cells(iRow, sHyperlinkDataCOLUMN).Hyperlinks(1).SubAddress
If InStr(sUrl, "mailto") > 0 Then
Debug.Print Format(iRow, "00000 ") & " No URL Hyperlink - E-Mail Hyperlink"
ws.Cells(iRow, sHyperlinkDataCOLUMN).Interior.Color = myRGB_Yellow
ElseIf Len(sUrl) > 0 Then
'Navigate to the URL
ie.Navigate sUrl
'Wait until Internet Explorer is not busy and ready
Do While ie.Busy Or ie.readyState <> 4
Sleep 200
Loop
'After not busy and ready, wait until status is 'Done'
If ie.StatusText <> "Done" Then
Sleep 200
End If
sUrlActive = ie.LocationURL
sUrlStatusBarText = ie.StatusText
sUrlLocationName = ie.LocationName
sDocumentUrl = ie.Document.URL
'Debug.Print "''''''''''''''''''''''"
'Debug.Print sUrlActive
'Debug.Print sUrlStatusBarText
'Debug.Print sUrlLocationName
'Debug.Print sDocumentUrl
'Color the cell based on the Document URL returned
If InStr(sDocumentUrl, sBadDOmainNameSUBSTRING) > 0 Then
Debug.Print Format(iRow, "00000 ") & " Bad Domain Name"
ws.Cells(iRow, sHyperlinkDataCOLUMN).Interior.Color = myRGB_Red 'Bad Domain Name
ElseIf InStr(sDocumentUrl, sUrlNotFoundSUBSTRING) > 0 Then
Debug.Print Format(iRow, "00000 ") & " Valid Domain Name - URL cannot be found"
ws.Cells(iRow, sHyperlinkDataCOLUMN).Interior.Color = myRGB_Magenta 'Valid Domain Name - URL cannot be found
ElseIf InStr(sDocumentUrl, sUrlIsAFileSUBSTRING) > 0 Then
Debug.Print Format(iRow, "00000 ") & " NO URL Hyperlink - URL is a file name"
ws.Cells(iRow, sHyperlinkDataCOLUMN).Interior.Color = myRGB_Yellow 'No URL Hyperlink - URL is a file name
Else
Debug.Print Format(iRow, "00000 ") & " Success"
ws.Cells(iRow, sHyperlinkDataCOLUMN).Interior.Color = myRGB_Green 'Success
End If
Else
Debug.Print Format(iRow, "00000 ") & " No URL Hyperlink - Link to this file"
ws.Cells(iRow, sHyperlinkDataCOLUMN).Interior.Color = myRGB_Yellow
End If
Else
Debug.Print Format(iRow, "00000 ") & " No URL Hyperlink"
ws.Cells(iRow, sHyperlinkDataCOLUMN).Interior.Color = myRGB_Cyan
End If
'Scroll down so the user can see progress
ActiveWindow.SmallScroll Down:=1
Wend
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Exit and Error Handler
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ERROR_HANDLER:
If Err.Number = 18 Then
MsgBox "Program Terminated because User Pressed the 'ESC' Key."
End If
ie.Quit
Set ie = Nothing
Set ws = Nothing
Debug.Print "Ended at " & Now()
End Sub
Sub GenerateBadDomainNameError()
'This uses Internet Explorer to attempt to access a URL with a 'Bad Domain Name'
Const sUrl = "http://www.XXXexcelforum.com/whocares.html"
Call GenerateInternetExplorerErrorGeneric(sUrl, sDomainNameNotFoundDisplayCELL)
End Sub
Sub GenerateURLNotFoundError()
'This uses Internet Explorer to attempt to access a URL with a 'Good Domain Name' and an Invalid URL
Const sUrl = "http://www.excelforum.com/junque.html"
Call GenerateInternetExplorerErrorGeneric(sUrl, sUrlNotFoundDisplayCELL)
End Sub
Sub GenerateURLIsAFileError()
'This uses Internet Explorer to attempt to access a URL that is not a URL, but is actually a file name
Const sUrl = "x.txt"
Call GenerateInternetExplorerErrorGeneric(sUrl, sUrlIsAFileDisplayCELL)
End Sub
Sub GenerateInternetExplorerErrorGeneric(sUrlToTest As String, sCell As String)
'This TESTS a URL using Internet Explorer and puts the value of 'document.URL' in the input cell
Dim ie As Object
Dim iRow As Long
Dim bNeedMore As Boolean
Dim sDocumentUrl As String
Dim sUrlActive As String
Dim sUrlStatusBarText As String
Dim sUrlLocationName As String
Dim sValue As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Initialization
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Verify that the Source Data Sheet Exists
If LjmSheetExists(sSourceWorksheetNAME) = False Then
MsgBox "TERMINATING. Source Worksheet DOES NOT EXIST." & vbCrLf & _
"Sheet Name: '" & sSourceWorksheetNAME & "'"
Exit Sub
End If
Sheets(sSourceWorksheetNAME).Range(sCell) = ""
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create the Internet Explorer Object
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ShowWindow ie.hwnd, SW_SHOWMINIMIZED
On Error GoTo Handler
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Attempt to Access the Website URL
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Navigate to the URL
ie.Navigate sUrlToTest
'Wait until Internet Explorer is not busy and ready
Do While ie.Busy Or ie.readyState <> 4
Sleep 200
Loop
'After not busy and ready, wait until status is 'Done'
If ie.StatusText <> "Done" Then
Sleep 200
End If
sUrlActive = ie.LocationURL
sUrlStatusBarText = ie.StatusText
sUrlLocationName = ie.LocationName
sDocumentUrl = ie.Document.URL
'Debug.Print "''''''''''''''''''''''"
'Debug.Print sUrlActive
'Debug.Print sUrlStatusBarText
'Debug.Print sUrlLocationName
'Debug.Print sDocumentUrl
Sheets(sSourceWorksheetNAME).Range(sCell) = sDocumentUrl
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Exit and Error Handler
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Handler:
ie.Quit
Set ie = Nothing
End Sub
Public Function LjmSheetExists(SheetName As String) As Boolean
'Return value TRUE if sheet exists
On Error Resume Next
If Sheets(SheetName) Is Nothing Then
LjmSheetExists = False
Else
LjmSheetExists = True
End If
On Error GoTo 0
End Function
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks