Create a Ribbon Radiobuttons Group with PNG Images

Read how to Create a Ribbon Radiobuttons Group with PNG Images by Mark Kubiszyn · 2013 & 2016 (32bit & 64bit)

#back



GDI Method

- Download the Ribbon Radiobuttons GDI File Example


There isn't a Radiobutton Group available for the Ribbon, nor is there an easy way of getting transparent images on the Ribbon (you can use BMP images which can be stored and retrived using UserForm Images, however you cannot use the Alpha value to make them transparent when loaded into an Image and .CUR or .ICO can be loaded but not rendered onto the Ribbon). In fact there are a couple of methods that do work. The image retrival method using the GDI is well known and I implement the GDI method here. With my XML and Callback Code you can have unlimited numbers of Radiobuttons that update their respective settings in a Worksheet - ideal if you are planning an AddIn which is what this should be used for. I store my images internally, compressing them within the Worksheet itself using Custom Properties, extract them to the users Temp Folder and then read them back in using GDI Functions with API's. I use purchased transparent, PNG images, however you can substitute these for your own if preferred. All of the Code is given free to load in your own two images

This is a Screen Shot of the Radiobuttons displayed on the Ribbon:

Radiobuttons GDI Screen Shot

This is the XML Markup used to create the Ribbon - very simple, use a Ribbon Editor to change like the Custom UI Editor by Microsoft - notice that all of the Radiobuttons which are Button Controls use the same Callbacks:


  
    
      
        
          

This is the Code that extracts and writes out the images which is stored in the ThisWorkbook Code Module:

Option Explicit

'¬ Workbook_Open, copies the stored images to the Temp Folder to be loaded by GDI
Private Sub Workbook_Open()
   On Error Resume Next
   Dim ImageFile() As Byte
   Dim F As Long
   ImageFile() = StrConv(Settings.CustomProperties(1), vbFromUnicode)
   F = FreeFile: Open CStr(Environ$("Temp") & Application.PathSeparator & RADIOBUTTON_OFF_FILENAME) For Binary Access Write As #F: Put #F, , ImageFile: Close #F
   ImageFile() = StrConv(Settings.CustomProperties(2), vbFromUnicode)
   F = FreeFile: Open CStr(Environ$("Temp") & Application.PathSeparator & RADIOBUTTON_ON_FILENAME) For Binary Access Write As #F: Put #F, , ImageFile: Close #F
   On Error GoTo 0
End Sub

'¬ Workbook_BeforeClose, removes the copied images from the Temp Folder
Private Sub Workbook_BeforeClose(Cancel As Boolean)
   On Error Resume Next
   Kill CStr(Environ$("Temp") & Application.PathSeparator & RADIOBUTTON_OFF_FILENAME)
   Kill CStr(Environ$("Temp") & Application.PathSeparator & RADIOBUTTON_ON_FILENAME)
   On Error GoTo 0
End Sub

This is the Code that handles the Ribbon Callbacks including the Subroutines to store the PNG images - notice all of the Radiobuttons all use the same RadiobuttonsOnAction, RadiobuttonsGetLabel and RadiobuttonsGetImage Subroutines. The Code below has been checked using Rubberduck and includes the Fix for a loss of Ribbon Pointer so that you can Reset Code and the Radiobuttons will still work ie. during writing and testing of the Ribbon:


' RIBBON RADIOBUTTON EXAMPLE
' © Copyright/Author:
' Mark Kubiszyn. All Rights Reserved
' Website/Follow:
' https://www.kubiszyn.co.uk/
' https://www.facebook.com/Kubiszyn.co.uk/
'
' License:
' This Software is released under an MIT License (MIT)
' https://www.kubiszyn.co.uk/license.html
'
' Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files
' (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge,
' publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so,
' subject to the following conditions:
'
' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
' MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR
' ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
' SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE

Option Explicit

