Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,615
- Office Version
- 2016
- Platform
- Windows
Hi dear members.
I thought I would post this little project here . Basically, as per the thread title, the code creates beveled round buttons at runtime.
The buttons can be added to the userform or to a frame control.
Behind the scenes, the code creates temporary round shapes in a hidden worksheet (makes use of the enhanced shapes engine that is built-in excel > 2007) , add to them the requested formatting, copies them to the clipboard and then paste them to a parent frame container as a stdpicture.
I have seen similar approaches for adding shapes to userforms before but the resulting shapes were liveless: always flat, not clickable and had no tab support.
I have wrapped the code in two classes CRoundButton and CRoundButtons for easy use. The classes expose intuitive Properties,Methods and a Click event + Tab functionality.
One limitation is that you cannot add the buttons in separate parent containers. In other words, if you decide to add the buttons to the userform, you cannot add some of them to a frame and vice versa. This is due to an annoying bug in the MSForms control .
Workbook Example:
Round3D_Buttons.xlsm
Here is a preview :
1- CRoundButton Class code:
2- CRoundButtons Collection Class Code:
3- Usage example in a UserForm Module:
Regards.
I thought I would post this little project here . Basically, as per the thread title, the code creates beveled round buttons at runtime.
The buttons can be added to the userform or to a frame control.
Behind the scenes, the code creates temporary round shapes in a hidden worksheet (makes use of the enhanced shapes engine that is built-in excel > 2007) , add to them the requested formatting, copies them to the clipboard and then paste them to a parent frame container as a stdpicture.
I have seen similar approaches for adding shapes to userforms before but the resulting shapes were liveless: always flat, not clickable and had no tab support.
I have wrapped the code in two classes CRoundButton and CRoundButtons for easy use. The classes expose intuitive Properties,Methods and a Click event + Tab functionality.
One limitation is that you cannot add the buttons in separate parent containers. In other words, if you decide to add the buttons to the userform, you cannot add some of them to a frame and vice versa. This is due to an annoying bug in the MSForms control .
Workbook Example:
Round3D_Buttons.xlsm
Here is a preview :
1- CRoundButton Class code:
VBA Code:
Option Explicit
Private Enum eBevelTopType
BevelConvex = MsoBevelType.msoBevelConvex
BevelHardEdge = MsoBevelType.msoBevelHardEdge
End Enum
Private Type BUTTON_PROPERTIES
Name As String
Parent As Object
TabIndex As Long
Left As Single
Top As Single
Width As Single
Height As Single
Caption As String
BackColor As Long
FontColor As Long
FontBold As Boolean
FontName As String
FontSize As Long
End Type
Private Type RGB
R As Byte
G As Byte
b As Byte
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 GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
Size As Long
Type As Long
#If Win64 Then
hPic As LongLong
hPal As LongLong
#Else
hPic As Long
hPal As Long
#End If
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As Any, RefIID As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As LongPtr, ByVal lpszName As String, ByVal lType As Long, ByVal cxWidth As Long, ByVal cyHeight As Long, ByVal fuLoad As Long) As Long
Private Declare PtrSafe Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare PtrSafe Function ApiGetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) 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 TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
Private Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
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 SetWindowRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDc As LongPtr, ByVal x As Long, ByVal Y As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (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 CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function Arc Lib "gdi32" (ByVal hDc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) 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
#Else
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As Any, RefIID As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpszName As String, ByVal lType As Long, ByVal cxWidth As Long, ByVal cyHeight As Long, ByVal fuLoad As Long) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function ApiGetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDc As Long, ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function Arc Lib "gdi32" (ByVal hDc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 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
#End If
Public Event Click()
Private WithEvents oFrame As MSForms.Frame
Private tButtonProperties As BUTTON_PROPERTIES
Private IButtonPressedPic As stdole.IPicture, IButtonRelasedPic As stdole.IPicture
Private IButtonActiveRelasedPic As stdole.IPicture
Private Const HIDDEN_SHAPES_HOLDER_SHEET = "TempDrawingSheet" '<< Change hidden sheet name as required.
'_______________________________________ Props And Methods ____________________________________________
Public Property Get Parent() As Object
Set Parent = tButtonProperties.Parent
End Property
Public Property Get Name() As String
Name = tButtonProperties.Name
End Property
Public Property Get TabIndex() As Long
TabIndex = tButtonProperties.TabIndex
End Property
Public Property Let TabIndex(ByVal vNewValue As Long)
tButtonProperties.TabIndex = vNewValue
End Property
Public Property Get FontName() As String
FontName = tButtonProperties.FontName
End Property
Public Property Let FontName(ByVal vNewValue As String)
tButtonProperties.FontName = vNewValue
End Property
Public Property Get Left() As Single
Left = tButtonProperties.Left
End Property
Public Property Get Top() As Single
Top = tButtonProperties.Top
End Property
Public Property Get Width() As Single
Width = tButtonProperties.Width
End Property
Public Property Get Height() As Single
Height = tButtonProperties.Height
End Property
Public Property Get Caption() As String
Caption = tButtonProperties.Caption
End Property
Public Property Let Caption(ByVal vNewValue As String)
tButtonProperties.Caption = vNewValue
End Property
Public Property Get FontColor() As Long
FontColor = tButtonProperties.FontColor
End Property
Public Property Let FontColor(ByVal vNewValue As Long)
tButtonProperties.FontColor = vNewValue
End Property
Public Property Get FontSize() As Long
FontSize = tButtonProperties.FontSize
End Property
Public Property Let FontSize(ByVal vNewValue As Long)
tButtonProperties.FontSize = vNewValue
End Property
Public Property Get FontBold() As Boolean
FontBold = tButtonProperties.FontBold
End Property
Public Property Let FontBold(ByVal vNewValue As Boolean)
tButtonProperties.FontBold = vNewValue
End Property
Public Property Get BackColor() As Long
BackColor = tButtonProperties.BackColor
End Property
Public Property Let BackColor(ByVal vNewValue As Long)
Dim lNewColor As Long
Call TranslateColor(vNewValue, 0, lNewColor)
tButtonProperties.BackColor = lNewColor
End Property
Public Property Get FrameContainer() As MSForms.Frame
Set FrameContainer = oFrame
End Property
Public Sub Init( _
ByVal Name As String, _
ByVal Parent As Object, _
ByVal Left As Single, _
ByVal Top As Single, _
ByVal Width As Single, _
ByVal Height As Single _
)
With tButtonProperties
.Name = Name
Set .Parent = Parent
.Left = Left
.Top = Top
.Width = Width
.Height = Height
End With
Set oFrame = Parent.Controls.Add("Forms.Frame.1")
SetControlEvents(oFrame) = True
With oFrame
.Left = Left: .Top = Top
.Width = Width: .Height = Height
.BorderStyle = fmBorderStyleSingle
.BorderStyle = fmBorderStyleNone
.Caption = ""
End With
End Sub
Public Sub ShowButton()
If Not oFrame Is Nothing Then
oFrame.TabIndex = tButtonProperties.TabIndex
'Button Pressed.
Call CreateAndCopyShape(BevelHardEdge, False)
Call DrawOnClipboardDib(BevelHardEdge, False)
'Button released and active.
Call CreateAndCopyShape(BevelConvex, True)
Call DrawOnClipboardDib(BevelConvex, True)
'Button released and not active.
Call CreateAndCopyShape(BevelConvex, False)
Call DrawOnClipboardDib(BevelConvex, False)
End If
End Sub
'_____________________________________________ Button Events ______________________________________________________
Private Sub oFrame_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
If IsCursorOverButton Then
Set oFrame.Picture = IButtonPressedPic
End If
End Sub
Private Sub oFrame_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
If IsCursorOverButton Then
Set oFrame.Picture = IButtonActiveRelasedPic
End If
End Sub
Private Sub oFrame_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = VBA.vbKeyReturn Then
RaiseEvent Click
End If
End Sub
Private Sub oFrame_Click()
If IsCursorOverButton Then
RaiseEvent Click
End If
End Sub
Public Sub OnEnter_DO_NOT_USE()
'Attribute OnEnter_DO_NOT_USE.VB_UserMemId = &H80018202
Set oFrame.Picture = IButtonActiveRelasedPic
End Sub
Public Sub OnExit_DO_NOT_USE(ByVal Cancel As MSForms.ReturnBoolean)
'Attribute OnExit_DO_NOT_USE.VB_UserMemId = &H80018203
Set oFrame.Picture = IButtonRelasedPic
End Sub
'___________________________________________ Helper Routines __________________________________________________
Private Property Let SetControlEvents(ByVal Frame As MSForms.Frame, ByVal SetEvents As Boolean)
Const S_OK = &H0
Dim tIID As GUID
Static lCookie As Long
Set oFrame = Frame
If IIDFromString(StrPtr("{00020400-0000-0000-C000-000000000046}"), tIID) = S_OK Then
Call ConnectToConnectionPoint(Me, tIID, SetEvents, Frame, lCookie)
If lCookie Then
Debug.Print "Connection set for: " & Frame.Name
Else
Debug.Print "Connection failed for: " & Frame.Name
End If
End If
End Property
Private Sub DrawOnClipboardDib(ByVal BevelType As eBevelTopType, Optional ByVal bActive As Boolean)
#If Win64 Then
Dim hFrame As LongLong
Dim hDib As LongLong, hPrevDIB As LongLong
Dim hPen As LongLong, hPrevPen As LongLong
Dim hDc As LongLong, hMemDc As LongLong
#Else
Dim hFrame As Long
Dim hDib As Long, hPrevDIB As Long
Dim hPen As Long, hPrevPen As Long
Dim hDc As Long, hMemDc As Long
#End If
Const CF_DIB = 8
Const PS_DOT = 2
Dim tBMIH As BITMAPINFOHEADER
Dim tRoundRect As RECT
Dim p1 As POINTAPI, p2 As POINTAPI
Dim bDIBData() As Byte
Dim lWidth As Long, lHeight As Long
If Not GetClipData(CF_DIB, bDIBData) Then
' MsgBox "Unable to get DIB data from clipboard."
Exit Sub
End If
hDib = GetDIBHandle(bDIBData)
Call ApiGetObject(hDib, LenB(tBMIH), tBMIH)
lWidth = tBMIH.biWidth: lHeight = Abs(tBMIH.biHeight)
If BevelType = BevelHardEdge Or (BevelType = BevelConvex And bActive) Then
hDc = GetDC(0)
hMemDc = CreateCompatibleDC(hDc)
hPrevDIB = SelectObject(hMemDc, hDib)
Call SetRect(tRoundRect, PTtoPX(Me.Left, False), PTtoPX(Me.Top, True), _
PTtoPX((Me.Width + Me.Left), False), PTtoPX((Me.Height + Me.Top), True))
Call IUnknown_GetWindow(oFrame, VarPtr(hFrame))
With tRoundRect
hPen = CreatePen(PS_DOT, 1, vbBlack)
hPrevPen = SelectObject(hMemDc, hPen)
Call Arc(hMemDc, 18, 18, lWidth - 18, lHeight - 18, 0, 0, 0, 0)
End With
Set IButtonActiveRelasedPic = CreateIPicture(hDib, BevelType)
Set oFrame.Picture = CreateIPicture(hDib, BevelType)
Call SelectObject(hMemDc, hPrevDIB)
Call SelectObject(hMemDc, hPrevPen)
Call DeleteObject(hPen)
Call DeleteDC(hMemDc)
Call ReleaseDC(0, hDc)
Else
Set oFrame.Picture = CreateIPicture(hDib, BevelType)
End If
Call DeleteObject(hDib)
End Sub
Private Function GetClipData(ByVal lFormat As Long, baData() As Byte) As Boolean
#If Win64 Then
Dim hMem As LongLong
Dim lPtr As LongLong
Dim lSize As LongLong
#Else
Dim hMem As Long
Dim lPtr As Long
Dim lSize As Long
#End If
If IsClipboardFormatAvailable(lFormat) = 0 Then
' MsgBox "CF_DIB Format not found in the clipboard."
Exit Function
End If
If OpenClipboard(0) = 0 Then
MsgBox "Unable to open the clipboard."
Exit Function
End If
hMem = GetClipboardData(lFormat)
lPtr = GlobalLock(hMem)
lSize = GlobalSize(hMem)
If lSize > 0 Then
ReDim baData(0 To CLng(lSize) - 1) As Byte
Call CopyMemory(baData(0), ByVal lPtr, lSize)
Else
baData = vbNullString
End If
Call GlobalUnlock(hMem)
Call CloseClipboard
GetClipData = True
End Function
#If Win64 Then
Private Function GetDIBHandle(baData() As Byte) As LongLong
#Else
Private Function GetDIBHandle(baData() As Byte) As Long
#End If
Const IMAGE_BITMAP = 0
Const LR_LOADFROMFILE = &H10
Const LR_CREATEDIBSECTION = &H2000
Dim baHeader() As Byte
Dim sFile As String
sFile = String$(1000, 0)
Call GetTempFileName(Environ$("TEMP"), "test", 0, sFile)
sFile = Left$(sFile, InStr(sFile, vbNullChar) - 1)
ReDim baHeader(0 To 13) As Byte
Call CopyMemory(baHeader(0), &H4D42, 2) '--- "BM"
Call CopyMemory(baHeader(2), UBound(baHeader) + 1 + UBound(baData) + 1, 8)
WriteBinaryFile sFile, baHeader, baData
GetDIBHandle = LoadImage(0, sFile, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
Kill sFile
End Function
'
Private Sub WriteBinaryFile(sFile As String, baHeader() As Byte, baBuffer() As Byte)
Dim nFile As Integer
nFile = FreeFile
Open sFile For Binary Access Write Shared As nFile
If UBound(baHeader) >= 0 Then
Put nFile, , baHeader
End If
If UBound(baBuffer) >= 0 Then
Put nFile, , baBuffer
End If
Close nFile
End Sub
#If Win64 Then
Private Function CreateIPicture( _
ByVal hDib As LongLong, _
ByVal BevelType As eBevelTopType _
) As IPicture
Dim hBmp As LongLong
#Else
Private Function CreateIPicture( _
ByVal hDib As Long, _
ByVal BevelType As eBevelTopType _
) As IPicture
Dim hBmp As Long
#End If
Const IMAGE_BITMAP = 0
Const LR_COPYDELETEORG = &H8
Const PICTYPE_BITMAP = 1
Const S_OK = &H0&
Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
Dim iPic As IPicture
Dim lRet As Long
hBmp = CopyImage(hDib, IMAGE_BITMAP, 0, 0, LR_COPYDELETEORG)
Call DeleteObject(hDib)
If hBmp Then
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hBmp
.hPal = 0
End With
lRet = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, iPic)
If lRet = S_OK Then
Set CreateIPicture = iPic
If BevelType = msoBevelHardEdge Then
Set IButtonPressedPic = iPic
Else
Set IButtonRelasedPic = iPic
End If
End If
End If
End Function
Private Function SheetsExists(ByVal Sh As Worksheet) As Boolean
Dim oHiddenSheet As Worksheet
On Error Resume Next
Set oHiddenSheet = Sh
SheetsExists = Not CBool(oHiddenSheet Is Nothing)
On Error GoTo 0
End Function
Private Sub CreateAndCopyShape(ByVal BevelType As eBevelTopType, Optional ByVal bSelected As Boolean)
Const BEVEL_INSERT = 10 '<< Change as required.
Const BEVEL_DEPTH = 6 '<< Change as required.
Const RGN_AND = 1
#If Win64 Then
Dim hFrame As LongLong, hRectRgn As LongLong, hEllipRgn As LongLong
#Else
Dim hFrame As Long, hRectRgn As Long, hEllipRgn As Long
#End If
Dim tFrameRect As RECT, p1 As POINTAPI, p2 As POINTAPI
Dim oShape As Shape
Dim tRGB As RGB
Dim oHiddenSheet As Worksheet
Dim bWorkbookProtected As Boolean
On Error Resume Next
If Sheets(HIDDEN_SHAPES_HOLDER_SHEET) Is Nothing Then
Set oHiddenSheet = Sheets.Add(After:=Sheets(Sheets.Count))
oHiddenSheet.Visible = xlSheetVeryHidden
oHiddenSheet.Name = HIDDEN_SHAPES_HOLDER_SHEET
End If
If Not SheetsExists(Sheets(HIDDEN_SHAPES_HOLDER_SHEET)) Then
bWorkbookProtected = ThisWorkbook.ProtectStructure
MsgBox "Adding the [" & _
HIDDEN_SHAPES_HOLDER_SHEET & "] sheet failed !" & vbNewLine & vbNewLine & _
IIf(bWorkbookProtected, "Unprotect and try again.", ""), vbCritical, "Error."
End
End If
On Error GoTo 0
With Me
Set oShape = Sheets(HIDDEN_SHAPES_HOLDER_SHEET).Shapes.AddShape _
(msoShapeOval, .Left, .Top, .Width - 6, .Height - 6)
End With
With oShape.Fill
tRGB = ColorToRGB(Me.BackColor)
.ForeColor.RGB = RGB(tRGB.R, tRGB.G, tRGB.b)
.Solid
End With
With oShape.ThreeD
If BevelType = BevelConvex Then
.BevelTopType = msoBevelConvex
.BevelTopDepth = BEVEL_DEPTH
If bSelected Then
.BevelTopDepth = 100
.LightAngle = 100
End If
Else
.BevelTopType = msoBevelHardEdge
.BevelTopDepth = BEVEL_DEPTH
End If
If Me.Width <= 50 Or Me.Height <= 50 Then
.BevelTopInset = 6
Else
.BevelTopInset = BEVEL_INSERT
End If
End With
With oShape.TextFrame2
.VerticalAnchor = msoAnchorMiddle
.TextRange.Characters.Text = Me.Caption
With .TextRange.Characters.ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
End With
With oShape.TextFrame2.TextRange.Font
.Bold = IIf(Me.FontBold, msoTrue, msoFalse)
.Fill.Visible = msoTrue
tRGB = ColorToRGB(Me.FontColor)
.Fill.ForeColor.RGB = RGB(tRGB.R, tRGB.G, tRGB.b)
.Fill.Transparency = 0
.Fill.Solid
.Size = IIf(Me.FontSize = 0, 11, Me.FontSize)
.Name = IIf(Len(Me.FontName) = 0, "Calibri", Me.FontName)
End With
With oShape
On Error Resume Next
.CopyPicture xlScreen, xlBitmap
DoEvents
.CopyPicture xlScreen, xlBitmap
.Delete
On Error GoTo 0
End With
Call IUnknown_GetWindow(oFrame, VarPtr(hFrame))
Call GetWindowRect(hFrame, tFrameRect)
With tFrameRect
p1.x = .Left + 3
p1.Y = .Top + 3
p2.x = .Right - 3
p2.Y = .Bottom - 3
End With
Call ScreenToClient(hFrame, p1)
Call ScreenToClient(hFrame, p2)
hRectRgn = CreateRectRgn(p1.x, p1.Y, p2.x, p2.Y)
hEllipRgn = CreateEllipticRgn(p1.x, p1.Y, p2.x, p2.Y)
Call CombineRgn(hEllipRgn, hEllipRgn, hRectRgn, RGN_AND)
Call SetWindowRgn(hFrame, hEllipRgn, True)
Call DeleteObject(hRectRgn)
Call DeleteObject(hEllipRgn)
End Sub
Private Function IsCursorOverButton() As Boolean
#If Win64 Then
Dim hFrame As LongLong, hDc As LongLong
#Else
Dim hFrame As Long, hDc As Long
#End If
Dim tCurPos As POINTAPI, p As POINTAPI
Dim lNewColor As Long
Call IUnknown_GetWindow(oFrame, VarPtr(hFrame))
hDc = GetDC(hFrame)
Call GetCursorPos(tCurPos)
p.x = tCurPos.x
p.Y = tCurPos.Y
Call ScreenToClient(hFrame, p)
Call TranslateColor(oFrame.Parent.BackColor, 0, lNewColor)
If GetPixel(hDc, p.x, p.Y) <> lNewColor Then
IsCursorOverButton = True
End If
Call ReleaseDC(hFrame, hDc)
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(0)
lDPI(0) = GetDeviceCaps(hDc, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(hDc, LOGPIXELSY)
hDc = ReleaseDC(0, hDc)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX(Points As Single, bVert As Boolean) As Single
Const POINTS_PER_INCH = 72
PTtoPX = (Points * ScreenDPI(bVert) / POINTS_PER_INCH) * tButtonProperties.Parent.Zoom / 100
End Function
Private Function ColorToRGB(ByVal col As Long) As RGB
ColorToRGB.R = &HFF& And col
ColorToRGB.G = (&HFF00& And col) \ 256
ColorToRGB.b = (&HFF0000 And col) \ 65536
End Function2- CRoundButtons Collection Class Code:
VBA Code:
Option Explicit
Private oButtonsCol As Collection
Private oParentsCol As Collection
Private oParent As Object
Public Function Add( _
ByVal Name As String, _
ByVal ParentContainer As Object, _
ByVal Left As Single, _
ByVal Top As Single, _
ByVal Width As Single, _
ByVal Height As Single _
) As CRoundButton
Dim oButton As CRoundButton
Set oParent = ParentContainer
If IsButtonOffScreen(Left, Top, Width, Height) Then
Err.Raise Number:=vbObjectError + 513, _
Description:="[" & Name & "] is fully or partially outside of its container !!" & _
vbNewLine & vbNewLine & _
"Please, adjust the button location\dimensions so that it fits entirely inside its parent container."
End If
If oButtonsCol Is Nothing Then
Set oButtonsCol = New Collection
Set oParentsCol = New Collection
End If
On Error Resume Next
oParentsCol.Add ParentContainer, ParentContainer.Name
If Err.Number = 0 And oParentsCol.Count > 1 Then
Err.Clear
'Due to an annoying BUG in the MSForms controls, we cannot nest
'frames & multpages @runtime within diff frames & multpages.
MsgBox "All Buttons MUST have a common Parent container." & vbNewLine & vbNewLine & _
"Set the Parent of all the buttons to a shared container control " & _
"(such as a Frame) or place them directly on the userform.", vbCritical, "Error!"
End
End If
On Error GoTo 0
Set oButton = New CRoundButton
oButtonsCol.Add oButton, Name
Set Add = oButton
Call oButton.Init( _
Name, _
ParentContainer, _
Left, _
Top, _
Width, _
Height _
)
End Function
Public Sub Remove(ByVal Index As Variant)
oParent.Controls.Remove oButtonsCol(Index).FrameContainer.Name
oButtonsCol.Remove Index
End Sub
Public Property Get Item(ByVal Index As Variant) As CRoundButton
Set Item = oButtonsCol(Index)
End Property
Public Property Get Count() As Long
Count = oButtonsCol.Count
End Property
Private Function IsButtonOffScreen( _
ByVal Left As Single, _
ByVal Top As Single, _
ByVal Width As Single, _
ByVal Height As Single _
) As Boolean
If Left < 0 Or Top < 0 Or Width + Left > oParent.InsideWidth _
Or Height + Top > oParent.InsideHeight Then
IsButtonOffScreen = True
End If
End Function
Private Sub Class_Terminate()
Dim i As Long
For i = Count To 1 Step -1
oButtonsCol.Remove oButtonsCol(i).Name
Next
Set oButtonsCol = Nothing
End Sub3- Usage example in a UserForm Module:
VBA Code:
Option Explicit
Private RoundButtons As New CRoundButtons
Private WithEvents Button1 As CRoundButton
Private WithEvents Button2 As CRoundButton
Private WithEvents Button3 As CRoundButton
Private Sub UserForm_Initialize()
Set RoundButtons = New CRoundButtons
Set Button1 = RoundButtons.Add("Button1", Me.Frame1, 10, 10, 80, 80)
With Button1
.Caption = "A"
.BackColor = 4648156
.FontColor = vbRed
.FontBold = 0
.FontSize = 40
.TabIndex = 0
.ShowButton
End With
Set Button2 = RoundButtons.Add("Button2", Me.Frame1, 110, 10, 80, 80)
With Button2
.Caption = "B"
.BackColor = vbWhite
.FontSize = 40
.TabIndex = 1
.ShowButton
End With
''
Set Button3 = RoundButtons.Add("Button3", Me.Frame1, 210, 10, 80, 80)
With Button3
.Caption = "C"
.BackColor = 15327561
.FontColor = vbYellow
.FontSize = 40
.TabIndex = 2
.ShowButton
End With
End Sub
Private Sub Button1_Click()
MsgBox "You Clicked [" & Button1.Name & "]"
End Sub
Private Sub Button2_Click()
MsgBox "You Clicked [" & Button2.Name & "]"
End Sub
Private Sub Button3_Click()
MsgBox "You Clicked [" & Button3.Name & "]"
End Sub
Private Sub RemoveButtons_Click()
Dim i As Long
For i = RoundButtons.Count To 1 Step -1
RoundButtons.Remove i
Next
End SubRegards.
