Multiple hyperlinks in a single cell

[GaryA]

Is there any way to put more than one hyperlink in a single cell?

[Bob Phillips]

If you could, how would it know which one to follow?

[GaryA]

Hi Bob,

Actually, this would be ideal. For example, we have a spreadsheet that itemizes process steps by Row. For that same row, the process step is associated with multiple artifacts or hyperlinks, with the full UNC path to the artifact (the full path tells me which link to follow). For metric purposes, even though we have multiple artifacts, it still counts as 1 process step. This probably could be better served in a database, but I find Excel far easier to manipulate.

I have no idea if this can be done, but it would sure be a nice feature have available.

[Ken Puls]

Hi Gary,

I think you're out of luck on this one. I can't think of any way to get mutliple hyperlinks into a single cell.

[GaryA]

I would like to run this by you and maybe you can offer some guidance on its implementation.

1. Format the target cell for multiple lines (ALT + ENTER)
2. On each line put a different Path to a file, folder or URL.
Note: These cells would always be formatted this way.
3. Create a Macro (SENDKEYS) to select the specific line (1, 2, 3, 4 or 5) in the Active Cell and copy it to the clipboard or an array, convert the contents of the clipboard or array(value) to a hyperlink and navigate the path.

[GaryA]

Well, I have put multiple paths in a single cell, on separate lines, CHR(10), and can navigate to the individual paths by using Chandoos SplitCell routines and grabbing a target path. See attachment.

However, it is not yet complete. I need to assign keyboard macros to the target paths. For some reason, the Application.OnKey "^1", "Nav_Hyp1" is not working. Any ideas?

Here is the code:

Sub Nav_Hyp1()
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

splitVals = Split(ActiveCell.Value, Chr(10))
totalVals = UBound(splitVals)

Hyp1 = splitVals(0)
Hyp2 = splitVals(1)
Hyp3 = splitVals(2)
Hyp4 = splitVals(3)
Hyp5 = splitVals(4)

ActiveWorkbook.FollowHyperlink Address:=Hyp1, NewWindow:=True

Application.OnKey "^1", "Nav_Hyp1"

End Sub

[GaryA]

Done it! Had to add the following code to the "ThisWorkbook" Module. Updated file attached.

Private Sub Workbook_Activate()
Application.OnKey "^1", "Nav_Hyp1"
Application.OnKey "^2", "Nav_Hyp2"
Application.OnKey "^3", "Nav_Hyp3"
Application.OnKey "^4", "Nav_Hyp4"
Application.OnKey "^5", "Nav_Hyp5"
End Sub

Private Sub Workbook_Deactivate()
Application.OnKey "^1", ""
Application.OnKey "^2", ""
Application.OnKey "^3", ""
Application.OnKey "^4", ""
Application.OnKey "^5", ""
End Sub

How would you go about assigning the "Left Mouse button" + "1" combination to lauch a macro? It would give you more of the feel of clicking on an actual hyperlink in the cell.

[Ken Puls]

Hi Gary,

Way to go! I'm glad you got that part worked out.

With regards to capturing the "Left Mouse Button" + 1 combination, I'm not sure how realistic that is. The issue is that when you left click that immediately triggers an action. When you press the number one, the same thing. The mouse button is not like the CTRL or ALT keys in that regard that wait for a secondary input.

There are a couple of Worksheet events that you might be able to use though... a double click and a right click event. Their signatures are:

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


Alternately, you could pop up a box on doubleclick asking them which of the five links you want to follow. You could have that autopopulate from in a userform. So basically you'd double click the cell, then click on the desired link. Would that work?

[GaryA]

Hi Ken, I got side tracked with trying to validate the individual links on the separate lines. I modified the check-links code to determine the start and stop characters values for each line, then attempt to change the color of the line depending on the link valiation. Link validation seems to work for all individual lines but it fails to highlight the text start/stop correctly. I removed all the CHR(10)'s during debug thinking that may have something to do with it, but I get the same problem.:confused2:

Nav_Hyp1_Link_Checks Works: It validated the first link and updated the color of line 1 correctly.

Nav_Hyp2_Link_Checks Fails: It validated the second link but does not update the color of the second line based on start/stop correctly.


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

[Ken Puls]

Hi Gary,

Can you upload a new version of the file? I'm a bit lost in all the changes here. I tried adding the last post's routines to the prior file, but it was misisng something for me.

Thanks,

[GaryA]

Hi Ken, updated file attached.

[Ken Puls]

Hi Gary,

This isn't perfect, you may have to do a little work on the last one, as it is reformatting the first line a bit. But hopefully it will get you close.


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


Just so you know, I've changed it so that you don't have to rely on 6 different variables, in fact, it will support as many links as you throw in there.

