Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
Hi,
I have lately been doing some research on the subject of how to use the GDI+ library for drawing in vba.
One thing I wanted to do was to be able to perform smooth zooming on userform images (The native userform zoom property is no good as it doesn't keep the image in the center and moves the bottom-right corner off the client area). The following code achieves just that.
The code is also a good example of how to subclass several windows at once using the comctl32 library.
I have handled the WM_MOUSEWHEEL message in the window procedure so that the zooming in\out is carried out in response to scrolling up\down the mouse wheel.
Notice: Due to subclassing, the code should only be applied to Modal UserForms. If applied to modeless userforms, there is a risk of making the application unstable. Also, anyone incorporating this code in their project should carefully apply error handling as any unhandled error while the form is subclassed will crash the application.
Workbook Demo : GDIPlusZooming.xls
1-API code in a Standard Module:
2- Code in the Class Module ( Class name : Cls_PropertyBag)
3- Code Usage (As per the above demo workbook)
UserForm1
Userform2
UserForm3
UserForm4
I have lately been doing some research on the subject of how to use the GDI+ library for drawing in vba.
One thing I wanted to do was to be able to perform smooth zooming on userform images (The native userform zoom property is no good as it doesn't keep the image in the center and moves the bottom-right corner off the client area). The following code achieves just that.
The code is also a good example of how to subclass several windows at once using the comctl32 library.
I have handled the WM_MOUSEWHEEL message in the window procedure so that the zooming in\out is carried out in response to scrolling up\down the mouse wheel.
Notice: Due to subclassing, the code should only be applied to Modal UserForms. If applied to modeless userforms, there is a risk of making the application unstable. Also, anyone incorporating this code in their project should carefully apply error handling as any unhandled error while the form is subclassed will crash the application.
Workbook Demo : GDIPlusZooming.xls
1-API code in a Standard Module:
VBA Code:
Option Explicit
Private Enum BP_BUFFERFORMAT
BPBF_COMPATIBLEBITMAP = 0
BPBF_DIB = 1
BPBF_TOPDOWNDIB = 2
BPBF_TOPDOWNMONODIB = 3
End Enum
Private Type GdiplusStartupInput
GdiplusVersion As Long
#If Win64 Then
DebugEventCallback As LongLong
SuppressBackgroundThread As LongLong
#Else
DebugEventCallback As Long
SuppressBackgroundThread As Long
#End If
SuppressExternalCodecs As Long
End Type
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 PAINTSTRUCT
#If Win64 Then
hDc As LongLong
#Else
hDc As Long
#End If
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(0 To 31) As Byte
End Type
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hWnd As LongPtr, ByVal gaFlags As Long) As LongPtr
Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As LongPtr, ByVal wFlag As Long) As LongPtr
Private Declare PtrSafe Function RedrawWindow Lib "user32" (ByVal hWnd As LongPtr, lprcUpdate As RECT, ByVal hrgnUpdate As LongPtr, ByVal fuRedraw As Long) As Long
Private Declare PtrSafe Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hWnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr, Optional ByVal dwRefData As LongPtr) As LongPtr
Private Declare PtrSafe Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hWnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hWnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hWnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
Private Declare PtrSafe Function EnableWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal fEnable As Long) As Long
Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare PtrSafe Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, BITMAP As LongPtr) As Long
Private Declare PtrSafe Function GdipGetImageThumbnail Lib "gdiplus" (ByVal image As LongPtr, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As LongPtr, ByVal Callback As LongPtr, ByVal callbackData As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As LongPtr, hbmReturn As LongPtr, ByVal background As Long) As Long
Private Declare PtrSafe Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDc As LongPtr, hGraphics As LongPtr) As Long
Private Declare PtrSafe Function GdipGetImageWidth Lib "gdiplus" (ByVal pImage As LongPtr, ByRef nWidth As Long) As Long
Private Declare PtrSafe Function GdipGetImageHeight Lib "gdiplus" (ByVal pImage As LongPtr, ByRef nHeight As Long) As Long
Private Declare PtrSafe Function GdipDrawImageRect Lib "gdiplus" (ByVal graphics As LongPtr, ByVal image As LongPtr, ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare PtrSafe Function GdipDrawRectangle Lib "gdiplus" (ByVal graphics As LongPtr, ByVal pen As LongPtr, ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare PtrSafe Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As Long, pen As LongPtr) As Long
Private Declare PtrSafe Function GdipDeletePen Lib "gdiplus" (ByVal pen As LongPtr) As Long
Private Declare PtrSafe Function GdipGraphicsClear Lib "gdiplus" (ByVal graphics As LongPtr, ByVal lColor As Long) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal image As LongPtr) As Long
Private Declare PtrSafe Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr) As Long
Private Declare PtrSafe Function BufferedPaintInit Lib "uxtheme" () As Long
Private Declare PtrSafe Function BufferedPaintUnInit Lib "uxtheme" () As Long
Private Declare PtrSafe Function BeginBufferedPaint Lib "uxtheme" (ByVal hdcTarget As LongPtr, ByRef prcTarget As RECT, ByVal dwFormat As BP_BUFFERFORMAT, ByRef pPaintParams As Any, ByRef hDc As LongPtr) As LongPtr
Private Declare PtrSafe Function EndBufferedPaint Lib "uxtheme.dll" (ByVal hBufferedPaint As LongPtr, ByVal fUpdateTarget As Long) As Long
Private Declare PtrSafe Function BufferedPaintSetAlpha Lib "uxtheme" (ByVal hBufferedPaint As LongPtr, ByRef prc As RECT, ByVal Alpha As Byte) 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 hWnd As LongPtr, lPrevWndProc As LongPtr
#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 WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hWnd As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetAncestor Lib "user32" (ByVal hWnd As Long, ByVal gaFlags As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As Long, ByVal wFlag As Long) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hWnd As Long, lprcUpdate As RECT, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function BeginPaint Lib "user32" (ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hWnd As Long, ByVal fEnable As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Private Declare Function GdipGetImageThumbnail Lib "gdiplus" (ByVal image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, ByVal Callback As Long, ByVal callbackData As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As Long, hbmReturn As Long, ByVal background As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDc As Long, hGraphics As Long) As Long
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal pImage As Long, ByRef nWidth As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal pImage As Long, ByRef nHeight As Long) As Long
Private Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal Graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipDrawRectangle Lib "gdiplus" (ByVal graphics As Long, ByVal pen As Long, ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As Long, pen As Long) As Long
Private Declare Function GdipDeletePen Lib "gdiplus" (ByVal pen As Long) As Long
Private Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal Graphics As Long, ByVal lColor As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As Long) As Long
Private Declare Function BufferedPaintInit Lib "uxtheme" () As Long
Private Declare Function BufferedPaintUnInit Lib "uxtheme" () As Long
Private Declare Function BeginBufferedPaint Lib "uxtheme" (ByVal hdcTarget As Long, ByRef prcTarget As RECT, ByVal dwFormat As BP_BUFFERFORMAT, ByRef pPaintParams As Any, ByRef hDc As Long) As Long
Private Declare Function EndBufferedPaint Lib "uxtheme.dll" (ByVal hBufferedPaint As Long, ByVal fUpdateTarget As Long) As Long
Private Declare Function BufferedPaintSetAlpha Lib "uxtheme" (ByVal hBufferedPaint As Long, ByRef prc As RECT, ByVal Alpha As Byte) 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 hWnd As Long, lPrevWndProc As Long
#End If
Private Const dblZoomStep As Double = 1.1
Private oCollection As New Collection
Private tClientRect As RECT
Private oPtr As Cls_PropertyBag
Public Sub SubclassObject(ByVal Obj As Object, ByVal Pic As StdPicture, Optional ByVal BackGroundColor As Variant, Optional ByVal ZoomLabel As Control)
Const GWL_WNDPROC As Long = -4
Const GW_CHILD = 5
#If Win64 Then
Dim hResizedBitmap As LongLong
#Else
Dim hResizedBitmap As Long
#End If
Dim cls As New Cls_PropertyBag
Dim oUserForm As Object
Dim lBackColor As Long
Dim lRealcolor As Long
Dim R As Byte, G As Byte, B As Byte
If Not IsUserForm(Obj) Then
Set oUserForm = GetUserForm(Obj)
Else
Set oUserForm = Obj
End If
'Do not allow Modeless userforms\controls as
'subclassing them can be buggy.
If Not IsModal(oUserForm) Then
Call IUnknown_GetWindow(oUserForm, VarPtr(hWnd))
ShowWindow hWnd, 0
MsgBox "Can't subclass modeless form"
Set Obj = Nothing
Set Pic = Nothing
Set oUserForm = Nothing
Exit Sub
End If
Call IUnknown_GetWindow(Obj, VarPtr(hWnd))
If hWnd Then
If IsMissing(BackGroundColor) Then
Call TranslateColor(Obj.BackColor, 0, lRealcolor)
Else
Call TranslateColor(BackGroundColor, 0, lRealcolor)
End If
Call GetRGB(lRealcolor, R, G, B)
lBackColor = ARGB(&HFF, B, G, R)
Call GetClientRect(hWnd, tClientRect)
With tClientRect
hResizedBitmap = ResizeBitmap(Pic.Handle, .Right - .Left, .Bottom - .Top)
End With
With cls
Set .ImageHolder = Obj
Set .UForm = oUserForm
Set .PictureObject = Pic
.BackColor = lBackColor
.ZoomText = Obj.Caption
.ResizedBitmapHandle = hResizedBitmap
If Not ZoomLabel Is Nothing Then
Set .ZoomLabel = ZoomLabel
End If
End With
oCollection.Add cls, CStr(ObjPtr(cls))
If Obj Is oUserForm Then
hWnd = GetNextWindow(hWnd, GW_CHILD)
End If
Call SetWindowSubclass(hWnd, AddressOf WndProc, ObjPtr(cls), ObjPtr(cls))
End If
End Sub
#If Win64 Then
Private Sub RemoveSubclass(ByVal hWnd As LongLong, ByVal WinProc As LongLong, ByVal Ptr As Cls_PropertyBag)
#Else
Private Sub RemoveSubclass(ByVal hWnd As Long, ByVal WinProc As Long, ByVal Ptr As Cls_PropertyBag)
#End If
On Error Resume Next
Set oPtr = Ptr
Call RemoveWindowSubclass(hWnd, WinProc, Ptr)
Set oCollection(CStr(ObjPtr(Ptr))) = Nothing
oCollection.Remove (CStr(ObjPtr(Ptr)))
If oCollection.Count = 0 Then Set oCollection = Nothing
End Sub
Private Sub UpdateCaption(ByVal UF As Object, ByVal sCaption As String, ByVal dScale As Double, Optional oLabel As Control)
If oLabel Is Nothing Then
UF.Caption = sCaption & " (Zoom : " & Format((dScale * 100), "##") & "%)"
Else
oLabel.Caption = sCaption & " (Zoom : " & Format((dScale * 100), "##") & "%)"
End If
End Sub
#If Win64 Then
Private Function WndProc( _
ByVal hWnd As LongLong, _
ByVal wMsg As Long, _
ByVal wParam As LongLong, _
ByVal lParam As LongLong, _
ByVal uIdSubclass As Cls_PropertyBag, _
ByVal This As Object) As LongLong
Dim hBitmap As LongLong, hResizedBitmap As LongLong, bufferedDC As LongLong, hDc As LongLong, hGraphics As LongLong, hPaintContext As LongLong, hPen As LongLong
#Else
Private Function WndProc( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long, _
ByVal uIdSubclass As Cls_PropertyBag, _
ByVal This As Object) As Long
Dim hBitmap As Long, hResizedBitmap As Long, bufferedDC As Long, hDc As Long, hGraphics As Long, hPaintContext As Long, hPen As Long
#End If
Const WM_DESTROY = &H2
Const GWL_WNDPROC = -4
Const WM_PAINT As Long = &HF&
Const WM_MOUSEWHEEL = &H20A
Const WM_SETCURSOR = &H20
Const GW_CHILD = 5
Const RDW_INVALIDATE = &H1
Const RDW_NOINTERNALPAINT = &H10
Const RDW_NOCHILDREN = &H40
Const WHEEL_DELTA = 120
Const S_OK = 0&
Const GA_ROOT = 2
Const UnitPixel = 2
Dim tSI As GdiplusStartupInput
Dim tPS As PAINTSTRUCT
Dim tMousePos As POINTAPI
Dim lToken As Long, lRes As Long
Dim X As Single, Y As Single
Dim lBmpWidth As Long, lBmpHeight As Long
On Error Resume Next
With uIdSubclass
If .ZoomScale = 0 Then
.ZoomScale = 1
Call UpdateCaption(.UForm, .ZoomText, .ZoomScale, .ZoomLabel)
End If
End With
'
Select Case wMsg
Case WM_SETCURSOR
If GetFocus <> hWnd Then
Call SetFocus(GetAncestor(hWnd, GA_ROOT))
Call SetFocus(hWnd)
End If
Case WM_PAINT
hDc = BeginPaint(hWnd, tPS)
Call GetClientRect(hWnd, tClientRect)
hResizedBitmap = uIdSubclass.ResizedBitmapHandle
bufferedDC = 0
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lToken, tSI)
If lRes = S_OK Then
lRes = BufferedPaintInit
If lRes = S_OK Then
hPaintContext = BeginBufferedPaint(hDc, tClientRect, BPBF_TOPDOWNDIB, ByVal 0&, bufferedDC)
If hPaintContext Then
lRes = GdipCreateFromHDC(bufferedDC, hGraphics)
If lRes = S_OK Then
Call GdipGraphicsClear(hGraphics, uIdSubclass.BackColor)
lRes = GdipCreateBitmapFromHBITMAP(hResizedBitmap, 0, hBitmap)
If lRes = S_OK Then
Call GdipGetImageHeight(hBitmap, lBmpHeight)
Call GdipGetImageWidth(hBitmap, lBmpWidth)
Call BufferedPaintSetAlpha(hPaintContext, tClientRect, 255)
X = (tClientRect.Right - tClientRect.Left - lBmpWidth * uIdSubclass.ZoomScale) / 2
Y = (tClientRect.Bottom - tClientRect.Top - lBmpHeight * uIdSubclass.ZoomScale) / 2
lRes = GdipDrawImageRect(hGraphics, hBitmap, X, Y, _
lBmpWidth * uIdSubclass.ZoomScale, lBmpHeight * uIdSubclass.ZoomScale)
Call GdipCreatePen1(&HFF000000, 2, UnitPixel, hPen)
Call GdipDrawRectangle(hGraphics, hPen, tClientRect.Left, tClientRect.Top, tClientRect.Right, tClientRect.Bottom)
Call GdipDeletePen(hPen)
If lRes = S_OK Then
DoEvents
End If
Call GdipDisposeImage(hBitmap)
End If
Call GdipDeleteGraphics(hGraphics)
End If
Call EndBufferedPaint(hPaintContext, True)
End If
Call BufferedPaintUnInit
End If
Call GdiplusShutdown(lToken)
End If
Call EndPaint(hWnd, tPS)
Case WM_MOUSEWHEEL
With tMousePos
.X = loword(CLng(lParam))
.Y = HiWord(CLng(lParam))
#If Win64 Then
Dim lngPtr As LongLong, hwndFromPoint As LongLong
Call CopyMemory(lngPtr, tMousePos, LenB(tMousePos))
hwndFromPoint = WindowFromPoint(lngPtr)
#Else
Dim hwndFromPoint As Long
hwndFromPoint = WindowFromPoint(.X, .Y)
#End If
End With
If GetNextWindow(hWnd, GW_CHILD) = hwndFromPoint Or hWnd = hwndFromPoint Then
If HiWord(CLng(wParam)) > 0 Or HiWord(CLng(wParam)) = WHEEL_DELTA Then
uIdSubclass.ZoomScale = uIdSubclass.ZoomScale / dblZoomStep
Else
uIdSubclass.ZoomScale = uIdSubclass.ZoomScale * dblZoomStep
End If
Call RedrawWindow(hWnd, tClientRect, 0, RDW_NOCHILDREN + RDW_NOINTERNALPAINT + RDW_INVALIDATE)
With uIdSubclass
Call UpdateCaption(.UForm, .ZoomText, .ZoomScale, .ZoomLabel)
End With
End If
Case WM_DESTROY
uIdSubclass.ZoomScale = 0
Call EnableWindow(Application.hWnd, True)
Call SetFocus(Application.hWnd)
Call RemoveSubclass(hWnd, FuncAddr, uIdSubclass)
Exit Function
End Select
WndProc = DefSubclassProc(hWnd, wMsg, wParam, lParam)
End Function
#If Win64 Then
Private Function FuncAddr() As LongLong
FuncAddr = VBA.CLngLng(AddressOf WndProc)
#Else
Private Function FuncAddr() As Long
FuncAddr = VBA.CLng(AddressOf WndProc)
#End If
End Function
#If Win64 Then
Private Function ResizeBitmap( _
ByVal hSourceBitmap As LongLong, _
ByVal Width As Long, _
ByVal Height As Long _
) As LongLong
Dim lBitmap As LongLong, lThumb As LongLong
#Else
Private Function ResizeBitmap( _
ByVal hSourceBitmap As Long, _
ByVal Width As Long, _
ByVal Height As Long _
) As Long
Dim lBitmap As Long, lThumb As Long
#End If
Const S_OK = 0&
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI)
If lRes = S_OK Then
lRes = GdipCreateBitmapFromHBITMAP(hSourceBitmap, 0, lBitmap)
If lRes = S_OK Then
lRes = GdipGetImageThumbnail(lBitmap, Width, Height, lThumb, 0, 0)
If lRes = S_OK Then
lRes = GdipCreateHBITMAPFromBitmap(lThumb, hSourceBitmap, 0)
ResizeBitmap = hSourceBitmap
GdipDisposeImage lThumb
End If
GdipDisposeImage lBitmap
End If
GdiplusShutdown lGDIP
End If
If lRes Then Err.Raise 5
End Function
Private Function IsUserForm(ByVal Obj As Object) As Boolean
Dim oTemp As Object
On Error Resume Next
Set oTemp = Obj.Parent
IsUserForm = oTemp Is Nothing
End Function
Private Function GetUserForm(ByVal Ctrl As Control) As Object
Dim oTemp As Object
Set oTemp = Ctrl.Parent
Do While TypeOf oTemp Is MSForms.Control
Set oTemp = oTemp.Parent
Loop
Set GetUserForm = oTemp
End Function
Private Sub GetRGB(ByVal col As Long, R, G, B)
B = col \ 65536
G = (col - B * 65536) \ 256
R = col - B * 65536 - G * 256
End Sub
Private Function ARGB(Alpha As Byte, Red As Byte, Green As Byte, Blue As Byte) As Long
If Alpha > 127 Then
ARGB = ((Alpha - 128) * &H1000000 Or &H80000000) Or _
Red Or (Green * &H100&) Or (Blue * &H10000)
Else
ARGB = (Alpha * &H1000000) Or _
Red Or (Green * &H100&) Or (Blue * &H10000)
End If
End Function
Private Function HiWord(DWord As Long) As Long
HiWord = (DWord And &HFFFF0000) \ &H10000
End Function
Private Function loword(DWord As Long) As Integer
If DWord And &H8000& Then
loword = DWord Or &HFFFF0000
Else
loword = DWord And &HFFFF&
End If
End Function
Private Property Get IsModal(ByVal UF As Object) As Boolean
On Error Resume Next
UF.Show vbModeless
IsModal = Err.Number <> 0
Set UF = Nothing
On Error GoTo 0
End Property2- Code in the Class Module ( Class name : Cls_PropertyBag)
VBA Code:
Option Explicit
#If Win64 Then
Private hResizedBitmap As LongLong
#Else
Private hResizedBitmap As Long
#End If
Private oObj As Object, oPic As Object, oUF As Object, oZoomLabel As Control
Private sCaption As String, lColor As Long, dblScale As Double
Public Property Get ImageHolder() As Object
Set ImageHolder = oObj
End Property
Public Property Set ImageHolder(ByVal vNewValue As Object)
Set oObj = vNewValue
End Property
Public Property Get PictureObject() As Object
Set PictureObject = oPic
End Property
Public Property Set PictureObject(ByVal vNewValue As Object)
Set oPic = vNewValue
End Property
Public Property Get UForm() As Object
Set UForm = oUF
End Property
Public Property Set UForm(ByVal vNewValue As Object)
Set oUF = vNewValue
End Property
Public Property Get ZoomLabel() As Control
Set ZoomLabel = oZoomLabel
End Property
Public Property Set ZoomLabel(ByVal vNewValue As Control)
Set oZoomLabel = vNewValue
End Property
Public Property Get BackColor() As Long
BackColor = lColor
End Property
Public Property Let BackColor(ByVal vNewValue As Long)
lColor = vNewValue
End Property
Public Property Get ZoomText() As String
ZoomText = sCaption
End Property
Public Property Let ZoomText(ByVal vNewValue As String)
sCaption = vNewValue
End Property
Public Property Get ZoomScale() As Double
ZoomScale = dblScale
End Property
Public Property Let ZoomScale(ByVal vNewValue As Double)
dblScale = vNewValue
End Property
#If Win64 Then
Public Property Get ResizedBitmapHandle() As LongLong
ResizedBitmapHandle = hResizedBitmap
End Property
Public Property Let ResizedBitmapHandle(ByVal vNewValue As LongLong)
hResizedBitmap = vNewValue
End Property
#Else
Public Property Get ResizedBitmapHandle() As Long
ResizedBitmapHandle = hResizedBitmap
End Property
Public Property Let ResizedBitmapHandle(ByVal vNewValue As Long)
hResizedBitmap = vNewValue
End Property
#End If3- Code Usage (As per the above demo workbook)
UserForm1
VBA Code:
Option Explicit
Private Sub UserForm_Activate()
Me.Caption = "Zooming " & Me.Name & " Image With MouseWheel."
Call SubclassObject(Me, Sheet1.Image1.Picture, vbWhite)
End SubUserform2
VBA Code:
Option Explicit
Private Sub UserForm_Activate()
Call SubclassObject(Me, Sheet1.Image2.Picture, vbWhite)
End SubUserForm3
VBA Code:
Option Explicit
Private Sub UserForm_Activate()
Call SubclassObject(Frame2, Sheet1.Image2.Picture, vbWhite, Label1)
Call SubclassObject(Frame3, Sheet1.Image1.Picture, vbWhite, Label2)
Call SubclassObject(Frame4, Sheet1.Image4.Picture, vbBlack, Label3)
Call SubclassObject(Frame5, Sheet1.Image3.Picture, vbCyan, Label4)
End SubUserForm4
VBA Code:
Option Explicit
Private Sub UserForm_Activate()
Call SubclassObject(Me, Sheet1.Image4.Picture, vbBlack)
End Sub
Last edited:
