Hyperlink function

[effka]

Hello,

Is there any way to always show linked cell (by "HYPERLINK" function) in top left corner?

I used this macro:

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Application.Goto Selection, Scroll:=True
End Sub

but this code only works with simple hyperlinks created by this method:

Can you help to upgrade macro code?

 

[Jaafar Tribak]

Are you linking to a worksheet cell within the workbook or linking to a url ?

 

[effka]

Yes, I'm trying to link from one cell to other in the same worksheet something like this:

I can achieve this by doing hyperlinks manually (by clicking right mouse button) but in my excel will be hundreds of hyperlinks so I want to use =HYPERLINK() function.

 

[Jaafar Tribak]

To achieve some kind of worksheet\workbook event that automatically fires when a cell with the Hyperlink function (formula) is not going to be easy... I have a vague recollection of coding something a while back but never got around finishing the code.

One annoying issue I remember when testing was that the hyperlink tooltip that normally appears when hovering the hyperlik cell gets blocked and never shows up due to the use of a loop in the code.

If you can live with that ? I can look for the code, tweak it and post the result here later on tonight.

 

[effka]

if you can share this, I will be very thankful!

 

[Jaafar Tribak]

This turned out to be more difficult than I initially anticipated. I agree it seems overkill but, I liked the challenge and the learning opportunity.

The code resides inside a class module ( CHypEvent ). The Class provides an custom event ( OnHyperLinkClick ) which passes the Hyperlink Cell and the linked target in its arguments to the client sink class (ThisWorkbook module ).

The client class ( ThisWorkbook ) can then flexibly use the event and use the passed arguments as needed... The CHypEvent class code also provides a custom hyperlink tooltip to make up for the issue with the default hyperlink tips which I mentioned in my previous post.

Pros:
- Stable... No risk of crashing excel as the code doesn't use windows timers nor subclassing. The code is based on the CommandBars OnUpdate event.
- Code approached in an OOP way for flexibility and intuitivity of use... Worker code is insulated inside the class so the user will only need to handle the event in the client (ThisWorkbook module)

Cons:
- Code runs periodically behind the scenes (imitating a timer) which has a performance hit.
- Slightly slow in intercepting clicks on the hyperlinks as the commandbars event runs approx every third of a second.
- Works only on one workbook at a time.
- Maybe other issues I haven't discovered.


HyperLinkEvent.xlsm



1- CHypEvent Class code:

Option Explicit

Public Event OnHyperLinkClick(ByVal HyperLinkCell As Range, ByVal HyperLinkTarget As Variant)

Private WithEvents oCmbrsEvents As CommandBars

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

#If VBA7 Then
    Private Declare PtrSafe Function SetThreadExecutionState Lib "Kernel32.dll" (ByVal esFlags As Long) As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As LongPtr
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hDC As LongPtr, ByVal lpStr As LongPtr, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function FillRgn Lib "gdi32" (ByVal lShapeDC As LongPtr, ByVal hRgn As LongPtr, ByVal hFrameBrush As LongPtr) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPtr
    Private Declare PtrSafe Function FrameRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT, ByVal bErase As Long) As Long
    Private Declare PtrSafe Function SetCursor Lib "user32" (ByVal hCursor As LongPtr) As LongPtr
    Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function SetThreadExecutionState Lib "Kernel32.dll" (ByVal esFlags As Long) As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As LongPtr
    Private Declare Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hDC As LongPtr, ByVal lpStr As LongPtr, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare Function FillRgn Lib "gdi32" (ByVal lShapeDC As LongPtr, ByVal hRgn As LongPtr, ByVal hFrameBrush As LongPtr) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPtr
    Private Declare Function FrameRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT, ByVal bErase As Long) As Long
    Private Declare Function SetCursor Lib "user32" (ByVal hCursor As LongPtr) As LongPtr
    Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
#End If

Private Type POINTAPI
  x As Long
  y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type MSG
    hwnd As LongPtr
    message As Long
    wParam As LongPtr
    lParam As LongPtr
    time As Long
    pt As POINTAPI
End Type



Private Sub Class_Initialize()
    Set oCmbrsEvents = Application.CommandBars
    Call oCmbrsEvents_OnUpdate
End Sub

Private Sub oCmbrsEvents_OnUpdate()
    Call MonitorUserSelection
End Sub


