Link Checks

[GaryA]

Trying to check cells that contains paths to a File, a Folder, URL, or a Sharepoint Site by changing the font color of the active cell to validate the hyperlink. This works pretty good most of the time, but not everytime. Any suggestions?

[Ken Puls]

Can you give some more details on when it fails?

[GaryA]

It fails on ExistPath, it is sometime true when it is actually false or visa versa.

-------------------------------------
If Len(Dir(Fname)) > 0 Then ' verify path
ExistPath = True
Else

If Len(Dir(Fname, vbDirectory)) > 0 Then ' verify the file
ExistPath = True
End If
End If

End If

If ExistPath Then
ActiveCell.Font.Color = RGB(0, 0, 255) ' Turn font blue if valid
'Debug.Print "Valid"
Else
ActiveCell.Font.Color = RGB(255, 0, 0) ' Turn font red if not valid
'Debug.Print "Not Valid"
--------------------------------

[Ken Puls]

Hi Gary,

This isn't going to fix your problem at all, but since I run on 64bit Office, I had to modify your API call to work. Figured I might as well share the modifications to help future proof this when you've got it totally sorted. I replaced your API code with this:

#If Win64 Then
    Private Declare PtrSafe Function InternetCheckConnection Lib "wininet.dll" _
        Alias "InternetCheckConnectionA" ( _
            ByVal lpszUrl As String, _
            ByVal dwFlags As LongPtr, _
            ByVal dwReserved As LongPtr) As LongPtr
#Else
    Private Declare Function InternetCheckConnection Lib "wininet.dll" _
        Alias "InternetCheckConnectionA" ( _
            ByVal lpszUrl As String, _
            ByVal dwFlags As Long, _
            ByVal dwReserved As Long) As Long
#End If

So that will now work in both 32bit and 64bit versions of Office.

Now, as to the real issue... I tested your code, and it seems to work fine for me here, but I'm not sure if I'm doing anything "weird" enough to trigger the issue. To debug this, we need to know the symptons of the actual issues, i.e. where it fails. The one thing we know for sure is that it never works one way or another, it always works the way we programmed it. We just don't always realize that things have some idiosyncracies that we didn't cater for. (My forum sig for years was always "I hate it when my computer does what I tell it to and not what I want it to"!)

Can you share with me a list of scenarios where it does not work? What I'm looking for is:
- The exact text that is in the Excel cell
- The exact hyperlink that is embedded in the Excel text (it may be different than what's showing)
- The full file path to the file or folder that you're targeting
- An indication of what it did return and what you feel is should have returned. (False positive, or false negative?)

With that info I can set up a test on my side to mirroir your paths and debug any issues that I find.

[GaryA]

Exact Text: \\VSS\Data\Repository. The issues here is that I do not have network permissions to the folder. The macro hangs when it encounters this cell. I need to account for lack of permissions, say, in a different color and ID the issue and then move on.

Exact hyperlink: The way it should work is:
1) delete the existing hyperlink in the active cell
2) takes the text in the active cell and create a new hyperlink
3) Test the hyperlink, If valid: Blue, if invalid: Red

I was also trying to take into account spaces in the paths to files and folders.

In my actual code, all mapped drives are converted to UNC paths, before testing the link. i.e. P:\ is mapped to \\VSS

For Web links, I am not sure if %20 replacements of spaces cause any issues.

[Ken Puls]

Hi Gary,

I've made a minor mod to try and deal with the permissions error. I notice on my system that it throws Error 52 each time I try to connect to a drive with no access. Give this a go:

Private Sub FixSingleCellHyperlink()
    Application.ScreenUpdating = False ' Turn off Screen updating
    
    Dim Fname As String
    Dim bNoRights As Boolean
    Sheets("Artifacts").Select ' Select Artifact Worksheet
    Cells(Application.ActiveCell.Row, 1).Select 'Go to 1st cell of current row
    ActiveCell.Offset(0, 9).Select ' Select the Artifact Column
    Set rngArea = Range("Direct_Artifact_Link_Group") 'Set the Defined range
    
    Fname = Selection.Value ' Select active cell
    If Fname = "" Then ' Check if cell is empty, if so, warn user.
        MsgBox "Sorry, There is no data in the cell.", vbOKOnly
        Exit Sub
    End If
    
  
    ActiveCell.Value = ConvertDrive2ServerName(Fname) ' Convert Path to UNC, if mapped, and copy selected path to the Active cell.
    Fname = Selection.Value ' Get the Active Cell Text
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Fname, TextToDisplay:=Fname ' Create Hyperlink from active cell text
    '***********************************************************************
    ' Hyperlink Validation - Check single
    '***********************************************************************
    ExistPath = False
    If Left(Fname, 7) = "http://" Or Left(Fname, 8) = "https://" Or Left(Fname, 6) = "ftp://" Or Left(Fname, 7) = "ftps://" Then
        ExistPath = InternetCheckConnection(Fname, 1, 0) '1=FLAG_ICC_FORCE_CONNECTION
    Else
         'Fname = " "" " + Fname + " "" "
        On Error Resume Next
        Err.Clear
        If Len(Dir(Fname)) > 0 Then ' verify path
                If Err.Number = 52 Then
                    'Error thrown due to lack of directory access
                    bNoRights = True
                Else
                    ExistPath = True
                End If
        Else
       
           If Len(Dir(Fname, vbDirectory)) > 0 Then ' verify the file
                If Err.Number = 52 Then
                    'Error thrown due to lack of directory access
                    bNoRights = True
                Else
                    ExistPath = True
                End If
        End If
        
    End If
        
    If ExistPath Then
        ActiveCell.Font.Color = RGB(0, 0, 255) ' Turn font blue if valid
                'Debug.Print "Valid"
    Else
        If bNoRights Then
            ActiveCell.Font.Color = RGB(0, 255, 0)
        Else
            ActiveCell.Font.Color = RGB(255, 0, 0) ' Turn font red if not valid
                    'Debug.Print "Not Valid"
        End If
    'test = ConvertDrive2ServerName(Fname)
    
    End If
    
    Set rngArea = Nothing ' clear range value
    
    Application.ScreenUpdating = True ' Turn on Screen updating
    
      
Err_Trap:
    If Err <> 0 Then
        Err.Clear
        Resume Next
    End If
    
End Sub

[GaryA]

Thanks Ken, I added another "End If" at the end, but your code works perfectly. It flags the cells with color green when it connot access that location. I made the same mod to the "Check_For_Broken_Hyperlinks" routine (Checks all links in column instead of a single link) and it works most excellent. Many thanks!

I came accross another scenario in the following intranet link: http://web2.acd.com/ProcessPortal/Do...umber=PM-G-002. To the code, this link is valid because it looks at the first part of the link only and not the whole string, when in reality, the document does not exits. Any thoughts?

[Ken Puls]

Hi Gary,

On mine that link fails, presumably because I don't have access to the intranet... It should be passing the entire link through as well as you don't manipulate Fname in any way, just test for it's preface...

[GaryA]

Hi Ken, the link points to a Document Server that really does exist on our intranet. The path is http://web2.acd.com/ProcessPortal/Do...umber=PM-G-002. But the document (identified by the documentNumber PM-G-002) does not exist. When the code encounters this link, the code indicates that the link is valid when in reality it is not.

[Ken Puls]

Ahhh... I see what you mean. It actually works the same as a website... if the page is not found, it re-routes to an index page, correct?

Interestingly enough, I was able to test this using my site. If I put in the URL to this page it believes it's there (as it should). If I add a letter to the URL at the end, it still believes it's there, even though it actually triggers a 404 error... which re-routes you to my homepage.

I'll work on this a little later and see if I can come up with a solution.