Excel Hyperlinks - activate a message box... VBA christmas!

[MacroEcon1337]

I have an excel workbook with a bunch of hyperlinks built into the worksheet cells. These hyperlinks all point to other cells/sheets within the same workbook. The problem is that people keep accidentally clicking the hyperlinks, and getting involuntarily bounced around the workbook.

I'm wondering if there is a way to program an "event" to occur whenever any hyperlink is clicked. The event would open a message box and say "Do you wish to navigate to the link?" - allowing the user to select "no" if they don't want to navigate.

Would this require a class module, or something else? Any assistance pointing me on the right path would be greatly appreciated,

MC

 

[Logit]

.
One method would involve replacing the hyperlinks with a MessageBox (Yes/No) and go from there.

 

[Jaafar Tribak]

Are the Hyperlinks inserted or using the HYPERLINK function ?

 

[MacroEcon1337]

They are created with this method. You set the beginning/hyperlink cell "equal to" a cell on another worksheet. Then I go back to the beginning/hyperlink cell, highlight it, and run the macro below. So I don't think the Hyperlink() function is involved at all?

The key is this workbook is byzantine, and people want to be able to "trace backwards." The links are great for that, but too many people are being accidently teleported throughout the workbook when they accidentally click on linked cells (the users call them "jump cells" haha).

'Convert Cell Link into Hyperlink
Sub MakeLink()
    Dim Rng As Range
    For Each Rng In Selection
        If Rng.Formula Like "=*!*" Then
            Rng.Hyperlinks.Add Rng, "", Replace(Rng.Formula, "=", "")
        End If
    Next Rng
End Sub

any ideas greatly appreciated - and happy holidays to all,

MC

 

[Jaafar Tribak]

Hi MacroEcon1337,

You can use something along these lines :

Code in the ThisWorkbook Module:

Option Explicit

Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
    With Application
        .ScreenUpdating = False
        If MsgBox("Do you wish to navigate to the link?", vbYesNo) = vbNo Then
            .Goto Target.Parent
        End If
        .ScreenUpdating = True
    End With
End Sub

Note hawever that the above code fires after the hyperlink has been clicked which means it is not that good and could cause problems if there happens to be other event code when activating the worksheets.

 

[Jaafar Tribak]

In order to have the msgbox apper before the hyperlink is followed, I have written the following code which is obviously more involved than the previous one but should be more accurate :

Workbook demo

Code in the Thisworkbook Module :

Option Explicit

Private WithEvents cmbrs As CommandBars

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type KeyboardBytes
    kbByte(0 To 255) As Byte
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare PtrSafe Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private oHyperLinkCell As Object
Private oPrevSelection As Object

Private Sub Workbook_Activate()
    Call StoreRecoverSubAddresses(True)
    Set cmbrs = Application.CommandBars
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Call StoreRecoverSubAddresses(True)
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Set cmbrs = Application.CommandBars
    Set oPrevSelection = Target
End Sub

Sub StoreRecoverSubAddresses(ByVal Store As Boolean)
    Dim oCell As Range
    
    For Each oCell In ActiveSheet.UsedRange.Cells
        If oCell.Hyperlinks.Count > 0 Then
            If Store Then
                oCell.Hyperlinks(1).Range.ID = oCell.Hyperlinks(1).SubAddress
            Else
                oCell.Hyperlinks(1).SubAddress = oCell.Hyperlinks(1).Range.ID
            End If
        End If
    Next
End Sub

Private Sub cmbrs_OnUpdate()
    Dim tCurPos As POINTAPI
    Dim kbArray As KeyboardBytes
    
    Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled
    GetCursorPos tCurPos
    Set oHyperLinkCell = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)
    If TypeName(oHyperLinkCell) = "Range" Then
        GetKeyboardState kbArray
        If oHyperLinkCell.Hyperlinks.Count Then
            oHyperLinkCell.Hyperlinks(1).SubAddress = ""
            If GetKeyState(vbKeyLButton) = 1 Then
                If oPrevSelection.Address = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y).Address Then
                    Call StoreRecoverSubAddresses(False)
                        If MsgBox("Do you wish to navigate to the link?", vbYesNo) = vbNo Then
                    Else
                        oHyperLinkCell.Hyperlinks(1).Follow
                    End If
                End If
            End If
        End If
    End If
    kbArray.kbByte(vbKeyLButton) = 0
    SetKeyboardState kbArray
End Sub

 

[MacroEcon1337]

This works perfectly – thank you Mr. Jaafar, and Happy holidays!

In order to have the msgbox apper before the hyperlink is followed, I have written the following code which is obviously more involved than the previous one but should be more accurate :

Workbook demo

Code in the Thisworkbook Module :

Option Explicit

Private WithEvents cmbrs As CommandBars

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type KeyboardBytes
    kbByte(0 To 255) As Byte
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare PtrSafe Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private oHyperLinkCell As Object
Private oPrevSelection As Object

Private Sub Workbook_Activate()
    Call StoreRecoverSubAddresses(True)
    Set cmbrs = Application.CommandBars
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Call StoreRecoverSubAddresses(True)
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Set cmbrs = Application.CommandBars
    Set oPrevSelection = Target
End Sub

Sub StoreRecoverSubAddresses(ByVal Store As Boolean)
    Dim oCell As Range
    
    For Each oCell In ActiveSheet.UsedRange.Cells
        If oCell.Hyperlinks.Count > 0 Then
            If Store Then
                oCell.Hyperlinks(1).Range.ID = oCell.Hyperlinks(1).SubAddress
            Else
                oCell.Hyperlinks(1).SubAddress = oCell.Hyperlinks(1).Range.ID
            End If
        End If
    Next
End Sub

Private Sub cmbrs_OnUpdate()
    Dim tCurPos As POINTAPI
    Dim kbArray As KeyboardBytes
    
    Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled
    GetCursorPos tCurPos
    Set oHyperLinkCell = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)
    If TypeName(oHyperLinkCell) = "Range" Then
        GetKeyboardState kbArray
        If oHyperLinkCell.Hyperlinks.Count Then
            oHyperLinkCell.Hyperlinks(1).SubAddress = ""
            If GetKeyState(vbKeyLButton) = 1 Then
                If oPrevSelection.Address = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y).Address Then
                    Call StoreRecoverSubAddresses(False)
                        If MsgBox("Do you wish to navigate to the link?", vbYesNo) = vbNo Then
                    Else
                        oHyperLinkCell.Hyperlinks(1).Follow
                    End If
                End If
            End If
        End If
    End If
    kbArray.kbByte(vbKeyLButton) = 0
    SetKeyboardState kbArray
End Sub