Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
End Sub
Sub Nav_Hyp1_Link_Checks()
'On Error Resume Next
Range("MultiLink").Select
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim totalVals As Long
Dim bNoRights As Boolean
splitVals = Split(ActiveCell.Value, Chr(10))
totalVals = UBound(splitVals)
Hyp1 = splitVals(0)
Hyp2 = splitVals(1)
'Get Line 1 Range
Start1 = InStr(Range("MultiLink").Value, Hyp1)
End1 = InStr(Range("MultiLink").Value, Hyp2) - 2
'***********************************************************************
' Hyperlink Validation - Check multilink line in single cell
'***********************************************************************
ExistPath = False
If Left(Hyp1, 7) = "http://" Or Left(Hyp1, 8) = "https://" Or Left(Hyp1, 6) = "ftp://" Or Left(Hyp1, 7) = "ftps://" Then
ExistPath = InternetCheckConnection(Hyp1, 1, 0) '1=FLAG_ICC_FORCE_CONNECTION
Else
'Hyp1 = " "" " + Hyp1 + " "" "
On Error Resume Next
Err.Clear
If Len(Dir(Hyp1)) > 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(Hyp1, 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
With ActiveCell.Characters(Start1, End1).Font ' Turn line blue if valid
.Color = RGB(0, 0, 255)
End With
Debug.Print "Valid"
ActiveWorkbook.FollowHyperlink Address:=Hyp1, NewWindow:=True
Else
If bNoRights Then
With ActiveCell.Characters(Start1, End1).Font ' Turn line green if no access to folder
.Color = RGB(0, 255, 0)
End With
Debug.Print "No Permissions"
Else
With ActiveCell.Characters(Start1, End1).Font ' Turn line red if not valid
.Color = RGB(255, 0, 0)
End With
Debug.Print "Not Valid"
End If
End If
Err_Trap:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End If
End Sub
Sub Nav_Hyp2_Link_Checks()
'On Error Resume Next
Range("MultiLink").Select
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim totalVals As Long
Dim bNoRights As Boolean
splitVals = Split(ActiveCell.Value, Chr(10))
totalVals = UBound(splitVals)
Hyp2 = splitVals(1)
Hyp3 = splitVals(2)
'Get Line 2 Range
Start2 = InStr(Range("MultiLink").Value, Hyp2)
End2 = InStr(Range("MultiLink").Value, Hyp3) - 2
'***********************************************************************
' Hyperlink Validation - Check multilink line in single cell
'***********************************************************************
ExistPath = False
If Left(Hyp2, 7) = "http://" Or Left(Hyp2, 8) = "https://" Or Left(Hyp2, 6) = "ftp://" Or Left(Hyp2, 7) = "ftps://" Then
ExistPath = InternetCheckConnection(Hyp2, 1, 0) '1=FLAG_ICC_FORCE_CONNECTION
If ExistPath = 0 Then
With ActiveCell.Characters(Start2, End2).Font ' Turn line red if not valid
.Color = RGB(255, 0, 0)
End With
Exit Sub
Else
With ActiveCell.Characters(Start2, End2).Font ' Turn line blue if valid
.Color = RGB(0, 0, 255)
End With
ActiveWorkbook.FollowHyperlink Address:=Hyp2, NewWindow:=True
Exit Sub
End If
Else
On Error Resume Next
Err.Clear
If Len(Dir(Hyp2)) > 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(Hyp2, 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
With ActiveCell.Characters(Start2, End2).Font ' Turn line blue if valid
.Color = RGB(0, 0, 255)
End With
Debug.Print "Valid"
ActiveWorkbook.FollowHyperlink Address:=Hyp2, NewWindow:=True
Else
If bNoRights Then
With ActiveCell.Characters(Start2, End2).Font ' Turn line green if no access to folder
.Color = RGB(0, 255, 0)
End With
Debug.Print "No Permissions"
Else
With ActiveCell.Characters(Start2, End2).Font ' Turn line red if not valid
.Color = RGB(255, 0, 0)
End With
Debug.Print "Not Valid"
End If
End If
Err_Trap:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End If
End Sub
Sub CheckAndColorLinks()
SetDefaultMultiLinkFont
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim lHyp As Long
Dim sHyp As String
Dim lStart As Long
Dim lEnd As Long
Dim bNoRights As Boolean
splitVals = Split(ActiveCell.Value, Chr(10))
For lHyp = 0 To UBound(splitVals) - 1
sHyp = splitVals(lHyp)
'Get Line 1 Range
lStart = InStr(Range("MultiLink").Value, sHyp) ' Get start position of line 1
lEnd = Len(sHyp) ' Get end position of line 1 by determining start position of line 2, less CHR(10)
'***********************************************************************
' Hyperlink Validation - Check multilink line in single cell
'***********************************************************************
ExistPath = False
If Left(sHyp, 7) = "http://" Or Left(sHyp, 8) = "https://" Or Left(sHyp, 6) = "ftp://" Or Left(sHyp, 7) = "ftps://" Then
ExistPath = InternetCheckConnection(sHyp, 1, 0) '1=FLAG_ICC_FORCE_CONNECTION
If ExistPath = 0 Then
With ActiveCell.Characters(lStart, lEnd).Font ' Turn line red if not valid
.Color = RGB(255, 0, 0)
End With
Else
With ActiveCell.Characters(lStart, lEnd).Font ' Turn line blue if valid
.Color = RGB(0, 0, 255)
End With
ActiveWorkbook.FollowHyperlink Address:=sHyp, NewWindow:=True
End If
Else
'Hyp1 = " "" " + Hyp1 + " "" "
On Error Resume Next
Err.Clear
If Len(Dir(sHyp)) > 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(sHyp, 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
End If
If ExistPath Then
With ActiveCell.Characters(lStart, lEnd).Font ' Turn line blue if valid
.Color = RGB(0, 0, 255)
End With
Debug.Print "Valid"
ActiveWorkbook.FollowHyperlink Address:=sHyp, NewWindow:=True
Else
If bNoRights Then
With ActiveCell.Characters(lStart, lEnd).Font ' Turn line green if no access to folder
.Color = RGB(0, 255, 0)
End With
Debug.Print "No Permissions"
Else
With ActiveCell.Characters(lStart, lEnd).Font ' Turn line red if not valid
.Color = RGB(255, 0, 0)
End With
Debug.Print "Not Valid"
End If
End If
Next lHyp
Err_Trap:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub
Each of your links has either a : or a \\ character set in it somewhere, doesn't it? (C:\, http://, ftp://, \\servername) So why not do a quick count on those... if anything ends up with more than one, it must be a multilink cell.GaryA said:How would you quickly identify if a cell is multilink or not via vba?
So to do this, you'd need to hook it to a worksheet change event. The framework would be something like this:GaryA said:How would you automatically adjust the formula bar based on the number of lines in ANY cell.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.FormulaBarHeight = HowManyLinesIs(Target)
End Sub
The actual right click routine can be re-written to use a more dynamic approach like I did with the last one (sorry, I'm out of time for tonight). I'd then link the selection change to create/destroy the menu based on the worksheets_selectionchange event as described above.GaryA said:How would you prevent display of the Hyperlink Lines 1 thru 5 (right mouse click)if cell is not a multilink cell?
Is there a better way to do this so as not to be limited to just 5 lines?
So far as I know we can't change the colour of the text in the Right Click menu. We could probably add an icon there though... maybe a different one for good/bad? I'll have to look in to how to do that again, it's been a while.GaryA said:How would you change the font color of the Right Mouse Click menu based on valid / invalid links?
Will get back to you on this. My last few and next few days have been ridiculously busy. So much so that I haven't been online at all since Friday.GaryA said:I am still interested in how you would re-write the right click routine to use a more dynamic approach.