Private Sub MonitorUserSelection()

    Const WM_MOUSEFIRST = &H200
    Const WM_MOUSELAST = &H209
    Const WM_LBUTTONDOWN = &H201
    Const WM_RBUTTONDOWN = &H204
    Const PM_REMOVE = &H1
    Const IDC_HAND = 32649&
    
    Static oPrevSelection As Range
    Dim tMsg As MSG, tCurPos As POINTAPI
    Dim oHypLinkCell As Object, oHypLinkTarget As Variant
    Dim sTipText As String
    

    Application.EnableCancelKey = xlDisabled
    
    If GetActiveWindow <> Application.hwnd Then GoTo Xit

    On Error Resume Next
        If oPrevSelection.Address <> ActiveWindow.RangeSelection.Address _
            And Not oPrevSelection Is Nothing Then
                GoTo Xit
        End If
    On Error GoTo 0

    Call GetCursorPos(tCurPos)
    Set oHypLinkCell = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)
    
    If TypeName(oHypLinkCell) = "Range" Then
        If HasHyperLinkFunction(oHypLinkCell) Then
            sTipText = GetHypelinkTarget(oHypLinkCell)
            Call DrawOnWindow(oHypLinkCell, sTipText, True)
            Do
                Call SetCursor(LoadCursor(NULL_PTR, IDC_HAND))
                Call WaitMessage
                If PeekMessage(tMsg, 0&, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) Then
                    Set oHypLinkCell = ActiveWindow.RangeFromPoint(tMsg.pt.x, tMsg.pt.y)
                    If HasHyperLinkFunction(oHypLinkCell) Then
                        If tMsg.message = WM_RBUTTONDOWN Then
                            oHypLinkCell.Select
                            Call DrawOnWindow(oHypLinkCell, sTipText, False)
                            Call DispatchMessage(tMsg)
                        End If
                        If tMsg.message = WM_LBUTTONDOWN Then
                            On Error Resume Next
                                Set oHypLinkTarget = Range(Replace(sTipText, "#", ""))
                                If IsObject(oHypLinkTarget) Then
                                    RaiseEvent OnHyperLinkClick(oHypLinkCell, oHypLinkTarget)
                                End If
                                If Err.Number Then
                                    RaiseEvent OnHyperLinkClick(oHypLinkCell, sTipText)
                                    ThisWorkbook.FollowHyperlink sTipText
                                End If
                                Err.Clear
                            On Error GoTo 0
                        End If
                    Else
                        Call DrawOnWindow(oHypLinkCell, sTipText, False)
                    End If
                    If HasHyperLinkFunction(oHypLinkCell) = False Then
                        Exit Do
                    End If
                End If
                DoEvents
            Loop
        End If
    End If

Xit:

    Set oPrevSelection = ActiveWindow.RangeSelection
    
    PreventSleepMode = True
    With Application.CommandBars.FindControl(ID:=2040)
        .Enabled = Not .Enabled
    End With
    
End Sub

Private Sub DrawOnWindow(ByVal HyperLinkRange As Range, ByVal TipText As String, bDraw As Boolean)

    Const DT_CALCRECT = &H400
    Const DT_CENTER = &H1
    Const TRANSPARENT = 1&
    Const COLOR_INFOBK = 24&
    Const DEFAULT_GUI_FONT = 17&
    
    Dim hDC As LongPtr, hRgn As LongPtr, hBrush As LongPtr
    Dim hFont As LongPtr, hPrevFont As LongPtr
    
    Dim tCellRect As RECT, tTextRect As RECT, tCurPos As POINTAPI
    Dim lWidth As Long, lHeight As Long, lLeft As Long, lTop As Long
    Dim lNewColor As Long
    Dim sText As String
        
        
    sText = TipText & vbLf & _
        "[Click once to follow Link - Right Click to select this cell.]" & vbLf
    
    hDC = GetDC(NULL_PTR)
    hFont = GetStockObject(DEFAULT_GUI_FONT)
    hPrevFont = SelectObject(hDC, hFont)
    Call DrawText(hDC, StrPtr(sText), Len(sText), tTextRect, DT_CALCRECT)
    With tTextRect
        lLeft = .Left
        lTop = .Top
        lWidth = .Right - .Left + 10&
        lHeight = .Bottom - .Top + 10&
    End With
    Call TranslateColor(GetSysColor(COLOR_INFOBK), 0&, lNewColor)
    hBrush = CreateSolidBrush(lNewColor)
    If bDraw Then
        Call GetCursorPos(tCurPos)
        tCellRect = GetRangeRect(HyperLinkRange)
        With tCellRect
            .Left = tCellRect.Left + (tCellRect.Right - tCellRect.Left) / 2
            .Top = tCellRect.Bottom
            .Right = lWidth + .Left
            .Bottom = lHeight + .Top - 20&
        End With
        With tCellRect
            hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
        End With
        Call FillRgn(hDC, hRgn, hBrush)
        Call DeleteObject(hRgn)
        Call DeleteObject(hBrush)
        Call SetBkMode(hDC, TRANSPARENT)
        Call DrawText(hDC, StrPtr(sText), Len(sText), tCellRect, DT_CENTER)
        Call DeleteObject(SelectObject(hDC, hPrevFont))
        Call DeleteObject(hBrush)
        hBrush = CreateSolidBrush(vbMagenta)
        Call FrameRect(hDC, tCellRect, hBrush)
        Call DeleteObject(hBrush)
        Call ReleaseDC(NULL_PTR, hDC)
    Else
        Call InvalidateRect(NULL_PTR, tCellRect, 0&)
    End If

