Creation of a ComboBox drop-down menu for color selection in VBA

[Anonymous]

Hello ! 

I am looking for a way to create a ComboBox of this type in VBA in a UserForm : 

There is quite a bit of Excel, but nothing like AutoCad. I understand how to fill it in text but I do not know how to create squares or shapes of color in front of the text describing the colors, my goal is to be able then to extract the selected color and to apply it to an entity.

Can you help me ?

[norman.yuan]

It is not pssoble to do it with AutoCAD VBA. You best bet would be to try your luck to find existing ActiveX component that does what you need. Since it is very likely you are using AutoCAD2014 or later and it is 64-bit VBA, then the chance of finding one is very slim.

On the other hand, if you have moved (or started moving) from VBA to AutoCAD .NET API, it would be doable, easily, or not so easy, depends...

[Ed__Jobe]

Rather than creating your own color chooser, you could call AutoCAD's color dialog. Here is a post that shows how.

[Anonymous]

I believe Ed's answer should lead you to the goal

However just for fun I'add in that you could "mimic" in some fashion the color picker dialog by using "common" userform controls

for instance:

1) a combobox control

  where to list the colors names

2) a image control

  placed beside the place where the drop down menu would appear

  it'd show the colors boxes list, and you have to manually tune the boxes spacing to fit the combobox items ones

  it'd be hidden/unhidden on any combobox drop down

3) many image controls

  one for each color

  each showing one color box and starting as hidden

  then made visible/univisible and moved beside the combobox value and back at each valid user combobox selection

4) two event handlers

    namely:

    -  a ComboBox1_Click() event

    -  a ComboBox1_DropButtonClick() event

5) two userform scoped variable

    namely

    - some changeVisibility boolean variable, to keep track and handle the visibility of colors boxes list image (ref point 2)

    - some chosenColor string variable, to keep track and handle the visibility of the relevant colors boxe image chosen (ref point 3)

And just for fun I build it by means of some printscreen image caught when an autocad color picker dialog box was shown and then cutting/pasting all single color pieces for points 2 and 3

[Anonymous]

Wow thank you so much RICVBA and Ed.Jobe !!

I did not know that i can call the Autocad color selection window directly.

I would just like a confirmation, to run the code should I have this code in the part of the userform dedicated to the initialization "Public Sub UserForm_Initialize ()" : (original link)

    Dim lngLastSrfceTriColor As Long
    Dim blnMetaColor As Boolean
    Dim lngCurClr As Long
    Dim lngInitClr As Long
    Dim lngRed As Long
    Dim lngBlue As Long
    Dim lngGreen As Long
    Dim retCol As New AcadAcCmColor

        'store colour for reference
        lngLastSrfceTriColor = retCol.ColorIndex        


        'set color method to enable grabbing colour by colour index
        retCol.ColorMethod = AutoCAD.acColorMethodByACI
        

        ' Set retcol from surface point style
        retCol.ColorIndex = SrfcWrkgStyle.TriangleStyle.DisplayStylePlan.color


        ' check if current surface point colour matches last chosen colour.
        ' i.e the button colour
        If retCol.ColorIndex = lngLastSrfceTriColor Then
            lngInitClr = retCol.ColorIndex
        Else
            lngInitClr = lngLastSrfceTriColor
        End If
        
        
        ' grab the RGB properties of the current layer colour
        lngRed = AutoCAD.Application.ActiveDocument.ActiveLayer.TrueColor.Red
        lngGreen = AutoCAD.Application.ActiveDocument.ActiveLayer.TrueColor.Green
        lngBlue = AutoCAD.Application.ActiveDocument.ActiveLayer.TrueColor.Blue
        

        ' Set retcol from RGB components of current layer
        Call retCol.SetRGB(lngRed, lngGreen, lngBlue)
        

        'Set the long of the current layer colour index
        lngCurClr = retCol.ColorIndex
        

        ' Not sure what this property is
        blnMetaColor = True
            
        On Error Resume Next
        
        'the line below always generates an error - don't know why hence error ignoring
        If acedSetColorDialog(lngInitClr, blnMetaColor, lngCurClr) Then
            
        On Error GoTo 0
        
            'Get Surface Style Point Color
            retCol.ColorIndex = lngInitClr
    
            'Store chosen colour for checking later
            lngLastSrfceTriColor = lngInitClr
            
            
            ' Check returned colour and if 0 or 256 set colout to button face
            ' and text to byblock or bylayer, otherwise set to colour
            
            Select Case lngInitClr
                Case 0
                    Me.cmdbtnTriColour.BackColor = vbButtonFace
                    Me.cmdbtnTriColour.Caption = "ByBlock"
                    
                Case 256
                    Me.cmdbtnTriColour.BackColor = vbButtonFace
                    Me.cmdbtnTriColour.Caption = "ByLayer"
                                    
                Case Else
                    Me.cmdbtnTriColour.BackColor = RGB(retCol.Red, retCol.Green, retCol.Blue)
                    Me.cmdbtnTriColour.Caption = ""
            End Select

