Can you give some more details on when it fails?
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?
Last edited by GaryA; 2012-04-07 at 12:15 AM.
Can you give some more details on when it fails?
Ken Puls, FCPA, FCMA, MS MVP
Learn to Master Your Data at the Power Query Academy (the world's most comprehensive online Power Query training), with my book M is for Data Monkey, or our new Power Query Recipe cards!
Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter
If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.
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"
--------------------------------
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:
So that will now work in both 32bit and 64bit versions of Office.Code:#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
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.![]()
Ken Puls, FCPA, FCMA, MS MVP
Learn to Master Your Data at the Power Query Academy (the world's most comprehensive online Power Query training), with my book M is for Data Monkey, or our new Power Query Recipe cards!
Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter
If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.
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.
Last edited by GaryA; 2012-04-18 at 05:31 PM.
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:
Code: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
Ken Puls, FCPA, FCMA, MS MVP
Learn to Master Your Data at the Power Query Academy (the world's most comprehensive online Power Query training), with my book M is for Data Monkey, or our new Power Query Recipe cards!
Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter
If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.
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?
Last edited by GaryA; 2012-04-20 at 05:55 PM.
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...
Ken Puls, FCPA, FCMA, MS MVP
Learn to Master Your Data at the Power Query Academy (the world's most comprehensive online Power Query training), with my book M is for Data Monkey, or our new Power Query Recipe cards!
Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter
If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.
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.
Last edited by GaryA; 2012-04-21 at 12:58 AM.
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.![]()
Ken Puls, FCPA, FCMA, MS MVP
Learn to Master Your Data at the Power Query Academy (the world's most comprehensive online Power Query training), with my book M is for Data Monkey, or our new Power Query Recipe cards!
Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter
If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.
Bookmarks