#If VBA7 And Win64 Then
   ' 64bit API Declarations
   Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
   Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal HWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
   ' 32bit API Declarations
   Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
   Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal HWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

'@Ignore EncapsulatePublicField
Public RibbonUserInterface As IRibbonUI
' local storage image names
Private Const RADIOBUTTON_OFF As String = "Radiobutton_Image_Off"
Private Const RADIOBUTTON_ON As String = "Radiobutton_Image_On"
Private Const RADIOBUTTON_OFF_PATH As String = "C:\Archive\Working\Software\Ribbon Radiobutton\radio_off.png"
Private Const RADIOBUTTON_ON_PATH As String = "C:\Archive\Working\Software\Ribbon Radiobutton\radio_on.png"
' local vars used for the Label and Pressed values
Private Const LABEL_COLUMN As Long = 1
Private Const PRESSED_COLUMN As Long = 2
' global image Filenames
Public Const RADIOBUTTON_OFF_FILENAME As String = "radio_off.png"
Public Const RADIOBUTTON_ON_FILENAME As String = "radio_on.png"

'¬ Callback when the Ribbon is Loaded the first time.  implement a Ribbon retrieval fix - useful when writing/debugging Code
Public Sub ribbonLoaded(ByRef Ribbon As IRibbonUI)
   ' Store pointer to IRibbonUI
   Set RibbonUserInterface = Ribbon
   ' Row & Column specify the position of the Pointer value
   Settings.Cells(1, 26).Value = ObjPtr(Ribbon)
End Sub

'¬ generic Ribbon Functions to help restore the Ribbon Pointer
#If VBA7 Then
   '@Ignore HungarianNotation
Public Function GetRibbon(ByVal lRibbonPointer As LongPtr) As Object
#Else
Public Function GetRibbon(ByVal lRibbonPointer As Long) As Object
#End If
'@Ignore HungarianNotation
Dim objRibbon As Object
CopyMemory objRibbon, lRibbonPointer, LenB(lRibbonPointer)
Set GetRibbon = objRibbon
Set objRibbon = Nothing
End Function

'¬ UpdateRibbonPtr, restores the Ribbon pointer
Public Sub UpdateRibbonPtr()
   If RibbonUserInterface Is Nothing Then
      ' Row & Column specify the position of the Pointer value
      Set RibbonUserInterface = GetRibbon(Settings.Cells(1, 26).Value)
      RibbonUserInterface.Invalidate
   End If
End Sub

'¬ Callback for all of the Radiobuttons, OnAction
Public Sub RadiobuttonsOnAction(ByRef control As IRibbonControl)
   UpdateRibbonPtr
   ' Column Offset 2 is the PRESSED Boolean value ie. True, False
   With Settings
      .Cells.Range(.Cells(1, 3).Offset(1, 0), .Cells(1, 3).End(xlDown)).Value2 = False
      .Cells(1, 1).Offset(Application.WorksheetFunction.Match(control.ID, .Cells.Range(.Cells(1, 1).Offset(1, 0), .Cells(1, 1).End(xlDown)), 0), PRESSED_COLUMN).Value2 = True
   End With
   RibbonUserInterface.Invalidate
End Sub

'¬ Callback for all of the Radiobuttons, GetLabel
Public Sub RadiobuttonsGetLabel(ByRef control As IRibbonControl, ByRef label As Variant)
   UpdateRibbonPtr
   ' Column Offset 1 is the LABEL value ie. Radiobutton1, Radiobutton2 etc.
   With Settings
      label = .Cells(1, 1).Offset(Application.WorksheetFunction.Match(control.ID, .Cells.Range(.Cells(1, 1).Offset(1, 0), .Cells(1, 1).End(xlDown)), 0), LABEL_COLUMN)
   End With
End Sub

'¬ Callback for all of the Radiobuttons, GetImage
Public Sub RadiobuttonsGetImage(ByRef control As IRibbonControl, ByRef img As Variant)
   UpdateRibbonPtr
   ' Column Offset 2 is the PRESSED Boolean value ie. True, False
   With Settings
      If .Cells(1, 1).Offset(Application.WorksheetFunction.Match(control.ID, .Cells.Range(.Cells(1, 1).Offset(1, 0), .Cells(1, 1).End(xlDown)), 0), PRESSED_COLUMN) Then
         Set img = LoadPictureGDI(Environ$("Temp") & Application.PathSeparator & RADIOBUTTON_ON_FILENAME) 'Radiobuttons.OnPicture.Picture
      Else
         Set img = LoadPictureGDI(Environ$("Temp") & Application.PathSeparator & RADIOBUTTON_OFF_FILENAME) 'Radiobuttons.OffPicture.Picture
      End If
   End With
End Sub

'¬ Supporting Code used to setup this Workbook for the Icon storage CustomProperties
Public Sub Setup()
   ' embed Icons
   EmbedImages RADIOBUTTON_OFF, RADIOBUTTON_OFF_PATH
   EmbedImages RADIOBUTTON_ON, RADIOBUTTON_ON_PATH
   ' debug
   ReadCustomProperties RADIOBUTTON_OFF
   ReadCustomProperties RADIOBUTTON_ON
End Sub

'¬ EmbedImages, embeds the Radiobutton images into a Worksheet
Private Sub EmbedImages(ByVal ImageName As String, ByVal ImagePath As String)
   Dim FileContent As String
   Dim EmbedFile As Long
   EmbedFile = FreeFile
   Open ImagePath For Binary Access Read As #EmbedFile
   FileContent = Input$(LOF(EmbedFile), EmbedFile)
   Close #EmbedFile
   Settings.CustomProperties.Add ImageName, FileContent
End Sub

'¬ ReadCustomProperties, prints any Dialog Custom Properties to the Immediate Window
Private Sub ReadCustomProperties(ByVal ImageName As String)
   ' vars
   Dim ObjectProperty As CustomProperty
   ' only read Custom Properties installed by InternalStorageName
   For Each ObjectProperty In Settings.CustomProperties
      If ObjectProperty.Name = ImageName Then Debug.Print ObjectProperty
   Next ObjectProperty
End Sub

'¬ DeleteCustomProperties, deletes any Dialog Custom Properties
Private Sub DeleteCustomProperties()
   ' vars
   Dim ObjectProperty As CustomProperty
   ' only read Custom Properties installed by InternalStorageName
   For Each ObjectProperty In Settings.CustomProperties
      ObjectProperty.Delete
   Next ObjectProperty
End Sub

This is the Code for the GDI to create the IPicture Object:

Option Explicit
'This module provides a LoadPictureGDI function, which can be used instead of VBA's LoadPicture, _
to load a wide variety of image types from disk - including png.

'The png format is used in Office 2007-2010 to provide images that include an alpha channel for each pixel's transparency

'Author:    Stephen Bullen
'Date:      31 October, 2006
'Email:     stephen@oaltd.co.uk

'Updated :  30 December, 2010
'By :       Rob Bovey
'Reason :   Also working now in the 64 bit version of Office 2010

'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
   Data1 As Long
   '@Ignore IntegerDataType
   Data2 As Integer
   '@Ignore IntegerDataType
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

#If VBA7 Then
   'Declare a UDT to store the bitmap information
Private Type PICTDESC
   Size As Long
   '@Ignore KeywordsUsedAsMember
   Type As Long
   hPic As LongPtr
   hPal As LongPtr
End Type

'Declare a UDT to store the GDI+ Startup information
Private Type GdiplusStartupInput
   GdiplusVersion As Long
   DebugEventCallback As LongPtr
   SuppressBackgroundThread As Long
   SuppressExternalCodecs As Long
End Type

'Windows API calls into the GDI+ library
Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (ByRef token As LongPtr, ByRef inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As LongPtr, ByRef bitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As LongPtr, ByRef hbmReturn As LongPtr, ByVal background As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal image As LongPtr) As Long
Private Declare PtrSafe Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr)
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (ByRef PicDesc As PICTDESC, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As Long, ByRef IPic As IPicture) As Long
#Else
'Declare a UDT to store the bitmap information
Private Type PICTDESC
   Size As Long
   Type As Long
   hPic As Long
   hPal As Long
End Type

'Declare a UDT to store the GDI+ Startup information
Private Type GdiplusStartupInput
   GdiplusVersion As Long
   DebugEventCallback As Long
   SuppressBackgroundThread As Long
   SuppressExternalCodecs As Long
End Type

'Windows API calls into the GDI+ library
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap 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 GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long
Private Declare Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As Long)
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
#End If

' Procedure:    LoadPictureGDI
' Purpose:      Loads an image using GDI+
' Returns:      The image as an IPicture Object
'@Ignore HungarianNotation
Public Function LoadPictureGDI(ByVal sFilename As String) As IPicture
   Dim uGdiInput As GdiplusStartupInput
   '@Ignore HungarianNotation
   Dim lResult As Long
   #If VBA7 Then
      '@Ignore VariableNotAssigned
      Dim hGdiPlus As LongPtr
      '@Ignore VariableNotAssigned
      Dim hGdiImage As LongPtr
      '@Ignore VariableNotAssigned
      Dim hBitmap As LongPtr
   #Else
      Dim hGdiPlus As Long
      Dim hGdiImage As Long
      Dim hBitmap As Long
   #End If
   'Initialize GDI+
   uGdiInput.GdiplusVersion = 1
   '@Ignore UnassignedVariableUsage
   lResult = GdiplusStartup(hGdiPlus, uGdiInput)
   If lResult = 0 Then
      'Load the image
      '@Ignore UnassignedVariableUsage
      lResult = GdipCreateBitmapFromFile(StrPtr(sFilename), hGdiImage)
      If lResult = 0 Then
         'Create a bitmap handle from the GDI image
         '@Ignore UnassignedVariableUsage
         lResult = GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, 0)
         'Create the IPicture object from the bitmap handle
         '@Ignore UnassignedVariableUsage
         Set LoadPictureGDI = CreateIPicture(hBitmap)
         'Tidy up
         '@Ignore UnassignedVariableUsage
         GdipDisposeImage hGdiImage
      End If
      'Shutdown GDI+
      '@Ignore UnassignedVariableUsage
      GdiplusShutdown hGdiPlus
   End If
End Function

' Procedure:    CreateIPicture
' Purpose:      Converts a image handle into an IPicture object.
' Returns:      The IPicture object
#If VBA7 Then
Private Function CreateIPicture(ByVal hPic As LongPtr) As IPicture
#Else
Private Function CreateIPicture(ByVal hPic As Long) As IPicture
#End If
'@Ignore HungarianNotation
Dim lResult As Long
Dim uPicInfo As PICTDESC
Dim IID_IDispatch As GUID
'@Ignore VariableNotAssigned
Dim IPic As IPicture
'OLE Picture types
Const PICTYPE_BITMAP = 1
'Create the Interface GUID (for the IPicture interface)
With IID_IDispatch
   .Data1 = &H7BF80980
   .Data2 = &HBF32
   .Data3 = &H101A
   .Data4(0) = &H8B
   .Data4(1) = &HBB
   .Data4(2) = &H0
   .Data4(3) = &HAA
   .Data4(4) = &H0
   .Data4(5) = &H30
   .Data4(6) = &HC
   .Data4(7) = &HAB
End With
'Fill uPicInfo with necessary parts.
With uPicInfo
   .Size = Len(uPicInfo)
   .Type = PICTYPE_BITMAP
   .hPic = hPic
   .hPal = 0
End With
'Create the Picture object.
'@Ignore AssignmentNotUsed, UnassignedVariableUsage
lResult = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
'Return the new Picture object.
'@Ignore UnassignedVariableUsage
Set CreateIPicture = IPic
End Function


Activesheet Shapes & Clipboard Method

- Download the Ribbon Radiobuttons Shapes & Clipboard File Example

The second method is to use the Clipboard to Copy the Shape images from a Worksheet and then create the IPictures required for the Ribbon and toggle them in real-time accordingly. The beauty about this method is that you can mess about with the PNG or SVG Icons for Colours etc. and just click on the Ribbon Radiobuttons to update your new Colours - cool eh? The downside is a little loss of quality I think

This is a Screen Shot of the Radiobuttons displayed on the Ribbon:

Radiobuttons Shapes & Clipboard Screen Shot

This is the Code for the Ribbon Callbacks:


' RIBBON RADIOBUTTON EXAMPLE
' © Copyright/Author:
' Mark Kubiszyn. All Rights Reserved
' Website/Follow:
' https://www.kubiszyn.co.uk/
' https://www.facebook.com/Kubiszyn.co.uk/
'
' License:
' This Software is released under an MIT License (MIT)
' https://www.kubiszyn.co.uk/license.html
'
' Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files
' (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge,
' publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so,
' subject to the following conditions:
'
' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
' MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR
' ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
' SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE

Option Explicit

#If VBA7 And Win64 Then
   ' 64bit API Declarations
   Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
   Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
   ' 32bit API Declarations
   Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
   Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal HWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

'@Ignore EncapsulatePublicField
Public RibbonUserInterface As IRibbonUI
' local vars used for the Label and Pressed values
Private Const LABEL_COLUMN As Long = 1
Private Const PRESSED_COLUMN As Long = 2

'¬ Callback when the Ribbon is Loaded the first time.  implement a Ribbon retrieval fix - useful when writing/debugging Code
Public Sub ribbonLoaded(ByRef Ribbon As IRibbonUI)
   ' Store pointer to IRibbonUI
   Set RibbonUserInterface = Ribbon
   ' Row & Column specify the position of the Pointer value
   Settings.Cells(1, 26).Value = ObjPtr(Ribbon)
End Sub

'¬ generic Ribbon Functions to help restore the Ribbon Pointer
#If VBA7 Then
   '@Ignore HungarianNotation
Public Function GetRibbon(ByVal lRibbonPointer As LongPtr) As Object
#Else
Public Function GetRibbon(ByVal lRibbonPointer As Long) As Object
#End If
'@Ignore HungarianNotation
Dim objRibbon As Object
CopyMemory objRibbon, lRibbonPointer, LenB(lRibbonPointer)
Set GetRibbon = objRibbon
Set objRibbon = Nothing
End Function

'¬ UpdateRibbonPtr, restores the Ribbon pointer
Public Sub UpdateRibbonPtr()
   If RibbonUserInterface Is Nothing Then
      ' Row & Column specify the position of the Pointer value
      Set RibbonUserInterface = GetRibbon(Settings.Cells(1, 26).Value)
      RibbonUserInterface.Invalidate
   End If
End Sub

'¬ Callback for all of the Radiobuttons, OnAction
Public Sub RadiobuttonsOnAction(ByRef control As IRibbonControl)
   UpdateRibbonPtr
   ' Column Offset 2 is the PRESSED Boolean value ie. True, False
   With Settings
      .Cells.Range(.Cells(1, 3).Offset(1, 0), .Cells(1, 3).End(xlDown)).Value2 = False
      .Cells(1, 1).Offset(Application.WorksheetFunction.Match(control.ID, .Cells.Range(.Cells(1, 1).Offset(1, 0), .Cells(1, 1).End(xlDown)), 0), PRESSED_COLUMN).Value2 = True
   End With
   RibbonUserInterface.Invalidate
End Sub

'¬ Callback for all of the Radiobuttons, GetLabel
Public Sub RadiobuttonsGetLabel(ByRef control As IRibbonControl, ByRef label As Variant)
   UpdateRibbonPtr
   ' Column Offset 1 is the LABEL value ie. Radiobutton1, Radiobutton2 etc.
   With Settings
      label = .Cells(1, 1).Offset(Application.WorksheetFunction.Match(control.ID, .Cells.Range(.Cells(1, 1).Offset(1, 0), .Cells(1, 1).End(xlDown)), 0), LABEL_COLUMN)
   End With
End Sub

'¬ Callback for all of the Radiobuttons, GetImage
Public Sub RadiobuttonsGetImage(ByRef control As IRibbonControl, ByRef img As Variant)
   UpdateRibbonPtr
   ' Column Offset 2 is the PRESSED Boolean value ie. True, False
   With Settings
      If .Cells(1, 1).Offset(Application.WorksheetFunction.Match(control.ID, .Cells.Range(.Cells(1, 1).Offset(1, 0), .Cells(1, 1).End(xlDown)), 0), PRESSED_COLUMN) Then
         Set img = PictureFromShape(Settings.Shapes("Radiobutton_on"))
      Else
         Set img = PictureFromShape(Settings.Shapes("Radiobutton_off"))
      End If
   End With
End Sub

This is the Code for the Clipboard:


' found here:
' https://answers.microsoft.com/en-us/msoffice/forum/all/picture-shapes-and-image-boxes-in-vba/3f29cbf5-4b72-49b5-887b-d5d828bd01be
' - Andreas Killer, October 19, 2013
' - Rubberducked by M P Kubiszyn 29.04.2019

Option Explicit

'@Ignore ConstantNotUsed
Private Const SRCCOPY As Long = &HCC0020
'@Ignore ConstantNotUsed
Private Const RC_PALETTE As Long = &H100
'@Ignore ConstantNotUsed
Private Const SIZEPALETTE As Long = 104
'@Ignore ConstantNotUsed
Private Const RASTERCAPS As Long = 38
Private Type PALETTEENTRY
   peRed As Byte
   peGreen As Byte
   peBlue As Byte
   peFlags As Byte
End Type

Private Type LOGPALETTE
   '@Ignore IntegerDataType
   palVersion As Integer
   '@Ignore IntegerDataType
   palNumEntries As Integer
   palPalEntry(255) As PALETTEENTRY              ' Enough for 256 colors
End Type

Private Type GUID
   Data1 As Long
   '@Ignore IntegerDataType
   Data2 As Integer
   '@Ignore IntegerDataType
   Data3 As Integer
   Data4(7) As Byte
End Type

Private Type PICTDESC
   Size As Long
   Typ As Long
   #If Win64 Then
   hPic As LongPtr
   hPal As LongPtr
   #Else
   hPic As Long
   hPal As Long
   #End If
End Type

#If VBA7 Then
   '@Ignore ImplicitByRefModifier
   Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PICDESC As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
#Else
   Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (PICDESC As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
#End If
Private Enum PictureType
   CF_BITMAP = 2
   CF_ENHMETAFILE = 14
End Enum

' api's
#If Win64 Then
   Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
   Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
   Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
   Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
   Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
   Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
   Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal imageType As Long, ByVal NewWidth As Long, ByVal NewHeight As Long, ByVal lFlags As Long) As LongPtr
#Else
   Private Declare Function CloseClipboard Lib "user32" () As Long
   Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
   Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
   Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
   Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
   Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
   Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal imageType As Long, ByVal NewWidth As Long, ByVal NewHeight As Long, ByVal lFlags As Long) As Long
#End If

Public Function PictureFromShape(ByVal S As Shape) As IPicture
   'Wandelt ein Shape über die Zwischenablage in ein Picture
   S.CopyPicture xlScreen, xlBitmap
   Set PictureFromShape = PictureFromClipboard
End Function

Public Function PictureFromClipboard() As IPicture
   'Return a bitmap or metafile picture from clipboard (type is auto detected)
   Const IMAGE_BITMAP = 0
   Const LR_COPYRETURNORG = &H4
   #If VBA7 Then
      Dim hPic As LongPtr
      Dim hCopy As LongPtr
   #Else
      Dim hPic As Long
      Dim hCopy As Long
   #End If
   Dim Result As Long
   Dim PicType As PictureType
   '@Ignore IntegerDataType
   Dim Count As Integer

   'Check if the clipboard contains a possible format
   If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
      PicType = CF_BITMAP
   ElseIf IsClipboardFormatAvailable(CF_ENHMETAFILE) <> 0 Then
      PicType = CF_ENHMETAFILE
   End If
   If PicType = 0 Then Err.Raise 70, "PictureFromClipboard", "No valid picture in " & _
   "clipboard"

   'Get access to the clipboard
   Do
      Result = OpenClipboard(0&)
      If Result <> 1 Then
         CloseClipboard
         DoEvents
         Sleep 10
      End If
      Count = Count + 1
   Loop Until Count = 10 Or Result = 1
   If Result <> 1 Then Err.Raise 70, "PictureFromClipboard", "Can not open the clipboard"

   'Get a handle to the image data
   hPic = GetClipboardData(PicType)
   If hPic = 0 Then
      CloseClipboard
      Err.Raise Err.LastDllError, "PictureFromClipboard"
   End If
   'Create our own copy of the image on the clipboard, in the appropriate format.
   If PicType = CF_BITMAP Then
      hCopy = CopyImage(hPic, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
   Else
      hCopy = CopyEnhMetaFile(hPic, vbNullString)
   End If
   If hCopy = 0 Then Err.Raise Err.LastDllError, "PictureFromClipboard"
   'Release the clipboard to other programs
   CloseClipboard
   'Convert it into a Picture object and return it
   Set PictureFromClipboard = CreatePicture(hCopy, 0, PicType)
End Function

#If VBA7 Then
Private Function CreatePicture(ByVal hPic As LongPtr, ByVal hPal As LongPtr, _
Optional ByVal PicType As PictureType = CF_BITMAP) As IPicture
#Else
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, _
Optional ByVal PicType As PictureType = CF_BITMAP) As IPicture
#End If
Const PICTYPE_BITMAP As Long = 1
Const PICTYPE_ENHMETAFILE As Long = 4
Dim IPictureIID As GUID
'@Ignore VariableNotAssigned
Dim IPic As IPicture
Dim tagPic As PICTDESC

'Fill in the IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
With IPictureIID
   .Data1 = &H7BF80980
   .Data2 = &HBF32
   .Data3 = &H101A
   .Data4(0) = &H8B
   .Data4(1) = &HBB
   .Data4(2) = &H0
   .Data4(3) = &HAA
   .Data4(4) = &H0
   .Data4(5) = &H30
   .Data4(6) = &HC
   .Data4(7) = &HAB
End With

'Set the properties on the picture object
With tagPic
   .Size = Len(tagPic)
   .hPic = hPic
   Select Case PicType
   Case CF_BITMAP
      .Typ = PICTYPE_BITMAP
      .hPal = hPal
   Case CF_ENHMETAFILE
      .Typ = PICTYPE_ENHMETAFILE
      .hPal = 0
   Case Else
      Err.Raise 51, "CreatePicture", "Invalid picture type"
   End Select
End With

'Create a picture that will delete it's bitmap when it is finished with it
'@Ignore UnassignedVariableUsage
OleCreatePictureIndirect tagPic, IPictureIID, 1, IPic
'@Ignore UnassignedVariableUsage
If IPic Is Nothing Then Err.Raise Err.LastDllError, "CreatePicture"
'@Ignore UnassignedVariableUsage
Set CreatePicture = IPic
End Function