And also this code , I have no idea where to place it  ... : 

Public Declare Function acedSetColorDialog Lib "acad.exe" (color As Long, ByVal bAllowMetaColor As Boolean, ByVal nCurLayerColor As Long) As Boolean 

Sub example_usage() 
 On Error Resume Next 
 Dim blnMetaColor As Boolean 
 Dim lngCurClr As Long 
 Dim lngInitClr As Long 
 If acedSetColorDialog(lngInitClr, blnMetaColor, lngCurClr) Then 
    MsgBox lngInitClr 
 End If 
End Sub  

So excuse me my lack of experience in VBA, I am currently learning and English is not my native language either. :s

[Ed__Jobe]

The first block of code would probably go in an OnClick event, such as a button. If you put it in the Form.Initialize event, it would run when you open the form. The function Declare would go in the Declarations section at the top of your module.

[Anonymous]

Thanks 🙂

I try to adapt this code on my code but I have a doubt about the signification of these things : "Me" is this forthe name of my userform ? "cmdbtnTriColour" is this for the name of combobox or button ? and "caption" i realy don't know :s Do you know their meaning ?

Creafter

[Ed__Jobe]

Yes, it refers to a control someone else had on their form. You don't need to use that part. What they are trying to do is show the user "ByLayer" instead of the value "0".

[Anonymous]

All right, I almost there ! 

I delete the part of code witch was useless.

 The last problematic passage blocking code execution is this passage : 

 ' Set retcol from surface point style
        retCol.ColorIndex = SrfcWrkgStyle.TriangleStyle.DisplayStylePlan.color

I have naturally an error message about this line because i don't know what refer to each ellement of this line "SrfcWrkgStyle.TriangleStyle.DisplayStylePlan.color"

Creafter

[Ed__Jobe]

That is some other entity that you don't have. The only thing of importance is the Color property. That's where  you use the return value of the color dialog to set the Color property of whatever you are wanting to change.

[Anonymous]

I'm a little embarassed, I can not run the code ...

However I found on the net exactly what I want to do. I then try to reproduce it, I create a new project to try to make it work but here I can not do it either. Indeed all the code must be copied in the userform directly except that inside there is a declaration and I receive an error message each time because of it ... Would you have some idea?

http://vbnet.mvps.org/index.html?code/comdlg/choosecolor.htm (The program is in VBA and not in VBNet)

Creafter

[Ed__Jobe]

You don't want to use that. AutoCAD only uses 256 colors. You need to use the acad dialog. Why can't you run it? What errors are you getting?

[Anonymous]

I'm looking to make a color selection in a very clean way, whether it's in the form of a drop-down menu or a pop-like window.

Like this :or this :

I myself managed to do something with a combobox but the result is not satisfactory: Not pretty, little choice, no color preview :

That's why I redirected the code to the last post.

Here is the error message:

He said in english " Compilation error. Only comments can appear after End Sub, End Function or End Property"

[Ed__Jobe]

You've pasted the code inside the Initialize event. You can't do that. The Declare's have to go at the top of the module all by themselves.

[Anonymous]

Ah yes indeed, I'm really not comfortable with the statements ...

I modify that and put it on top.

Unfortunately I have again and again error messages ...
"Compile error, user defined type not defined"

Yet in the following code there is the following code that seems to define the type, it's really strange:

Private Type CHOOSECOLORSTRUCT
   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

My knowledge is far too basic for me to adapt some code. You have been a great help to me but I am afraid to waste your time with my misunderstanding ...

[Anonymous]

if you're using CHOOSECOLORSTRUCT type in different module than the one it is defined, then change

Private Type

into

Public Type

otherwise, and provided all of your code using CHOOSECOLORSTRUCT resides in the same module, simply move that type definition in that module

if you're still going with VBA and should you still face any problem, you'd better share relevant code by posting it here (not images!).

