Code:
Private VL As Object
Private VLF As Object
Private VL_Read As Object
Private VL_Eval As Object
Private VL_Set As Object
'---------------------------------------------------------------------------------
'---------------------------------------------------------------------------------
Private Sub Class_Initialize()
Dim C_cmdecho As Integer
C_cmdecho = ThisDrawing.GetVariable("cmdecho")
Call ThisDrawing.SetVariable("cmdecho", 0)
ThisDrawing.SendCommand ("(vl-load-com)" & vbCr)
Call ThisDrawing.SetVariable("cmdecho", C_cmdecho)
Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
Set VLF = VL.ActiveDocument.Functions
Set VL_Read = VLF.Item("read")
Set VL_Eval = VLF.Item("eval")
Set VL_Set = VLF.Item("set")
End SubPrivate Sub Class_Terminate()
Set VL_Eval = Nothing
Set VL_Read = Nothing
Set VLF = Nothing
Set VL = Nothing
End Sub
'---------------------------------------------------------------------------------
'---------------------------------------------------------------------------------
Public Function GetLispVar(ByVal Name As String) As Variant
On Error GoTo Ende
Dim Sym As Object
Set Sym = VL_Read.funcall(Name)
Dim Out As Variant
Out = VL_Eval.funcall(Sym)
GetLispVar = Out
On Error GoTo 0
Exit Function
Ende:
On Error GoTo 0
If isList_LispVar(Name) _
Then
Out = readList(Name)
End If
GetLispVar = Out
End Function
'---------------------------------------------------------------------------------
Public Function SetLispVar(ByVal Name As String, ByVal Value) As Variant
On Error GoTo Ende
Dim Sym As Object
Set Sym = VL_Read.funcall(Name)
Dim Out As Variant
Out = VL_Set(Sym, Value)
Ende:
On Error GoTo 0
'------------------------------
SetLispVar = Out
End Function
'---------------------------------------------------------------------------------
Private Function isList_LispVar(Name As String) As Boolean
Dim Sym As Object
Set Sym = VL_Read.funcall("(vl-princ-to-string (type " & Name & "))")
Dim Out As Variant
Out = VL_Eval.funcall(Sym)
If StrComp("List", Out, vbTextCompare) = 0 _
Then
isList_LispVar = True
Else
isList_LispVar = False
End If
End Function
'---------------------------------------------------------------------------------
Private Function readList(Name As String) As Variant
Dim Sym As Object
Set Sym = VL_Read.funcall("(length " & Name & ")")
Dim Out As Variant
Out = VL_Eval.funcall(Sym)
Dim Lst() As Variant
Dim toRead As String
For i = 0 To Out - 1
toRead = "(nth " & i & " " & Name & ")"
If isList_LispVar(toRead) _
Then
ReDim Preserve Lst(0 To i) As Variant
Lst(i) = readList(toRead)
Else
Set Sym = VL_Read.funcall(toRead)
ReDim Preserve Lst(0 To i) As Variant
Lst(i) = VL_Eval.funcall(Sym)
End If
Next i
readList = Lst
End Function
'---------------------------------------------------------------------------------
Public Function SendLisp(Expr As String) As Boolean
On Error GoTo Fehler
Dim Sym As Object
Set Sym = VL_Read.funcall(Expr)
Dim Out As Variant
Out = VL_Eval.funcall(Sym)
SendLisp = True
On Error GoTo 0
: Exit Function
Fehler:
On Error GoTo 0
SendLisp = False
End Function
Foren auf CAD.de
| 
