Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,779
- Office Version
- 2016
- Platform
- 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 :
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:
