[求助]：帮我学学习LSP，错在哪？

fjw_ok

Sub test()
'Initialize
Dim pickObj As AcadEntity         '保存被选择图元的对象变量
Dim pickPnt As Variant            '选择图元时的拾取点变量
Dim length As Double
ThisDrawing.Utility.GetEntity pickObj, pickPnt, "选择图元对象："

le = GetCurveLength(pickObj)
MsgBox le

End Sub

Public Function GetCurveLength(curve As AcadEntity) As Double
    Dim obj As VLAX, retVal
    Set obj = New VLAX
    obj.EvalLispExpression "(setq curve (handent " & Chr(34) & curve.Handle & Chr(34) & "))"
    obj.EvalLispExpression "(setq curvelength (vlax-curve-getDistAtParam curve " & _
                           "(vlax-curve-getEndParam curve)))"
    retVal = obj.GetLispSymbol("curvelength")
    obj.NullifySymbol "curve", "curvelength"
    Set obj = Nothing
    GetCurveLength = CDbl(retVal)
End Function



'VERSION 1.0 CLASS
'BEGIN
' MultiUse = -1  'True
'End


Private VL As Object
Private VLF As Object

Private Sub Class_Initialize()

    Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
    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) '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

报错“实时错误-2147221005 （800401f3)”，好象没初始化，请问如何初始化

XDSoft

最初由 fjw_ok 发布
[B]Sub test()
'Initialize
Dim pickObj As AcadEntity         '保存被选择图元的对象变量
Dim pickPnt As Variant            '选择图元时的拾取点变量
Dim length As Double
ThisDrawing.Utility.GetEntity pic... [/B]

也不是LSP啊？

fjw_ok

主要是引用 VLAX，好象没初始化

efan2000

VL没有加载，可以用SendCommand "(vl-load-com)"加载。