Propiedades de color del botón de comando de acceso, selector de color integrado

VBA

Módulo estándar

El
DiálogoColor La función utiliza la API ChooseColor.

Fue escrito originalmente por Daniel Pineault, modificado por Mike Wolfe y luego por mí.

'  bas_DialogColor_Daniel_Mike
'code from NoLongerSet by Mike Wolfe
'  
'references DevHut by Daniel Pineault
'  
'-----------------------------------------------------------------------
'Declarations for DialogColor function

Private Const CC_ANYCOLOR = &H100 
'Private Const CC_ENABLEHOOK = &H10
'Private Const CC_ENABLETEMPLATE = &H20
'Private Const CC_ENABLETEMPLATEHANDLE = &H40
Private Const CC_FULLOPEN = &H2 
Private Const CC_PREVENTFULLOPEN = &H4 
Private Const CC_RGBINIT = &H1 
'Private Const CC_SHOWHELP = &H8
'Private Const CC_SOLIDCOLOR = &H80

#If VBA7 Then 
    Private Type ChooseColor 
        lStructSize               As Long 
        hwndOwner                 As LongPtr 
        hInstance                 As LongPtr 
        rgbResult                 As Long 
        lpCustColors              As LongPtr 
        Flags                     As Long 
        lCustData                 As LongPtr 
        lpfnHook                  As LongPtr 
        lpTemplateName            As String 
    End Type 
    Private Declare PtrSafe Function ChooseColor Lib  "comdlg32.dll" _ 
      Alias  "ChooseColorA" _ 
      (pChoosecolor As ChooseColor) As Long 
#Else 
    Private Type ChooseColor 
        lStructSize               As Long 
        hwndOwner                 As Long 
        hInstance                 As Long 
        rgbResult                 As Long 
        lpCustColors              As Long 
        Flags                     As Long 
        lCustData                 As Long 
        lpfnHook                  As Long 
        lpTemplateName            As String 
    End Type 
    Private Declare Function ChooseColor Lib  "comdlg32.dll" _ 
      Alias  "ChooseColorA" _ 
      (pChoosecolor As ChooseColor) As Long 
#End If 
'=======================================================================
' ----------------------------------------------------------------
' Procedure : DialogColor
' Author    : Daniel Pineault
' Source    : 
' Adapted by: Mike Wolfe
' Date      : 2/2/2023 modified s4p 5/30/23 set custom colors
' Purpose   : Display the Windows color chooser dialog.
' Notes     - Returns the default color if the user cancels.
'           - Pass 0 as the DefaultColor to use the Color Picker default of black.
'           - DefaultColor is required
'             custom colors is an optional array not ParamArray.
' ----------------------------------------------------------------
Public Function DialogColor(DefaultColor As Long _ 
   ,Optional CustomColors As Variant) As Long 
    'Populate array of custom colors
    Dim Colors(16) As Long,i As Long 
    If Not IsMissing(CustomColors) Then  'crystal
      For i = LBound(CustomColors) To UBound(CustomColors) 
          Colors(i) = CustomColors(i) 
      Next i 
    End If 
    
    Dim CC As ChooseColor 
    With CC 
        .lStructSize = LenB(CC) 
        .hwndOwner = Application.hWndAccessApp 
        .Flags = CC_ANYCOLOR Or CC_FULLOPEN Or CC_PREVENTFULLOPEN Or CC_RGBINIT 
        .rgbResult = DefaultColor     'Set the initial color of the dialog
        .lpCustColors = VarPtr(Colors(0)) 
    End With 
    
    Dim ReturnCode As Long 
    ReturnCode = ChooseColor(CC) 
    If ReturnCode = 0 Then 
        'Cancelled by the user
        DialogColor = DefaultColor 
    Else 
        DialogColor = CC.rgbResult 
    End If 
End Function 

Ir al inicio

Módulo estándar

Función para obtener una cadena RGB a partir de un número de color

Public Function GetRGBstring(pnColr As Long) As String 
' strive4peace
' get RGB values from color number
' return as comma-delimited string
 
   Dim R As Integer 
   Dim G As Integer 
   Dim B As Integer 
   
   R = (pnColr Mod 65536) Mod 256 
   G = (pnColr Mod 65536) \ 256 
   B = pnColr \ 65536 
   
   GetRGBstring = R &  ", " & G &  ", " & B 
   
End Function 

Ir al inicio

Código detrás del formulario

'cbf: f_MENU_CommandButton_Color_Shape
'*************** Code Start ***********************************************
' Purpose  : Make command button come alive
'              by assigning colors to properties
' Author   : crystal (strive4peace)
' Code List: 
' This code: 
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Mark your changes. Use at your own risk.
'-------------------------------------------------------------------------------
'           module variable
'-------------------------------------------------------------------------------
Private maColorPropertyName() As String 

'-------------------------------------------------------------------------------
'           Form_Load
'-------------------------------------------------------------------------------
Private Sub Form_Load() 
'230529 s4p, 230531
   maColorPropertyName = Split( _ 
      "ForeColor" _ 
      &  ";BackColor" _ 
      &  ";BorderColor" _ 
      &  ";HoverForeColor" _ 
      &  ";HoverColor" _ 
      &  ";PressedForeColor" _ 
      &  ";PressedColor" _ 
      , ";") 
      
   Dim sColrControlname As String _ 
      ,sBoxControlname As String _ 
      ,sRgbControlname As String _ 
      ,nColr As Long _ 
      ,i As Integer _ 
      ,vPropertyName As Variant 

   'populate colors
   With Me 
   
      For Each vPropertyName In maColorPropertyName 
         sColrControlname =  "colr_" & vPropertyName 
         sBoxControlname =  "Box_" & vPropertyName 
         sRgbControlname =  "rgb_" & vPropertyName 
         
         'read color value from example command button
         nColr = .cmd_ColorMe.Properties(vPropertyName) 
         
         'show color or value
         .Controls(sColrControlname).Value = nColr 
         .Controls(sBoxControlname).BackColor = nColr 
         .Controls(sRgbControlname).Value = GetRGBstring(nColr) 
      Next vPropertyName 
      'read Shape and FontSize
      With .cmd_ColorMe 
         Me.lst_Shape = .Shape 
         Me.txt_FontSize = .FontSize 
      End With 
   End With 
   
End Sub 

'-------------------------------------------------------------------------------
'           COLOR
'-------------------------------------------------------------------------------
'------------------------------------------ Change Color Number
Private Sub colr_ForeColor_AfterUpdate() 
'230531
   Call SetColor( "ForeColor" _ 
      ,Nz(Me.ActiveControl.Value,-99) _ 
      , "colr") 
End Sub 
Private Sub colr_BackColor_AfterUpdate() 
   Call SetColor( "BackColor" _ 
      ,Nz(Me.ActiveControl.Value,-99) _ 
      , "colr") 
End Sub 
Private Sub colr_BorderColor_AfterUpdate() 
   Call SetColor( "BorderColor" _ 
      ,Nz(Me.ActiveControl.Value,-99) _ 
      , "colr") 
End Sub 
Private Sub colr_HoverForeColor_AfterUpdate() 
   Call SetColor( "HoverForeColor" _ 
      ,Nz(Me.ActiveControl.Value,-99) _ 
      , "colr") 
End Sub 
Private Sub colr_HoverColor_AfterUpdate() 
   Call SetColor( "HoverColor" _ 
      ,Nz(Me.ActiveControl.Value,-99) _ 
      , "colr") 
End Sub 
Private Sub colr_PressedForeColor_AfterUpdate() 
   Call SetColor( "PressedForeColor" _ 
      ,Nz(Me.ActiveControl.Value,-99) _ 
      , "colr") 
End Sub 
Private Sub colr_PressedColor_AfterUpdate() 
   Call SetColor( "PressedColor" _ 
      ,Nz(Me.ActiveControl.Value,-99) _ 
      , "colr") 
End Sub 

'------------------------------------------ Change RGB
Private Sub rgb_ForeColor_AfterUpdate() 
'230531
   Call ChangeRGB( "ForeColor") 
End Sub 
Private Sub rgb_BackColor_AfterUpdate() 
   Call ChangeRGB( "BackColor") 
End Sub 
Private Sub rgb_BorderColor_AfterUpdate() 
   Call ChangeRGB( "BorderColor") 
End Sub 
Private Sub rgb_HoverForeColor_AfterUpdate() 
   Call ChangeRGB( "HoverForeColor") 
End Sub 
Private Sub rgb_HoverColor_AfterUpdate() 
   Call ChangeRGB( "HoverColor") 
End Sub 
Private Sub rgb_PressedForeColor_AfterUpdate() 
   Call ChangeRGB( "PressedForeColor") 
End Sub 
Private Sub rgb_PressedColor_AfterUpdate() 
   Call ChangeRGB( "PressedColor") 
End Sub 