One more thing... you should REALLY make sure you've got Option Explicit at the top of your modules. It will force you to declare all of your variables, which will save you down the line later on.

[GaryA]

Outstanding! This is exactly what it should do. I'll try to work out the the formatting issue.

Yes, I agree with you, use of Option Explicit is a must.

Thanks for all your help. :)

[GaryA]

Updated workbook attached.

1. Added RightMouse click navigation to hyperlink 1 thru 5.

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?

2. Now testing for empty lines between links.

3. Adjusting the formula bar to display all the lines when clicking on Multilink Cell.

How would you automatically adjust the formula bar based on the number of lines in ANY cell.

4. Need to apply the CheckAndColorLinks() macro to multiple Multilink cells in a specific column.

How would you quickly identify if a cell is multilink or not via vba?

[GaryA]

Additionally. Now using Option Explicit. This seemed to have fixed the color issue with line 1.

Had to add an addional CHR(10) at the end of the Multilink cell to get the last line link color to work correctly. Not sure why?

[Ken Puls]

How would you quickly identify if a cell is multilink or not via vba?
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.


How would you automatically adjust the formula bar based on the number of lines in ANY cell.
So to do this, you'd need to hook it to a worksheet change event. The framework would be something like this:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.FormulaBarHeight = HowManyLinesIs(Target)

End Sub


You'd need to write the "HowManyLinesIs" function for this to make it work though. Something that starts like this:

Function HowManyLinesIs(rngTarget as range) as Long

'Check how many times : and \\ exist in rngTarget.Text

End Function


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?
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.

Hopefully that helps get you started, but if not I'll circle back with you tomorrow. :)

[GaryA]

Hi Ken,

Automatically adjusting the FormulaBarHeight:

Function AutoAdjustMultilink(rngTarget As Range) As Long
'Count the total # of "Chr(10)" characters in Active cell and pass value to the Worksheet_SelectionChange Event to automaticaly adjust the FormulaBarHeight
AutoAdjustMultilink = (Len(ActiveCell) - Len(Replace(ActiveCell, Chr(10), ""))) + 1
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.FormulaBarHeight = AutoAdjustMultilink(Target)
End Sub

Counting "//" and ":" in Active Cell:

Function HowManyLinesIs(rngTarget As Range) As Long 'Total count of "//" and ":" in Active Cell
HowManyLinesIs = (Len(ActiveCell) - Len(Replace(ActiveCell, "//", ""))) + (Len(ActiveCell) - Len(Replace(ActiveCell, ":", "")))
End Function

I may need your help to use a more dynamic approach to the Rt mouse click event.

Thanks!

[GaryA]

Uploaded new file.

Updated SelectionChange event for HowManyLinesIs:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Count the total # of "Chr(10)" characters in Active cell and pass value to the Worksheet_SelectionChange Event to automaticaly adjust the FormulaBarHeight
Application.FormulaBarHeight = AutoAdjustMultilink(Target)

' Is this a Multilink cell or not?
If HowManyLinesIs(Target) > 1 Then
MsgBox "This is a Multilink Cell"
Else
MsgBox "This is not a Multilink Cell"
End If
End Sub

[GaryA]

Hi Ken,

Updated file attached:

1. Added MultiLink paths to Right Mouse Click menu.
2. Automatically determines if the active cell contains multilinks.

How would you change the font color of the Right Mouse Click menu based on valid / invalid links?

I am still interested in how you would re-write the right click routine to use a more dynamic approach.

[Ken Puls]

How would you change the font color of the Right Mouse Click menu based on valid / invalid links?
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.


I am still interested in how you would re-write the right click routine to use a more dynamic approach.
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]

Adding good/bad icons to the Rt mouse click menu is a great idea. I'll give it a go.

Many Thanks,

Gary

[GaryA]

Hi Ken,

I need to modify the "CheckAndColorLinks" routine to add the specific value of FaceID when a link is good or bad.

How do you pass that value to the Worksheet_SelectionChange(ByVal Target As Range).

The .FaceIDs I will be using are 2876 and 6843, passed to variable iICON

i.e.


With Application.CommandBars("Cell").Controls

With .Add
.Caption = Hyp1 'Navigate to Hyperlink1
.OnAction = ThisWorkbook.Name & "!Nav_Hyp1" 'in RClick
.Tag = "Hyperlink1" 'cControlTag
.BeginGroup = True
.FaceID = iICON
End With

End With

Thanks,

Gary

[Ken Puls]

Hey Gary,

I haven't forgotten, but I'm out of time for tonight. I'll try and circle back on this over the weekend, although it's kind of a nutty one here.

FYI... I've reformatted your code to display better in the forum. When you're posting code, if you wrap it with code tags it comes out looking nicer. To do that, you'd write:


Your code here

And it will end up coming out like this:

Your code here

Cheers,