if you're going the NET way than you'd better start a new thread in the NET FORUM

[Anonymous]

Ok, I modified the private element in public element.

But i have again error message ...

That is my code :

Directly into the Form : 

Public Sub Form_Load()
Module
End Sub

Public Sub Command1_Click()
Dim cc As CHOOSECOLORSTRUCT
   Dim r As Long
   Dim g As Long
   Dim b As Long
   
   With cc

     'set the flags based on the check and option buttons
      .flags = CC_ANYCOLOR
      If Option2.Value = True Then .flags = .flags Or CC_FULLOPEN
      If Option3.Value = True Then .flags = .flags Or CC_PREVENTFULLOPEN
      If Check1.Value = 1 Then
         .flags = .flags Or CC_RGBINIT
         .rgbResult = Form1.BackColor
      End If

      'size of structure
      .lStructSize = Len(cc)

      'owner of the dialog
      .hwndOwner = Me.HWND

      'assign the custom colour selections
      .lpCustColors = VarPtr(dwCustClrs(0))

   End With

   If ChooseColor(cc) = 1 Then

     'assign the selected colour as the form background
      Me.BackColor = cc.rgbResult

     'bonus .. assure the text remains readable regardless of colour by splitting out the respective
     'RGB values, and adjusting the text colour to contrast
      Call GetRBGFromCLRREF(cc.rgbResult, r, g, b)
      Call UpdateControlShadeSelection(r, g, b)

   End If

End Sub


Public Sub UpdateControlShadeSelection(r As Long, g As Long, b As Long)

   Dim ctlcolor As Long
   Dim ctl As Control

  'if the value of the colour passed (representing the current colour) is less than 128, show white text
  'otherwise show black text
   If (r < 128) And (g < 128) Or _
      (g < 128) And (b < 128) Or _
      (r < 128) And (b < 128) Then

      ctlcolor = vbWhite
   Else
      ctlcolor = vbWindowText
   End If

  'set the option and check backcolor to the form backcolor, and the  'control's text to the contrasting shade
   For Each ctl In Controls

      If TypeOf ctl Is OptionButton Or _
         TypeOf ctl Is CheckBox Then
         ctl.BackColor = RGB(r, g, b)
         ctl.ForeColor = ctlcolor
      End If

   Next

End Sub


Public Sub GetRBGFromCLRREF(ByVal clrref As Long, r As Long, g As Long, b As Long)

  'pass a hex colour, return the rgb components
   b = (clrref \ 65536) And &HFF
   g = (clrref \ 256) And &HFF
   r = clrref And &HFF

End Sub


Public Sub Command2_Click()
   Unload Me
End Sub

And that is in the module 

Declare PtrSafe Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (lpcc As CHOOSECOLORSTRUCT) As Long
Public Sub Module()

  'initialize the custom colours
  'with a series of gray shades
   Dim cnt As Long
   For cnt = 240 To 15 Step -15
      dwCustClrs((cnt \ 15) - 1) = RGB(cnt, cnt, cnt)
   Next

  'initialize controls
   Option1.Caption = "Display normally"
   Option1.Value = True
   Option2.Caption = "Display with Define Custom Colors open"
   Option3.Caption = "Disable Define Custom Colors button"
   Check1.Caption = "Specify initial colour is form BackColor"
   Command1.Caption = "Choose Color"

Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce
'               or publish this code on any web site,
'               online service, or distribute as source
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'static array to contain the custom
'colours selected by the user
Public dwCustClrs(0 To 15) As Long

'ChooseColor structure flag constants
Private Const CC_RGBINIT         As Long = &H1
Private Const CC_FULLOPEN        As Long = &H2
Private Const CC_PREVENTFULLOPEN As Long = &H4
Private Const CC_SOLIDCOLOR      As Long = &H80
Private Const CC_ANYCOLOR        As Long = &H100

Public Type CHOOSECOLORSTRUCT
   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


End Sub

  

This module work but  the error appears in the form on the line :

Public Sub Command1_Click()

   Dim cc As CHOOSECOLORSTRUCT

With de message :

"Compilation error. User-defined type not defined."

[Anonymous]

Assuming we stiil have to stick to VBA 

I'm not sure where you are actually placing all bits of the code you've shown so you may want to test the following

1) place the following at the very top of any module (hence, NOTin any UserForm code pane)

Option Explicit

