Loading th color picker in VBA for autocad 2008

[Anonymous]

Hi all

I have a problem in loading the color picker in autocad 2008 using the VLAX class module, althought it was working well in autocad 2006.

The following represent the code for the VLAX class module:

Private VL As Object
Private VLF As Object

Private Sub Class_Initialize()

    Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
    Set VLF = VL.ActiveDocument.Functions

End Sub

Private Sub Class_Terminate()

    Set VLF = Nothing
    Set VL = Nothing

End Sub

Public Function EvalLispExpression(lispStatement As String)

    Dim sym As Object, RET As Object, retVal
    
    Set sym = VLF.Item("read").funcall(lispStatement)
    ' on error resume next
    retVal = VLF.Item("eval").funcall(sym)
    If Err Then
        EvalLispExpression = ""
    Else
        EvalLispExpression = retVal
    End If

End Function

Public Sub SetLispSymbol(symbolName As String, value)

    Dim sym As Object, RET, symValue
    
    symValue = value
    Set sym = VLF.Item("read").funcall(symbolName)
    RET = VLF.Item("set").funcall(sym, symValue)
    EvalLispExpression "(defun translate-variant (data) (cond ((= (type data) 'list) (mapcar 'translate-variant data)) ((= (type data) 'variant) (translate-variant (vlax-variant-value data))) ((= (type data) 'safearray) (mapcar 'translate-variant (vlax-safearray->list data))) (t data)))"
    EvalLispExpression "(setq " & symbolName & "(translate-variant " & symbolName & "))"
    EvalLispExpression "(setq translate-variant nil)"

End Sub

Public Function GetLispSymbol(symbolName As String)

    Dim sym As Object, RET, symValue
    
    symValue = value
    Set sym = VLF.Item("read").funcall(symbolName)
    GetLispSymbol = VLF.Item("eval").funcall(sym)

End Function

Public Function GetLispList(symbolName As String) As Variant

   Dim sym As Object, list As Object
   Dim count, elements(), i As Long
   
   Set sym = VLF.Item("read").funcall(symbolName)
   Set list = VLF.Item("eval").funcall(sym)
   
   count = VLF.Item("length").funcall(list)
   
   ReDim elements(0 To count - 1) As Variant
   
   For i = 0 To count - 1
        elements(i) = VLF.Item("nth").funcall(i, list)
   Next
   
   GetLispList = elements
   
End Function

Public Sub NullifySymbol(ParamArray symbolName())

    Dim i As Integer
    
    For i = LBound(symbolName) To UBound(symbolName)
        EvalLispExpression "(setq " & CStr(symbolName(i)) & " nil)"
    Next

End Sub

The line code highligthed in red is the line where an error occurs for the autocad2008

So does anyone know whats wrong with this module and also is there another way to call the autocad color picker?

Thanks 4 ur help.....................

[norman.yuan]

Having not used VLAX, I could be wrong.

Change "VL.Application.16" to "VL.Application.17"

"16" means AutoCAD version 16 (Acad2004/5/6), "17" means Acad2007/8/9

[Anonymous]

Thanks 4 ur reply, I tried it but still same error occurs

Thanks again....

[norman.yuan]

OK, it looks like, VL.Application.16 is the one you can use. There is no VL.Application.17/18...

I tried with my 2 computers with this code:

Public Sub Test()

    Dim vl As Object
    Set vl = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
    MsgBox "Done"
   
End Sub

Box1: OS Win2003 (Should be the same as WinXP) with Acad2006, 2008 2009 installed.  The code works with all of them: Acad2006, 2008, 2009

Box2: Win7 (32bit) with Acad 2009,2011 installed. The code does not work (getting error "Problem in loading application") with both Acad2009 and 2011.

[Anonymous]

Ok, so its not easy to fix this module.

But do u know another way to load the color picker in VBA?

Thanks again 4 ur help...

[Anonymous]

Here is an example of using Windows color palette. You pick a color from it and then you can convert it to RGB and use this color to the objects. First attachment is the code for picking the color from palette and convert it to RGB with function from the second attachment.

One question what is VLAX, for what it's?

[andrewpuller3811]

I found the attached file with the routine to call the autocad colour dialogue somewhere, sorry to the original author for not recalling who it was.

The code below is part of a sub that uses the attached routine to set form button colours

    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 the function that calls the autocad colour picker dialogue

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