Background Click-Through Image in single or multiple cells

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,616
Office Version
  1. 2016
Platform
  1. Windows
As you know, you can set a background image for an entire sheet, but can you set a background image to cover only a selection of cells, say B8:E20 ? Unfortunatly, there is no way to send an image behind the cells



The usual workaround to this problem is to place over the designated cells a boderless shape with a semi-transparent image but that leaves us with a major problem : You cannot click/select the cells with the mouse as the shape lies on top, only the keyboard can be used for selecting the cells underneath

In order to make a click-through image that behaves as close as possible to the native worksheet background picture, I have resorted to the Windows API as shown in the code below

Essentially, this workaround works as follows :

1- Add a userform to the VBProject and insert in it a background picture of your choice (This is the pic that ultimately will be displayed behind the cells)

2- The API code will then change the userform current styles so what is left is just the form's client area that holds the picture (Code will remove caption, Window Frame, set transparency, make form topmost etc..)

3- This is the tricky part - Once the form is on display, the code will have to continiously monitor the exact screen location of the Range containing the background picture so that when the user scrolls the worksheet,changes the zoom, moves the excel/workbook window or simply activates another worksheet, the userform has to follow the new screen location of the Range .. I have used a windows timer combined with some Regions functions for this

Anyway, here is the code that goes in a Standard Module :
Code: 
Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

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

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #End If
#Else
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
#End If

#If VBA7 Then
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) 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 MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
    Private Declare PtrSafe Function SelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr) 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 CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, pt As POINTAPI) 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 RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    
    Private lRgn1 As LongPtr, lRgn2 As LongPtr
    Private hwndImage As LongPtr, hwndExcel7 As LongPtr
#Else
    Private Declare Function ShowWindow Lib "USER32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
    Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
    Private Declare Function MoveWindow Lib "USER32" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare Function ScreenToClient Lib "USER32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function SetTimer Lib "USER32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "USER32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function SetWindowPos Lib "USER32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function SetWindowRgn Lib "USER32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
    Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn 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 Long
    Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "USER32" (ByVal vKey As Long) As Integer
    Private Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long
    Private Declare Function PtInRect Lib "USER32" (lpRect As RECT, pt As POINTAPI) 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 RemoveProp Lib "USER32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) 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 FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function DrawMenuBar Lib "USER32" (ByVal hWnd As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "USER32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    
    Private lRgn1 As Long, lRgn2 As Long
    Private hwndImage As Long, hwndExcel7 As Long
#End If

Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_BORDER = &H800000
Private Const WS_DLGFRAME = &H400000
Private Const WS_THICKFRAME = &H40000
Private Const WS_DISABLED = &H8000000

Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const WS_EX_TRANSPARENT = &H20&
Private Const WS_EX_DLGMODALFRAME = &H1
Private Const WS_EX_TOPMOST = &H8&

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const POINTSPERINCH = 72

Private Const SWP_FRAMECHANGED = &H20
Private Const RGN_AND = 1
Private Const LWA_ALPHA = &H2&

Private tTargetRangeRect As RECT
Private oTargetRange As Range


' Calling Macros ..
'--------------------------
Public Sub ShowImage()
    Call DisplayImage(UserForm1, Sheet1.Range("B8: E20"))
End Sub

Public Sub HideImage()
    Call CleanUp(UserForm1)
End Sub

'Public Routines ..
'-------------------
Public Sub DisplayImage(ByVal Img As Object, ByVal TargetRange As Range)
    KillTimer Application.hwnd, 0
    RemoveProp Application.hwnd, "Image"
    If GetProp(Application.hwnd, "Image") <> 0 Then Exit Sub
    Set oTargetRange = TargetRange
    hwndExcel7 = FindWindowEx(FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString), 0, "EXCEL7", vbNullString)
    tTargetRangeRect = GetRangeRect(oTargetRange)
    hwndImage = FindWindow(vbNullString, Img.Caption)
    SetProp Application.hwnd, "Image", hwndImage
    Call SetWindowLong(hwndImage, GWL_STYLE, GetWindowLong(hwndImage, GWL_STYLE) And Not WS_CAPTION)
    DrawMenuBar hwndImage
    Call SetWindowLong(hwndImage, GWL_STYLE, GetWindowLong(hwndImage, GWL_STYLE) _
    And Not WS_BORDER And Not WS_THICKFRAME And Not WS_DLGFRAME Or WS_DISABLED)
    With tTargetRangeRect
        Call SetWindowPos(hwndImage, WS_EX_TOPMOST, .Left, .Top, .Right - .Left, .Bottom - .Top, SWP_FRAMECHANGED)
    End With
    Call SetWindowLong(hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME)
    SetWindowLong hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) Or WS_EX_LAYERED
    SetWindowLong hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) Or WS_EX_TRANSPARENT
    SetLayeredWindowAttributes hwndImage, 0, 128, LWA_ALPHA
    Img.Show vbModeless
    SetTimer Application.hwnd, 0, 1, AddressOf ImagePositionMonitor
