Page 2 of 3 FirstFirst 1 2 3 LastLast
Results 11 to 20 of 23

Thread: Multiple hyperlinks in a single cell

  1. #11


    Register for a FREE account, and/
    or Log in to avoid these ads!

    Hi Ken, updated file attached.
    Attached Files Attached Files

  2. #12
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Location
    Nanaimo, BC, Canada
    Posts
    2,344
    Articles
    56
    Blog Entries
    14
    Excel Version
    Excel Office 365 Insider
    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.

    Code:
    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.
    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.

  3. #13
    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.

  4. #14
    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?
    Attached Files Attached Files
    Last edited by GaryA; 2012-05-07 at 11:22 PM.

  5. #15
    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?

  6. #16
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Location
    Nanaimo, BC, Canada
    Posts
    2,344
    Articles
    56
    Blog Entries
    14
    Excel Version
    Excel Office 365 Insider
    Quote Originally Posted by GaryA
    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.

    Quote Originally Posted by GaryA
    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:
    Code:
    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

    Quote Originally Posted by GaryA
    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.
    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.

  7. #17
    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!
    Last edited by GaryA; 2012-05-22 at 02:26 AM.

  8. #18
    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
    Attached Files Attached Files
    Last edited by GaryA; 2012-05-22 at 03:43 PM.

  9. #19
    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.
    Attached Files Attached Files
    Last edited by GaryA; 2012-05-22 at 05:58 PM.

  10. #20
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Location
    Nanaimo, BC, Canada
    Posts
    2,344
    Articles
    56
    Blog Entries
    14
    Excel Version
    Excel Office 365 Insider
    Quote Originally Posted by GaryA
    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.

    Quote Originally Posted by GaryA
    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.
    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.

Page 2 of 3 FirstFirst 1 2 3 LastLast

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •