Round Buttons on UserForm (Beveled + Clickable + Tab-able)

[Jaafar Tribak]

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:

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 Function

2- CRoundButtons Collection Class 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 Sub

3- Usage example in a UserForm Module:

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 Sub

Regards.

 

[Tom.Jones]

Thank you Jaafar.

 

[Jaafar Tribak]

Thank you Jaafar.

Thanks Tom.

Did the button borders look smooth or did they look a bit jagged when you tested the code ?

Regards.

 

[Jimmypop]

And the wizard did it again... Lol... Works awesome and will use in upcoming projects... Thanks for this...

 

[Tom.Jones]

Thanks Tom.

Did the button borders look smooth or did they look a bit jagged when you tested the code ?

Regards.

See pictures attached.

Win 64 M365 32

 

[Jaafar Tribak]

See pictures attached.
View attachment 70618View attachment 70617
Win 64 M365 32

Thanks so much Tom for posting the pictures.

The white background behind the buttons means the the Region api functions I used in the code for clipping the buttons did not work. Not sure why this is so. Maybe the machine graphics. I also don't have office 365 to test and debug.

I wrote the code in Win10 x64 excel 2016 x64 but, I also tested it in Win7 x32 excel 2007. It worked in both machines exactly the same.

One workaround I can think of that might work is to edit the image pixels\bits that correspond to white color and set those pixels to the current background color so they can blend nicely but then that would mean we can't have white buttons or have them overlapping .

 

[Jimmypop]

Mine works without the white background... Running Office 365

 

[Dan_W]

It runs a bit differently on my system. I'll try recording an animated GIF to demonstrate, but a few of the buttons will disappear all together depending on whether they have focus (from the tab) or whether I try to click on it. If I try to click on the button and they disappear, but reappear when it has focus from the tab, they will sometimes run if I press enter instead... even more bizarrely, it happens with different buttons each time that I run it. I wonder if it has something to do with my system, so will restart and try again.

For reference, I have win10 64 / Office 365 64bit

 

[Jaafar Tribak]

Mine works without the white background... Running Office 365

It is probably not due to office 365. I have done a quick search on why clipping window regions might not work. One reason has come up is aero theme but I am not sure.

Thanks.

 

[Jaafar Tribak]

It runs a bit differently on my system. I'll try recording an animated GIF to demonstrate, but a few of the buttons will disappear all together depending on whether they have focus (from the tab) or whether I try to click on it. If I try to click on the button and they disappear, but reappear when it has focus from the tab, they will sometimes run if I press enter instead... even more bizarrely, it happens with different buttons each time that I run it. I wonder if it has something to do with my system, so will restart and try again.

For reference, I have win10 64 / Office 365 64bit

Yes, I did get that issue a couple of times when first testing but it only happened a couple of times then stopped happening . I shouldn't have neglect it though..

I think the problem lies with the copying of the shapes to the clipboard repeatedly and fast. Excel can't keep up. This apparently causes the CopyPicture method of the shape to fail hence not creating all the required stdpics.

Please, try this workaround and see if brute-forcing the copying solves the problem.

Change the following code section (located in the CreateAndCopyShape SUB) from this :

With oShape
    On Error Resume Next
    .CopyPicture xlScreen, xlBitmap
    DoEvents
    .CopyPicture xlScreen, xlBitmap
    .Delete
    On Error GoTo 0
End With

To this :

With oShape
    On Error Resume Next
        Do
            Err.Clear
            DoEvents
            .CopyPicture xlScreen, xlBitmap
        Loop Until Err.Number = 0
    On Error GoTo 0
    .Delete
End With

You will also need to comment out the following code lines (in their respective routines so that the messageboxes don't get in the way ):

MsgBox "Unable to get DIB data from clipboard." and
MsgBox "Unable to open the clipboard."

Please, let me know if the above workaround works for you so I can update the uploaded workbook .

Thanks.