Dispalying Gif Preview Upon Hyperlink Mouseoever

[Jaafar Tribak]

Hia all,

Let's say I have a cell with the address of a gif url . I am looking for a way to display a small preview of the gif url next to the cell upon moving the mouse pointer over the cell with the url address.

I am aware of this nice trick which passes a UDF to the Hyperlink function in order to dynamically show the url image in a picture shape. However, this doesn't work with gifs. It works only with static images.

I've looked online but so far nothing has come up.

I can think of a couple of potential workarounds but to save myself re-inventing the wheel, I would like to ask if anybody is aware of an already existing solution/hack ?

Regards.

Late edit:
I want to avoid inserting into the worksheet an ie explorer control for displaying the gif .. This is mainly because it resets the VBE and all variables get reset plus of course all the other known issues associated with embedeed ActiveX controls on worksheets.

 

[Jaafar Tribak]

Hi again,

Workbook demo





After much searching and experimenting, I seem to have arrived at a working solution... No WebBrowser control is needed and nothing is ever embedeed into the worksheet - all is lightweight API-based.

Add a new Class module to your project and give it the name of CHyperlinkPopupPreview

Class code:

Option Explicit

Private WithEvents cmb As CommandBars

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) 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 AtlAxWinInit Lib "Atl.dll" () As Long
    Private Declare PtrSafe Function AtlAxWinTerm Lib "Atl.dll" () As Long
    Private Declare PtrSafe Function AtlAxGetControl Lib "atl" (ByVal hwnd As LongPtr, Unk As stdole.IUnknown) As Long
    Private Declare PtrSafe Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare PtrSafe Function DestroyWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As Long
    Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As LongPtr) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    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 FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long

    Private hWbk As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function AtlAxWinInit Lib "Atl.dll" () As Long
    Private Declare Function AtlAxWinTerm Lib "Atl.dll" () As Long
    Private Declare Function AtlAxGetControl Lib "atl" (ByVal hwnd As Long, Unk As stdole.IUnknown) As Long
    Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As GUID) As Long
    Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long

    Private hWbk As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const WS_EX_STATICEDGE = &H20000
Private Const WS_CHILD As Long = &H40000000
Private Const WS_VISIBLE As Long = &H10000000
Private Const S_OK = &H0

Private tIID As GUID
Private lCookie As Long
Private oWbrowser As Object


[COLOR=#008000]'Public Class Property.
'======================[/COLOR]
Public Property Let Enable(ByVal vNewValue As Boolean)
    If vNewValue Then
        Call Start
    Else
        Call Finish
    End If
End Property

[COLOR=#008000]'Private Class Routines.
'======================[/COLOR]
Private Sub Start()
    Call Finish
    Set cmb = Application.CommandBars
    Call cmb_OnUpdate
End Sub

Private Sub Finish()
    On Error Resume Next
    Call AtlAxWinTerm
    Call DestroyWindow(GetProp(Application.hwnd, "hWebCtrl"))
    Call ConnectToConnectionPoint(Nothing, tIID, 0, oWbrowser, lCookie)
End Sub

Private Sub cmb_OnUpdate()
    Static oRange As Object
    Dim tPt As POINTAPI
    Dim oHyp As Hyperlink
    Dim sURLPath As String

    On Error Resume Next
    Call GetCursorPos(tPt)
    With Application
        .CommandBars.FindControl(ID:=2040).Enabled = Not .CommandBars.FindControl(ID:=2040).Enabled
        If GetActiveWindow = .hwnd And ActiveWorkbook Is ThisWorkbook Then
            If oRange.Address <> ActiveWindow.RangeFromPoint(tPt.x, tPt.y).Address Then Call Finish
            Set oRange = ActiveWindow.RangeFromPoint(tPt.x, tPt.y)
            Err.Clear
            Set oHyp = oRange.Hyperlinks(1)
            If Err.Number = 0 Then
                    sURLPath = oHyp.Address
                    If Len(sURLPath) Then
                        .DisplayFullScreen = .DisplayFullScreen
                    If IsWindow(GetProp(.hwnd, "hWebCtrl")) = 0 Then
                        hWbk = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
                        hWbk = FindWindowEx(hWbk, 0, "EXCEL7", vbNullString)
                        ScreenToClient hWbk, tPt
                        Call CreateBrowser(hWbk, tPt.x + 30, tPt.y + 20, 200, 200, sURLPath)
                    End If
                End If
            Else
                If IsWindow(GetProp(.hwnd, "hWebCtrl")) Then
                    Call Finish
                End If
            End If
        Else
            Call Finish
        End If
    End With
End Sub

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function CreateBrowser(ByVal hParent As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal URL As String) As Long
    Dim hWebCtrl As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function CreateBrowser(ByVal hParent As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal URL As String) As Long
    Dim hWebCtrl As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Dim Unk As stdole.IUnknown

    Call AtlAxWinInit
    hWebCtrl = CreateWindowEx(WS_EX_STATICEDGE, "AtlAxWin", URL, WS_CHILD Or WS_VISIBLE, x, y, cx, cy, hParent, 0, 0, ByVal 0)
    If hWebCtrl Then
        Call SetProp(Application.hwnd, "hWebCtrl", CLng(hWebCtrl))
        Call AtlAxGetControl(hWebCtrl, Unk)
        Set oWbrowser = Unk
        With oWbrowser
            .Silent = True
            .RegisterAsBrowser = True
            If IIDFromString(StrPtr("{34A715A0-6587-11D0-924A-0020AFC7AC4D}"), tIID) = S_OK Then
                If ConnectToConnectionPoint(Me, tIID, 1, oWbrowser, lCookie) = S_OK Then
                    DoEvents
                    .Document.body.innerHTML = "[IMG]https://www.mrexcel.com/forum/newreply.php?do=postreply&t=1045293[/IMG]"
                End If
            End If
        End With
    End If
End Function

Public Function DocumentComplete_DoNotUseThisMethod(ByVal pDisp As Object, URL As Variant)
    [B][COLOR=#008000]'Attribute DocumentComplete_DoNotUseThisMethod.VB_UserMemId = 259[/COLOR][/B]
    pDisp.Document.body.innerHTML = "[IMG]https://www.mrexcel.com/forum/newreply.php?do=postreply&t=1045293[/IMG]"
    'Debug.Print URL, "- Document loaded."
End Function

Usage code:
In the ThisWorkbook Module:

Option Explicit

Private oClass As CHyperlinkPopupPreview

Private Sub Workbook_Open()
    Set oClass = New CHyperlinkPopupPreview
    oClass.Enable = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set oClass = New CHyperlinkPopupPreview
    oClass.Enable = False
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Set oClass = New CHyperlinkPopupPreview
    oClass.Enable = True
End Sub

Note: Anyone using this code for the first time will need to first uncomment the line in green "Attribute DocumentComplete_DoNotUseThisMethod.VB_UserMemId = 259" located in the class module DocumentComplete public event procedure and then save and close the workbook.

The code should work as expected when the workbook is next re-opened.

Regards.

 

[Jaafar Tribak]

​I have noticed that the forum didn't permit posting the HTML image tag string allocated to the Document.body.innerHTML Property of the browser in the CreateBrowser sub and the DocumentComplete_DoNotUseThisMethod function ... The strings were left empty !

The correct codes should read as follows :