'-------------------------------------------------------------------------------
'           ChangeRGB
'-------------------------------------------------------------------------------
Private Sub ChangeRGB(psProperty As String) 
'230531
   Dim sValue As String _ 
      ,nColr As Long 
   Dim aRGB() As String 
   
   sValue = Nz(Me.ActiveControl.Value, "") 
   aRGB = Split(sValue, ",") 
   If UBound(aRGB) - LBound(aRGB)  2 Then 
      Exit Sub 
   End If 
   'assume the values are valid numbers
   nColr = RGB(aRGB(0),aRGB(1),aRGB(2)) 
   Call SetColor(psProperty _ 
      ,nColr _ 
      , "rgb") 

End Sub 

'-------------------------------------------------------------------------------
'           SetColor
'-------------------------------------------------------------------------------
Private Sub SetColor(psPropertyName As String _ 
   ,pnColr As Long _ 
   ,Optional pSkip As String _ 
   ) 
   Dim sColrControlname As String _ 
      ,sBoxControlname As String _ 
      ,sRgbControlname As String 
      
   If pnColr Then Exit Sub 

   With Me 
      sColrControlname =  "colr_" & psPropertyName 
      sBoxControlname =  "Box_" & psPropertyName 
      sRgbControlname =  "rgb_" & psPropertyName 

      'show color or value
      If Not InStr(pSkip, "colr") >= 1 Then 
         .Controls(sColrControlname).Value = pnColr 
      End If 

      If Not InStr(pSkip, "Box") >= 1 Then 
         .Controls(sBoxControlname).BackColor = pnColr 
      End If 
      If Not InStr(pSkip, "rgb") >= 1 Then 
         .Controls(sRgbControlname).Value = GetRGBstring(pnColr) 
      End If 
      
   End With  'me
   
   'Change property for command button
   Me.cmd_ColorMe.Properties(psPropertyName) = pnColr 
End Sub 
'------------------------------------------ Box color picker
Private Sub Box_ForeColor_Click() 
   Call PickMyColor( "ForeColor") 
End Sub 

Private Sub Box_BackColor_Click() 
   Call PickMyColor( "BackColor") 
End Sub 

Private Sub Box_BorderColor_Click() 
   Call PickMyColor( "BorderColor") 
End Sub 

Private Sub Box_HoverForeColor_Click() 
   Call PickMyColor( "HoverForeColor") 
End Sub 
Private Sub Box_HoverColor_Click() 
   Call PickMyColor( "HoverColor") 
End Sub 

Private Sub Box_PressedForeColor_Click() 
   Call PickMyColor( "PressedForeColor") 
End Sub 
Private Sub Box_PressedColor_Click() 
   Call PickMyColor( "PressedColor") 
End Sub 
'-------------------------------------------------------------------------------
'           PickMyColor
'-------------------------------------------------------------------------------
Private Sub PickMyColor(sPropertyName As String _ 
   ,Optional pnColr As Long = -99) 
'230529 use Access built-in color picker
   'CALLS
   '  DialogColor
         'code from NoLongerSet by Mike Wolfe
         '  
         'references DevHut by Daniel Pineault
         '  
   '  SetColorArray -- define custom colors
   '  SetColor
   '     set appropriate color for example control
   '     and data for user to copy or make a note of
   'PARAMETERS
   '  sPropertyName is the name of the property to change for example
   '  pnColr is negative to read box BackColor
   '     or positive to set to something specific
   
   Dim nColr As Long _ 
      ,nColrPick As Long 
      
   'must be Variant instead of Long for passing
   Static aColor(0 To 15) As Variant 
   If aColor(0) = 0 Then 
      'only do this if colors aren't defined
      Call SetColorArray(aColor) 
      'you could call a different procedure
      'to load different custom values
   End If 

   If pnColr Then 
      'read BackColor from box (default)
      nColr = Me( "Box_" & sPropertyName).BackColor 
   End If 
   
   'call ChooseColor API
   '  via DialogColor by Daniel Pineault modified by Mike Wolfe
   '  send array (not ParamArray) for custom colors - modified by crystal
   nColrPick = DialogColor(nColr,aColor) 
   
   'chosen color is different
   If nColrPick  nColr Then 
      Call SetColor(sPropertyName,nColrPick) 
   End If 
   
End Sub 

'------------------------------------------ click Command Button
Private Sub cmd_DefaultButton_Click() 
   Call ShowMyColors 
End Sub 
Private Sub cmd_NoTheme_Click() 
   Call ShowMyColors 
End Sub 
Private Sub cmd_Command_Click() 
   Call ShowMyColors 
End Sub 
Private Sub cmd_Tab_Click() 
   Call ShowMyColors 
End Sub 
Private Sub cmd_Round_Click() 
   Call ShowMyColors 
End Sub 
Private Sub cmd_ColorMe_Click() 
   Call ShowMyColors 
End Sub 
'-------------------------------------------------------------------------------
'           ShowMyColors
'-------------------------------------------------------------------------------
Private Sub ShowMyColors() 
'230528 s4p, 230531, 601, 603
   Dim sMsg As String _ 
      ,sControlName As String _ 
      ,sText As String _ 
      ,vPropertyName As Variant _ 
      ,vValue As Variant 

   With Me.ActiveControl 
      sControlName = .Name 
      Debug.Print  "*** " & sControlName 

      Debug.Print  "UseTheme"; Tab(20); .UseTheme 
      sMsg =  "UseTheme: " & .UseTheme & vbCrLf 
   
      sText =  ""
      ' these are just property names for color
      For Each vPropertyName In maColorPropertyName 
      
         vValue = .Properties(vPropertyName) 

         sText =  "  (" & GetRGBstring(CLng(vValue)) &  ")"
         
         Debug.Print vPropertyName; 
         Debug.Print Tab(20); 
         Debug.Print vValue; 
         Debug.Print Tab(32); 
         Debug.Print sText 
            
         sMsg = sMsg & vPropertyName &  ": " _ 
            & .Properties(vPropertyName) _ 
            & sText _ 
            & vbCrLf 
            
      Next vPropertyName 
      
      'add FontSize
      Debug.Print  "FontSize"; Tab(20); .FontSize 
      sMsg = sMsg &  "FontSize: " & .FontSize _ 
         & vbCrLf 
      
      'add Shape
      Debug.Print  "Shape"; Tab(20); .Shape 
      sMsg = sMsg &  "Shape: " & .Shape &  "  " _ 
         & DLookup( "ShapeName", "enum_Shape", "Shapei=" & .Shape) _ 
         & vbCrLf 
      
      'finalize message
      sMsg = sMsg & vbCrLf &  "Ctrl-G to copy from Debug window"
      
   End With 
   
   MsgBox sMsg,, "Properties for " & sControlName 
End Sub 

'-------------------------------------------------------------------------------
'           SetColorArray
'-------------------------------------------------------------------------------
Private Sub SetColorArray(aColor As Variant) 
'fill array of color values
   'colors from Daniel
   aColor(0) = RGB(255,255,255)  'White
   aColor(1) = RGB(0,0,0)        'Black
   aColor(2) = RGB(255,0,0)      'Red
   aColor(3) = RGB(0,255,0)      'Green
   aColor(4) = RGB(0,0,255)      'Blue
   'colors added by crystal (strive4peace)
   aColor(5) = RGB(255,255,0)     'bright yellow
   aColor(6) = RGB(255,152,0)     'orange
   aColor(7) = RGB(153,0,255)     'purple
   aColor(8) = RGB(112,173,71)    'tree Green
   aColor(9) = RGB(33,150,243)    'Blue medium
   aColor(10) = RGB(150,100,0)    'brown
   aColor(11) = RGB(255,244,202)  'pale yellow
   aColor(12) = RGB(225,168,168)  'rose
   aColor(13) = RGB(251,218,181)  'tan
   aColor(14) = RGB(214,226,188)  'sea green
   aColor(15) = RGB(192,80,77)    'brick red
End Sub 

'-------------------------------------------------------------------------------
'           Shape
'-------------------------------------------------------------------------------
Private Sub lst_Shape_MouseUp(Button As Integer,Shift As Integer,X As Single,Y As Single) 
'230529 s4p written generically -- drop always
   With Me.ActiveControl 
'      If IsNull(.Value) Then
         .Dropdown 
'      End If
   End With  'me
End Sub 

Private Sub lst_Shape_AfterUpdate() 
'230531 s4p
   With Me.lst_Shape 
      If Not IsNull(.Value) Then 
         Me.cmd_ColorMe.Shape = CLng(.Value) 
      End If 
   End With 
End Sub 

'-------------------------------------------------------------------------------
'           FontSize
'-------------------------------------------------------------------------------

Private Sub txt_FontSize_AfterUpdate() 
'230531 s4p
   With Me.txt_FontSize 
      If Not IsNull(.Value) Then 
         Me.cmd_ColorMe.FontSize = .Value 
      End If 
   End With 
End Sub 

'*************** Code End *****************************************************