Public Declare PtrSafe Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (lpcc As CHOOSECOLORSTRUCT) As LongPtr

Public Type CHOOSECOLORSTRUCT
    lStructSize As LongPtr
    hwndOwner As LongPtr
    hInstance As LongPtr
    rgbResult As LongPtr
    lpCustColors As String
    flags As LongPtr
    lCustData As LongPtr
    lpfnHook As LongPtr
    lpTemplateName As String
End Type

2) place the following in your UserForm code pane

Option Explicit

Private dwCustClrs(0 To 15) As Byte

''''ChooseColor structure flag constants
Private Const CC_RGBINIT         As Long = &H1
Private Const CC_FULLOPEN        As Long = &H2
Private Const CC_PREVENTFULLOPEN As Long = &H4
Private Const CC_SOLIDCOLOR      As Long = &H80
Private Const CC_ANYCOLOR        As Long = &H100


Public Sub UserForm_Initialize()
    Dim cnt As Long
    With Me
        .Option1.Caption = "Display normally"
        .Option1.Value = True
        .Option2.Caption = "Display with Define Custom Colors open"
        .Option3.Caption = "Disable Define Custom Colors button"
        .Check1.Caption = "Specify initial colour is form BackColor"
        .Command1.Caption = "Choose Color"
    End With
End Sub

Public Sub Command1_Click()
    Dim cc As CHOOSECOLORSTRUCT
    Dim r As Long
    Dim g As Long
    Dim b As Long
    
    With cc
    
      'set the flags based on the check and option buttons
       .flags = CC_ANYCOLOR
       If Me.Option2.Value = True Then .flags = .flags Or CC_FULLOPEN
       If Me.Option3.Value = True Then .flags = .flags Or CC_PREVENTFULLOPEN
       If Me.Check1.Value = 1 Then
          .flags = .flags Or CC_RGBINIT
          .rgbResult = Me.BackColor
       End If
    
       'size of structure
       .lStructSize = Len(cc)
    
       'owner of the dialog
       .hwndOwner = Application.HWND
    
       'assign the custom colour selections
       .lpCustColors = StrConv(dwCustClrs, vbUnicode) 'VarPtr(dwCustClrs(0))
    
    End With

    If CHOOSECOLOR(cc) = 1 Then
    
      'assign the selected colour as the form background
       Me.BackColor = CLng(cc.rgbResult)
    
      'bonus .. assure the text remains readable regardless of colour by splitting out the respective
      'RGB values, and adjusting the text colour to contrast
       Call GetRBGFromCLRREF(CLng(cc.rgbResult), r, g, b)
       Call UpdateControlShadeSelection(r, g, b)
    
    End If

End Sub

   along with your UpdateControlShadeSelection(), GetRBGFromCLRREF() and Command2_Click() routines

and that should work

if you're in a VB.NET environment than you need some adjustments

[Anonymous]

Nice ! The code seems almost functional 🙂

And yes we still have to stick to VBA

I have just a new error message about the HWND : "Member of method or data not found"

In this part of code , it appears after clicking on the selection color button.

    'owner of the dialog
      .hwndOwner = Me.HWND

There is in this Sub :

Public Sub Command1_Click()
Dim cc As CHOOSECOLORSTRUCT
   Dim r As Long
   Dim g As Long
   Dim b As Long
   
   With cc

     'set the flags based on the check and option buttons
      .flags = CC_ANYCOLOR
      If Option2.Value = True Then .flags = .flags Or CC_FULLOPEN
      If Option3.Value = True Then .flags = .flags Or CC_PREVENTFULLOPEN
      If Check1.Value = 1 Then
         .flags = .flags Or CC_RGBINIT
         .rgbResult = Form1.BackColor
      End If

      'size of structure
      .lStructSize = Len(cc)

      'owner of the dialog
      .hwndOwner = Me.HWND

      'assign the custom colour selections
      .lpCustColors = VarPtr(dwCustClrs(0))

   End With

   If CHOOSECOLOR(cc) = 1 Then

     'assign the selected colour as the form background
      Me.BackColor = cc.rgbResult

     'bonus .. assure the text remains readable regardless of colour by splitting out the respective
     'RGB values, and adjusting the text colour to contrast
      Call GetRBGFromCLRREF(cc.rgbResult, r, g, b)
      Call UpdateControlShadeSelection(r, g, b)

   End If

End Sub

Do you have some idea on the origin of the error ?

[Anonymous]

Use

hwndOwner = Application.HWND