End Sub

Private Function HasHyperLinkFunction(ByVal Rng As Range) As Boolean
    On Error Resume Next
    HasHyperLinkFunction = InStr(Rng.Formula, "HYPERLINK")
End Function

Private Property Let PreventSleepMode(ByVal bPrevent As Boolean)
    Const ES_SYSTEM_REQUIRED As Long = &H1
    Const ES_DISPLAY_REQUIRED As Long = &H2
    Const ES_AWAYMODE_REQUIRED = &H40
    Const ES_CONTINUOUS As Long = &H80000000
    If bPrevent Then
        Call SetThreadExecutionState(ES_CONTINUOUS Or ES_DISPLAY_REQUIRED Or _
            ES_SYSTEM_REQUIRED Or ES_AWAYMODE_REQUIRED)
    Else
        Call SetThreadExecutionState(ES_CONTINUOUS)
    End If
End Property

Private Function GetHypelinkTarget(ByVal Rng As Range) As String
    Dim sFormula As String
    Dim lpos1 As Long, lpos2 As Long
    
    sFormula = Rng.FormulaLocal
    
    If InStr(Rng.Formula, "HYPERLINK") Then
        lpos1 = InStr(sFormula, "(")
        lpos2 = InStr(sFormula, Application.International(xlListSeparator))
        sFormula = Mid(sFormula, lpos1 + 1, lpos2 - lpos1 - 1)
        GetHypelinkTarget = Evaluate(sFormula)
    End If
End Function

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Const LOGPIXELSX As Long = 88&
    Const LOGPIXELSY As Long = 90&
    Static lDPI(1&), hDC

    If lDPI(0) = 0& Then
        hDC = GetDC(NULL_PTR)
        lDPI(0) = GetDeviceCaps(hDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(hDC, LOGPIXELSY)
        hDC = ReleaseDC(NULL_PTR, hDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
    Const POINTSPERINCH As Long = 72&
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

Private Function GetRangeRect(ByVal obj As Range) As RECT
    Dim oPane  As Pane
    Set oPane = ThisWorkbook.Windows(1&).ActivePane

    With GetRangeRect
        .Left = oPane.PointsToScreenPixelsX(obj.Left)
        .Top = oPane.PointsToScreenPixelsY(obj.Top)
        .Right = oPane.PointsToScreenPixelsX(obj.Left + obj.Width - 2&)
        .Bottom = oPane.PointsToScreenPixelsY(obj.Top + obj.Height)
    End With
End Function

2- ThisWorkbook Module Code:

Option Explicit

Private WithEvents oCHypEvent As CHypEvent

Private Sub Workbook_Activate()
    'Starts monitoring hyperlinks upon activating the wbk or opening it.
    SetHook True
End Sub

Private Sub Workbook_Deactivate()
    'Stop monitoring hyperlinks upon deactivating the wbk or closing it.
    SetHook False
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    'Needed in case the oCHypEvent var goes out of scope unintentionally.
    'Can be commented out if user wants to edit the hyperlinks w/o the tooltips interfering.
    SetHook True
End Sub

Public Sub UnLoad_CHypEvent_Class()
    'Stops monitoring hyperlinks
    SetHook False
End Sub

Private Sub SetHook(Optional ByVal bSet As Boolean = True)
    If bSet Then
        Set oCHypEvent = New CHypEvent
    Else
        Set oCHypEvent = Nothing
    End If
End Sub


' ___________________________________ HYPERLINK CLICK EVENT ______________________________________________

Private Sub oCHypEvent_OnHyperLinkClick(ByVal HyperLinkCell As Range, ByVal HyperLinkTarget As Variant)

    If IsObject(HyperLinkTarget) Then
        'If linking to cells.
        Application.Goto HyperLinkTarget, True
        Debug.Print "Target Address : "; HyperLinkTarget.Address
    ElseIf VarType(HyperLinkTarget) = vbString Then
        'If linking to urls.
        Debug.Print "Target Address : "; HyperLinkTarget
    End If

End Sub

As I said, all this amount of code is probably not worthwhile for such little return but, there you have it.

 

[Jaafar Tribak]

Small update with a couple of code changes.
HyperLinkEvent.xlsm