Exchange Forum > ActiveX and VBA
VBA code with AutoLISP
VBA code with AutoLISP

#1
Dante
Join Date:
08-13-2007
 The link for the VBA code that I've attached was suggested by Mark, aka member name ML0940. This code is a great find, and deserves its own thread. In this thread let's focus on new applications developed with this code. Again, special thanks to Mark for his suggestion.
Dante
 
Before you run the VBA Test function type the following on the command line.
Command: (setq A 1234)
1234
Command: (setq B (list 100 1.234 "string"))
(100 1.234 "string")
In VBA make sure you have the Immediate Window open for the Debug.Print code by pressing Ctrl+G or select it through the top View menu. Then paste and run the attached VBA code. You should see the following lines.
symbol A is: 1234
list B contains:
100
1.234
string
Finally go back to AutoCAD and type the following on the command line.
Command: !C
100.0
Command: !D
(#<variant 8 VBA> #<variant 2 100> #<variant 5 1.234>)
Here's a function to change a variant to a value.
You would use it like: (setq D (variant-value D)) = (list "VBA" 100 1.234)
Code: 
(defun variant-value (symbol)
  (cond
    ((= (type symbol) 'variant) (variant-value (vlax-variant-value symbol)))
    ((= (type symbol) 'safearray) (mapcar 'variant-value (vlax-safearray->list symbol)))
    ((= (type symbol) 'list) (mapcar 'variant-value symbol))
    (t symbol)
  )
)
In the attached code I changed the following line to work with AutoCAD 2004 and higher by changing the 1 to 16. If someone is using a version before 2004 change it back to a 1. Also note that this was only found one place in the sample code.
Set VL = CreateObject("VL.Application.16")
I noticed that both GetLispSym and GetLispList are defined as Functions, whereas PutLispSym and PutLispList are defined as just Subs.
Code: 
Dim VL As Object
Sub Test()
  ' Get the VisualLisp Automation interface
  Set VL = CreateObject("VL.Application.16")
  '
  ' [Getting symbols and lists from Lisp]
 
  '
  ' Get the value of the Lisp symbol 'A'.
  ' Use (setq A 1234) in Lisp to set it.
  A = GetLispSym("A")
  Debug.Print "symbol A is: " & A
  ' Get the Lisp list 'B'.
  ' Use (setq B (list 100 1.234 "string")) in Lisp to define it.
  B = GetLispList("B")
  Debug.Print "list B contains:"
  For index = LBound(B) To UBound(B)
    Debug.Print B(index)
  Next
  '
  ' [Setting Lisp symbols and lists]
  '
  ' Set the Lisp symbol 'C' to 100.0
  Dim value As Double
  value = 100#
  PutLispSym "C", value
  ' Create the list ("VBA" 100 1.234)
  ' and store it in the Lisp symbol 'D'.
  Dim values(0 To 2) As Variant
  values(0) = "VBA"
  values(1) = 100
  values(2) = 1.234
  PutLispList "D", values
End Sub
  ' This function returns the value of a Lisp symbol.
  ' The Lisp symbol can be set in Lisp like:
  ' (setq x 1234)
Function GetLispSym(symbolName As String) As Variant
  Dim sym As Object
  ' Get the Lisp symbol 'symbolName'.
  Set sym = VL.ActiveDocument.Functions.Item("read").funcall(symbolName)
  GetLispSym = VL.ActiveDocument.Functions.Item("eval").funcall(sym)
End Function
  ' This function gets a Lisp list
  ' and put its elements into a Variant array.
  ' The list can be something like:
  ' (100 1.234 "string")
Function GetLispList(symbolName As String) As Variant
  Dim sym As Object
  Dim list As Object
  ' Get the Lisp symbol 'symbolName'.
  Set sym = VL.ActiveDocument.Functions.Item("read").funcall(symbolName)
  Set list = VL.ActiveDocument.Functions.Item("eval").funcall(sym)
  ' Get the number of elements in this list.
  items = VL.ActiveDocument.Functions.Item("length").funcall(list)
  ReDim VarItems(0 To items - 1) As Variant
  ' Get every item from the list.
  For I = 1 To items
    Item = VL.ActiveDocument.Functions.Item("nth").funcall(I - 1, list)
    VarItems(I - 1) = Item
  Next
  GetLispList = VarItems
End Function
  ' This function creates a new Lisp symbol 'symbolName'.
  ' It gets the value specified by 'value'.
Sub PutLispSym(symbolName As String, value As Variant)
  Dim sym As Object
  Set sym = VL.ActiveDocument.Functions.Item("read").funcall(symbolName)
  VL.ActiveDocument.Functions.Item("set").funcall sym, value
End Sub
  ' This function creates a new Lisp list
  ' and assigns it to the symbol 'symbolName'.
  ' The 'values' parameter has to contain
  ' an array of variants, and this array
  ' is converted to the Lisp list:
  ' Array: "VBA" 100 1.234
  ' List: ("VBA" 100 1.234)
Sub PutLispList(symbolName As String, values As Variant)
  ' Initialize the list using the first value.
  Dim list As Object
  Dim newList As Object
  Set list = VL.ActiveDocument.Functions.Item("list").funcall(values(0))
  ' Append the other items
  For Item = LBound(values) + 1 To UBound(values)
  ' Create a new list for the next item...
    Set newList = VL.ActiveDocument.Functions.Item("list").funcall(values(Item))
  ' ...and append it to the existing list.
    Set list = VL.ActiveDocument.Functions.Item("append").funcall(list, newList)
  Next
  ' Assign the new list to 'symbolName'
  Dim sym As Object
  Dim res As Object
  Set sym = VL.ActiveDocument.Functions.Item("read").funcall(symbolName)
  Set res = VL.ActiveDocument.Functions.Item("set").funcall(sym, list)
End Sub

Attachments  Test.dvb  
VBA code with AutoLISP

#2
Nugent
Join Date:
10-05-2007
 I like this idea Dante. I've been working on a few things and will post them when I get further along.
Nugent
VBA code with AutoLISP

#3
Nugent
Join Date:
10-05-2007
 This routine was suggested by a co-worker. It uses AutoLISP for the basic code and VBA to control the dialog. I've incorporated some error checking in the VBA code to verify that the inputs are numbers in the right range.
I hope you like it.
Nugent
 
SlotSpecs.lsp AutoLISP Code
Code: 
(defun c:SlotSpecs (/ Diff Ins P1 P2 P3 P4 SlotCancel)
  (princ "\nEnter Slot Specifications ")(princ)
  (if (or (not *SlotLength)(not *SlotWidth)(not *SlotAngle))
    (progn
      (setq *SlotLength 2.0)
      (setq *SlotWidth 1.0)
      (setq *SlotAngle 0.0)
    )
  )
  (command "vbaload" "SlotSpecs.dvb")
  (command "vbarun" "thisdrawing.Main")
  (command "vbaunload" "SlotSpecs.dvb")
  (if (not SlotCancel)
    (if (setq Ins (getpoint "\nSpecify center of slot: "))
      (progn
        (setq Diff (abs (- *SlotLength *SlotWidth)))
        (if (> *SlotLength *SlotWidth)
          (progn
            (setq P1 (polar Ins pi (/ Diff 2.0)))
            (setq P1 (polar P1 (* pi 0.5) (/ *SlotWidth 2.0)))
            (setq P2 (polar P1 0 Diff))
            (setq P3 (polar P2 (* pi 1.5) *SlotWidth))
            (setq P4 (polar P3 pi Diff))
          )
          (progn
            (setq P1 (polar Ins (* pi 1.5) (/ Diff 2.0)))
            (setq P1 (polar P1 pi (/ *SlotLength 2.0)))
            (setq P2 (polar P1 (* pi 0.5) Diff))
            (setq P3 (polar P2 0 *SlotLength))
            (setq P4 (polar P3 (* pi 1.5) Diff))
          )
        )
        (if (= *SlotLength *SlotWidth)
          (command "CIRCLE" Ins "D" *SlotWidth)
          (command "PLINE" P1 P2 "A" P3 "L" P4 "A" P1 "CL")
        )
        (command "ROTATE" (entlast) "" Ins *SlotAngle)
      )
    )
  )
  (princ)
)
 
SlotSpecs.dvb VBA Code
Code: 
Sub Main()
 frmSlotSpecs.Show
End Sub
'-----------------
Dim VL As Object
Dim dblLength As Double
Dim dblWidth As Double
Dim dblAngle As Double
Private Sub UserForm_Initialize()
  Set VL = CreateObject("VL.Application.16")
  dblLength = GetLispSym("*SlotLength")
  editLength.Text = CStr(dblLength)
  dblWidth = GetLispSym("*SlotWidth")
  editWidth.Text = CStr(dblWidth)
  dblAngle = GetLispSym("*SlotAngle")
  editAngle.Text = CStr(dblAngle)
  editLength.SetFocus
End Sub
Private Sub cmdOK_Click()
  dblLength = CStr(editLength.Text)
  PutLispSym "*SlotLength", dblLength
  dblWidth = CStr(editWidth.Text)
  PutLispSym "*SlotWidth", dblWidth
  dblAngle = CStr(editAngle.Text)
  PutLispSym "*SlotAngle", dblAngle
  Unload Me
End Sub
Private Sub editLength_AfterUpdate()
  Dim InputValue As Double
  On Error GoTo NotNumber
  InputValue = CStr(editLength.Text)
  If InputValue < 0 Then
    GoTo NotNumber
  End If
  dblLength = CStr(editLength.Text)
  Exit Sub
NotNumber:
  MsgBox "Value must be a positive number!"
  editLength.Text = CStr(dblLength)
End Sub
Private Sub editWidth_AfterUpdate()
  Dim InputValue As Double
  On Error GoTo NotNumber
  InputValue = CStr(editWidth.Text)
  If InputValue < 0 Then
    GoTo NotNumber
  End If
  dblWidth = CStr(editWidth.Text)
  Exit Sub
NotNumber:
  MsgBox "Value must be a positive number!"
  editWidth.Text = CStr(dblWidth)
End Sub
Private Sub editAngle_AfterUpdate()
  Dim InputValue As Double
  On Error GoTo NotNumber
  InputValue = CStr(editAngle.Text)
  If InputValue < 0 Then
    GoTo NotNumber
  End If
  If InputValue > 360 Then
    GoTo NotNumber
  End If
  dblAngle = CStr(editAngle.Text)
  Exit Sub
NotNumber:
  MsgBox "Value must be a positive" + vbCrLf + "number less than 360!"
  editAngle.Text = CStr(dblAngle)
End Sub
Private Sub cmdCancel_Click()
  PutLispSym "SlotCancel", True
  Unload Me
End Sub
Function GetLispSym(symbolName As String) As Variant
  Dim sym As Object
  Set sym = VL.ActiveDocument.Functions.Item("read").funcall(symbolName)
  GetLispSym = VL.ActiveDocument.Functions.Item("eval").funcall(sym)
End Function
Sub PutLispSym(symbolName As String, value As Variant)
  Dim sym As Object
  Set sym = VL.ActiveDocument.Functions.Item("read").funcall(symbolName)
  VL.ActiveDocument.Functions.Item("set").funcall sym, value
End Sub



Attachments  SlotSpecs.lsp    SlotSpecs.dvb    SlotSpecs.jpg  
VBA code with AutoLISP

#4
Dante
Join Date:
08-13-2007
 Nugent,
I like it! The only thing I would suggest would be to add the DTR function below and maybe add the list of drawing layers to choose from to draw it on.
Dante
 
Here's that DTR function. You've probably seen it used before.
Code: 
;Degrees to Radians
(defun dtr (degrees)
  (* pi (/ degrees 180.0))
)
VBA code with AutoLISP

#5
Nugent
Join Date:
10-05-2007
 Hi there.
I already have the dtr function. I was just trying to make it less complicated, but I could definitely use it here. I think the layer thing is a good idea too.
VBA code with AutoLISP

#6
Nugent
Join Date:
10-05-2007
 Dante,
I was surprised how easy it was to incorporate the dtr function and the layer option into the code.
Here's what I came up with after work yesterday.
Thanks for the suggestion.
Nugent
 
AutoLISP code
Code: 
(defun c:SlotSpecs2 (/ Clayer Diff Ins LayerNames LayerTable P1 P2 P3 P4 SlotCancel)
  (princ "\nEnter Slot Specifications ")(princ)
  (setq Clayer (getvar "CLAYER"))
  (setq LayerTable (tblnext "LAYER" t))
  (setq LayerNames (list (cdr (assoc 2 LayerTable))))
  (while (setq LayerTable (tblnext "LAYER"))
    (setq LayerNames (append LayerNames (list (cdr (assoc 2 LayerTable)))))
  )
  (if (or (not *SlotLength)(not *SlotWidth)(not *SlotAngle)(not *SlotLayer))
    (progn
      (setq *SlotLength 2.0)
      (setq *SlotWidth 1.0)
      (setq *SlotAngle 0.0)
      (setq *SlotLayer (getvar "CLAYER"))
    )
  )
  (if (not (member *SlotLayer LayerNames))
    (setq *SlotLayer (getvar "CLAYER"))
  )
 
  (command "vbaload" "SlotSpecs2.dvb")
  (command "vbarun" "thisdrawing.Main")
  (command "vbaunload" "SlotSpecs2.dvb")
  (if (not SlotCancel)
    (if (setq Ins (getpoint "\nSpecify center of slot: "))
      (progn
        (setq Diff (abs (- *SlotLength *SlotWidth)))
        (if (> *SlotLength *SlotWidth)
          (progn
            (setq P1 (polar Ins (dtr *SlotAngle) (/ Diff 2.0)))
            (setq P1 (polar P1 (dtr (+ *SlotAngle 270)) (/ *SlotWidth 2.0)))
            (setq P2 (polar P1 (dtr (+ *SlotAngle 180)) Diff))
            (setq P3 (polar P2 (dtr (+ *SlotAngle 90)) *SlotWidth))
            (setq P4 (polar P3 (dtr *SlotAngle) Diff))
          )
          (progn
            (setq P1 (polar Ins (dtr (+ *SlotAngle 90)) (/ Diff 2.0)))
            (setq P1 (polar P1 (dtr *SlotAngle) (/ *SlotLength 2.0)))
            (setq P2 (polar P1 (dtr (+ *SlotAngle 270)) Diff))
            (setq P3 (polar P2 (dtr (+ *SlotAngle 180)) *SlotLength))
            (setq P4 (polar P3 (dtr (+ *SlotAngle 90)) Diff))
          )
        )
        (command "LAYER" "T" *SlotLayer "U" *SlotLayer "ON" *SlotLayer "S" *SlotLayer "")
        (if (= *SlotLength *SlotWidth)
          (command "CIRCLE" Ins "D" *SlotWidth)
          (command "PLINE" P1 P2 "A" P3 "L" P4 "A" P1 "CL")
        )
      )
    )
  )
  (setvar "CLAYER" Clayer)
  (princ)
)
(defun dtr (degrees)
  (* pi (/ degrees 180.0))
)
VBA code
Code: 
Sub Main()
 frmSlotSpecs.Show
End Sub
'-----------------
Dim VL As Object
Dim dblLength As Double
Dim dblWidth As Double
Dim dblAngle As Double
Dim txtLayer As String
Dim LayerList As Variant
Private Sub UserForm_Initialize()
  Set VL = CreateObject("VL.Application.16")
  dblLength = GetLispSym("*SlotLength")
  editLength.Text = CStr(dblLength)
  dblWidth = GetLispSym("*SlotWidth")
  editWidth.Text = CStr(dblWidth)
  dblAngle = GetLispSym("*SlotAngle")
  editAngle.Text = CStr(dblAngle)
  txtLayer = GetLispSym("*SlotLayer")
  LayerList = GetLispList("LayerNames")
  cboLayer.list = LayerList
  cboLayer.Text = txtLayer
  editLength.SetFocus
End Sub
Private Sub cmdOK_Click()
  dblLength = CStr(editLength.Text)
  PutLispSym "*SlotLength", dblLength
  dblWidth = CStr(editWidth.Text)
  PutLispSym "*SlotWidth", dblWidth
  dblAngle = CStr(editAngle.Text)
  PutLispSym "*SlotAngle", dblAngle
  txtLayer = cboLayer.Text
  PutLispSym "*SlotLayer", txtLayer
  Unload Me
End Sub
Private Sub editLength_AfterUpdate()
  Dim InputValue As Double
  On Error GoTo NotNumber
  InputValue = CStr(editLength.Text)
  If InputValue < 0 Then
    GoTo NotNumber
  End If
  dblLength = CStr(editLength.Text)
  Exit Sub
NotNumber:
  MsgBox "Value must be a positive number!"
  editLength.Text = CStr(dblLength)
End Sub
Private Sub editWidth_AfterUpdate()
  Dim InputValue As Double
  On Error GoTo NotNumber
  InputValue = CStr(editWidth.Text)
  If InputValue < 0 Then
    GoTo NotNumber
  End If
  dblWidth = CStr(editWidth.Text)
  Exit Sub
NotNumber:
  MsgBox "Value must be a positive number!"
  editWidth.Text = CStr(dblWidth)
End Sub
Private Sub editAngle_AfterUpdate()
  Dim InputValue As Double
  On Error GoTo NotNumber
  InputValue = CStr(editAngle.Text)
  If InputValue < 0 Then
    GoTo NotNumber
  End If
  If InputValue > 360 Then
    GoTo NotNumber
  End If
  dblAngle = CStr(editAngle.Text)
  Exit Sub
NotNumber:
  MsgBox "Value must be a positive" + vbCrLf + "number less than 360!"
  editAngle.Text = CStr(dblAngle)
End Sub
Private Sub cmdCancel_Click()
  PutLispSym "SlotCancel", True
  Unload Me
End Sub
Function GetLispSym(symbolName As String) As Variant
  Dim sym As Object
  Set sym = VL.ActiveDocument.Functions.Item("read").funcall(symbolName)
  GetLispSym = VL.ActiveDocument.Functions.Item("eval").funcall(sym)
End Function
Sub PutLispSym(symbolName As String, value As Variant)
  Dim sym As Object
  Set sym = VL.ActiveDocument.Functions.Item("read").funcall(symbolName)
  VL.ActiveDocument.Functions.Item("set").funcall sym, value
End Sub
Function GetLispList(symbolName As String) As Variant
  Dim sym As Object
  Dim list As Object
  Set sym = VL.ActiveDocument.Functions.Item("read").funcall(symbolName)
  Set list = VL.ActiveDocument.Functions.Item("eval").funcall(sym)
  items = VL.ActiveDocument.Functions.Item("length").funcall(list)
  ReDim VarItems(0 To items - 1) As Variant
  For I = 1 To items
    Item = VL.ActiveDocument.Functions.Item("nth").funcall(I - 1, list)
    VarItems(I - 1) = Item
  Next
  GetLispList = VarItems
End Function



Attachments  SlotSpecs2.lsp    SlotSpecs2.dvb    SlotSpecs2.jpg  
VBA code with AutoLISP

#7
DeCipher
Join Date:
08-02-2007
 I liked your example with the ComboBox. Very cool stuff!