End Sub


Public Sub CleanUp(ByVal Img As Object)
    KillTimer Application.hwnd, 0
    RemoveProp Application.hwnd, "Image"
    Unload Img
End Sub

'Private Routines ..
'-------------------
Private Sub ImagePositionMonitor()
    Static l1 As Long, t1 As Long, r1 As Long, b1 As Long, _
    l2 As Long, t2 As Long, r2 As Long, b2 As Long
    Dim tpt1 As POINTAPI, tpt2 As POINTAPI, tCurPos As POINTAPI
    Dim tVsbRngRect As RECT
    
    On Error Resume Next
    tVsbRngRect = GetRangeRect(ActiveWindow.VisibleRange)
    tTargetRangeRect = GetRangeRect(oTargetRange)
    GetCursorPos tCurPos
    
    If GetAsyncKeyState(vbKeyLButton) <> 0 And PtInRect(tVsbRngRect, tCurPos) <> 0 And _
    TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) = "Range" And _
    tTargetRangeRect.Left = l1 Then Exit Sub
    
    If Not ActiveSheet Is oTargetRange.Parent Or IsIconic(Application.hwnd) Then
        ShowWindow hwndImage, 0
        Exit Sub
    Else
        ShowWindow hwndImage, 1
    End If
    With tTargetRangeRect
        MoveWindow hwndImage, .Left, .Top, _
        .Right - .Left, _
        .Bottom - .Top, True
        tpt1.x = .Left
        tpt1.y = .Top
        tpt2.x = .Right
        tpt2.y = .Bottom
        ScreenToClient hwndExcel7, tpt1
        ScreenToClient hwndExcel7, tpt2
        .Left = tpt1.x
        .Top = tpt1.y
        .Right = tpt2.x
        .Bottom = tpt2.y
    End With
    With tVsbRngRect
        tpt1.x = .Left
        tpt1.y = .Top
        tpt2.x = .Right
        tpt2.y = .Bottom
        ScreenToClient hwndExcel7, tpt1
        ScreenToClient hwndExcel7, tpt2
        .Left = tpt1.x
        .Top = tpt1.y
        .Right = tpt2.x
        .Bottom = tpt2.y
    End With
    With tTargetRangeRect
        If .Left <> l1 Or .Top <> t1 Or tVsbRngRect.Left <> l2 Or tVsbRngRect.Top <> t2 Or _
        .Right <> r1 Or .Bottom <> b1 Or tVsbRngRect.Right <> r2 Or tVsbRngRect.Bottom <> b2 Then
            lRgn1 = CreateRectRgn(-tVsbRngRect.Left, -tVsbRngRect.Top, tVsbRngRect.Right, tVsbRngRect.Bottom)
            lRgn2 = CreateRectRgn(tVsbRngRect.Left - .Left, tVsbRngRect.Top - .Top, _
            tVsbRngRect.Right - .Left, tVsbRngRect.Bottom - .Top)
            Call CombineRgn(lRgn2, lRgn2, lRgn1, RGN_AND)
            SetWindowRgn hwndImage, lRgn2, True
            DeleteObject lRgn1
            DeleteObject lRgn2
        End If
    End With
    With tTargetRangeRect
        l1 = .Left
        t1 = .Top
        r1 = .Right
        b1 = .Bottom
    End With
    With tVsbRngRect
        l2 = .Left
        t2 = .Top
        r2 = .Right
        b2 = .Bottom
    End With
End Sub

Private Function GetRangeRect(ByVal rng As Range) As RECT
    Dim OWnd  As Window
    
    Set OWnd = rng.Parent.Parent.Windows(1)
    With rng
        GetRangeRect.Left = PTtoPX(.Left * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0)
        GetRangeRect.Top = PTtoPX(.Top * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0)
        GetRangeRect.Right = PTtoPX(.Width * OWnd.Zoom / 100, 0) _
        + GetRangeRect.Left
        GetRangeRect.Bottom = PTtoPX(.Height * OWnd.Zoom / 100, 1) _
        + GetRangeRect.Top
    End With
End Function
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function
Private Function ScreenDPI(bVert As Boolean) As Long
    Static lDPI(1), lDC
   If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function


 
Last edited:

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Sort by date Sort by votes
Hello,

When I wrote the above code, I only tested it in Windows 64bit. Yesterday, I tested it in a 32Bit machine and it failed to correctly display the image over the designated range.

Below is an update that ,hopefully, should work properly in both 32 and 64 bit machines :

Workbook update demo

code goes in a Standard Module:
Code: 
Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

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

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #End If
#Else
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
#End If

#If VBA7 Then
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) 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 MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
    Private Declare PtrSafe Function SelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr) 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 CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, pt As POINTAPI) 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 RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    
    Private lRgn1 As LongPtr, lRgn2 As LongPtr
    Private hwndImage As LongPtr, hwndExcel7 As LongPtr
#Else
    Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
    Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
    Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn 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 Long
    Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function PtInRect Lib "user32" (lpRect As RECT, pt As POINTAPI) 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 RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    
    Private lRgn1 As Long, lRgn2 As Long
    Private hwndImage As Long, hwndExcel7 As Long
#End If

Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_BORDER = &H800000
Private Const WS_DLGFRAME = &H400000
Private Const WS_THICKFRAME = &H40000
Private Const WS_DISABLED = &H8000000

Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const WS_EX_TRANSPARENT = &H20&
Private Const WS_EX_DLGMODALFRAME = &H1
Private Const WS_EX_TOPMOST = &H8&


Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const POINTSPERINCH = 72

Private Const SWP_FRAMECHANGED = &H20
Private Const RGN_AND = 1
Private Const LWA_ALPHA = &H2&

Private tTargetRangeRect As RECT
Private oTargetRange As Range

' Calling Macros ..
'--------------------------
Public Sub ShowImage()
    Call DisplayImage(UserForm1, Sheet1.Range("B8: E20"))
End Sub

Public Sub HideImage()
    Call CleanUp(UserForm1)
End Sub

'Public Routines ..
'-------------------
Public Sub DisplayImage(ByVal Img As Object, ByVal TargetRange As Range)
    KillTimer Application.hwnd, 0
    RemoveProp Application.hwnd, "Image"
    If GetProp(Application.hwnd, "Image") <> 0 Then Exit Sub
    Set oTargetRange = TargetRange
    hwndExcel7 = FindWindowEx(FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString), 0, "EXCEL7", vbNullString)
    tTargetRangeRect = GetRangeRect(oTargetRange)
    Img.StartUpPosition = 0
    hwndImage = FindWindow(vbNullString, Img.Caption)
    SetProp Application.hwnd, "Image", hwndImage
    Call SetWindowLong(hwndImage, GWL_STYLE, GetWindowLong(hwndImage, GWL_STYLE) And Not WS_CAPTION)
    DrawMenuBar hwndImage
    Call SetWindowLong(hwndImage, GWL_STYLE, GetWindowLong(hwndImage, GWL_STYLE) _
    And Not WS_BORDER And Not WS_THICKFRAME And Not WS_DLGFRAME Or WS_DISABLED)
    With tTargetRangeRect
        Call SetWindowPos(hwndImage, WS_EX_TOPMOST, .Left, .Top, .Right - .Left, .Bottom - .Top, SWP_FRAMECHANGED)
    End With
    Call SetWindowLong(hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME)
    SetWindowLong hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) Or WS_EX_LAYERED
    SetWindowLong hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) Or WS_EX_TRANSPARENT
    SetLayeredWindowAttributes hwndImage, 0, 128, LWA_ALPHA
    Img.Show vbModeless
    SetTimer Application.hwnd, 0, 1, AddressOf ImagePositionMonitor
End Sub

Public Sub CleanUp(ByVal Img As Object)
    KillTimer Application.hwnd, 0
    RemoveProp Application.hwnd, "Image"
    Unload Img
End Sub

'Private Routines ..
'-------------------
Private Sub ImagePositionMonitor()
    Static l1 As Long, t1 As Long, r1 As Long, b1 As Long, _
    l2 As Long, t2 As Long, r2 As Long, b2 As Long
    Dim tpt1 As POINTAPI, tpt2 As POINTAPI, tCurPos As POINTAPI
    Dim tVsbRngRect As RECT
    
    On Error Resume Next
    tVsbRngRect = GetRangeRect(ActiveWindow.VisibleRange)
    tTargetRangeRect = GetRangeRect(oTargetRange)
    GetCursorPos tCurPos
'    If GetAsyncKeyState(vbKeyLButton) <> 0 And PtInRect(tVsbRngRect, tCurPos) <> 0 And _
'    TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) = "Range" And _
'    tTargetRangeRect.Left = l1 Then Exit Sub
    If GetAsyncKeyState(vbKeyLButton) <> 0 And _
    TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) = "Range" And _
    tTargetRangeRect.Left = l1 Then Exit Sub
    If Not ActiveSheet Is oTargetRange.Parent Or IsIconic(Application.hwnd) Then
        ShowWindow hwndImage, 0
        Exit Sub
    Else
        ShowWindow hwndImage, 1
    End If
    With tTargetRangeRect
        MoveWindow hwndImage, .Left, .Top, _
        .Right - .Left, _
        .Bottom - .Top, True
        tpt1.x = .Left
        tpt1.y = .Top
        tpt2.x = .Right
        tpt2.y = .Bottom
        ScreenToClient hwndExcel7, tpt1
        ScreenToClient hwndExcel7, tpt2
        .Left = tpt1.x
        .Top = tpt1.y
        .Right = tpt2.x
        .Bottom = tpt2.y
    End With
    With tVsbRngRect
        tpt1.x = .Left
        tpt1.y = .Top
        tpt2.x = .Right
        tpt2.y = .Bottom
        ScreenToClient hwndExcel7, tpt1
        ScreenToClient hwndExcel7, tpt2
        .Left = tpt1.x
        .Top = tpt1.y
        .Right = tpt2.x
        .Bottom = tpt2.y
    End With
    With tTargetRangeRect
        If .Left <> l1 Or .Top <> t1 Or tVsbRngRect.Left <> l2 Or tVsbRngRect.Top <> t2 Or _
        .Right <> r1 Or .Bottom <> b1 Or tVsbRngRect.Right <> r2 Or tVsbRngRect.Bottom <> b2 Then
            lRgn1 = CreateRectRgn(-tVsbRngRect.Left, -tVsbRngRect.Top, tVsbRngRect.Right, tVsbRngRect.Bottom)
            lRgn2 = CreateRectRgn(tVsbRngRect.Left - .Left, tVsbRngRect.Top - .Top, _
            tVsbRngRect.Right - .Left, tVsbRngRect.Bottom - .Top)
            Call CombineRgn(lRgn2, lRgn2, lRgn1, RGN_AND)
            SetWindowRgn hwndImage, lRgn2, True
            DeleteObject lRgn1
            DeleteObject lRgn2
        End If
    End With
    With tTargetRangeRect
        l1 = .Left
        t1 = .Top
        r1 = .Right
        b1 = .Bottom
    End With
    With tVsbRngRect
        l2 = .Left
        t2 = .Top
        r2 = .Right
        b2 = .Bottom
    End With
End Sub

Private Function GetRangeRect(ByVal rng As Range) As RECT
    Dim OWnd  As Window
    
    Set OWnd = rng.Parent.Parent.Windows(1)
    With rng
        GetRangeRect.Left = PTtoPX(.Left * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0)
        GetRangeRect.Top = PTtoPX(.Top * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0)
        GetRangeRect.Right = PTtoPX(.Width * OWnd.Zoom / 100, 0) _
        + GetRangeRect.Left
        GetRangeRect.Bottom = PTtoPX(.Height * OWnd.Zoom / 100, 1) _
        + GetRangeRect.Top
    End With
End Function
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function
Private Function ScreenDPI(bVert As Boolean) As Long
    Static lDPI(1), lDC
   If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
300
huiettcm
H
W
  • Question
minimize and Maximize
Replies
4
Views
670
NdNoviceHlp
NdNoviceHlp
T
  • Solved
Chart point must move to point of click in chart
Replies
2
Views
71
tigger_na
T
Jaafar Tribak
  • Question
Blurring images using Direct2D & Windows Imaging Component
Replies
3
Views
255
Dan_W
D
A
  • Question
What is wrong with this VBA code: userForm get hand ico for pointer on hover
2
Replies
15
Views
520
RoryA
RoryA

Forum statistics

Threads
1,214,919
Messages
6,122,259
Members
449,075
Latest member
staticfluids

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top