vba如何调用lisp里vlax-curve曲线相关函数

yuanziyou

[Visual Basic] 纯文本查看 复制代码

Sub GetLength()
    Dim obj As AcadEntity
    Dim pnt As Variant
    
    ThisDrawing.Utility.GetEntity obj, pnt, "选取曲线："
    
    Dim leng As Double
    leng = GetCurveLength(obj)
    
    MsgBox "所选曲线的长度为 " & leng, , "明经通道VBA示例"
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

Sub 曲线最近的点2()
    Dim obj As AcadEntity
    Dim pnt As Variant
    Dim pt(0 To 2) As Double
    pt(0) = 1292
    pt(1) = 129
    pt(2) = 0
    ThisDrawing.Utility.GetEntity obj, pnt, "选取曲线："
    
    Dim ClosestPT
    ClosestPT = getClosestPointTo(obj, pt())

    
    MsgBox "所最近为 " & ClosestPT, , "明经通道VBA示例"
End Sub
'返回到曲线上的最近点
Public Function getClosestPointTo(curve As AcadEntity, givenPnt() As Double) As Double
    Dim obj As VLAX, retVal
    Dim pt As String
    Set obj = New VLAX
    pt = "'(" & givenPnt(0) & Chr(32) & givenPnt(1) & Chr(32) & givenPnt(2) & ")))"
    
    obj.EvalLispExpression "(setq curve (handent " & Chr(34) & curve.Handle & Chr(34) & "))"
    obj.EvalLispExpression "(setq getClosestPointTo (vlax-curve-getClosestPointTo curve " & pt
    retVal = obj.GetLispSymbol("getClosestPointTo")
    obj.NullifySymbol "curve", "getClosestPointTo"
    
    '释放内存，函数返回
    Set obj = Nothing
    getClosestPointTo = CDbl(retVal)
End Function
'(vlax-curve-getClosestPointTo arcObj '(2.0 6.0 0.0))

' VLAX.CLS v2.0 (Last updated 8/1/2003)
' Copyright 1999-2001 by Frank Oquendo
'
' 该程序由明经通道修改支持2004版本
' [url]http://www.mjtd.com[/url]
'
' Permission to use, copy, modify, and distribute this software
' for any purpose and without fee is hereby granted, provided
' that the above copyright notice appears in all copies and
' that both that copyright notice and the limited warranty and
' restricted rights notice below appear in all supporting
' documentation.
'
' FRANK OQUENDO (THE AUTHOR) PROVIDES THIS PROGRAM "AS IS" AND WITH
' ALL FAULTS. THE AUTHOR SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY
' OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  THE AUTHOR
' DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
' UNINTERRUPTED OR ERROR FREE.
'
' Use, duplication, or disclosure by the U.S. ** is subject to
' restrictions set forth in FAR 52.227-19 (Commercial Computer
' Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
' (Rights in Technical Data and Computer Software), as applicable.
'
' VLAX.cls allows developers to evaluate AutoLISP expressions from
' Visual Basic or VBA
'
' Notes:
' All code for this class module is publicly available througout various posts
' at [url]news://discussion.autodesk.com/autodesk.autocad.customization.vba.[/url] I do not
' claim copyright or authorship on code presented in these posts, only on this
' compilation of that code. In addition, a great big "Thank you!" to Cyrille Fauvel
' demonstrating the use of the VisualLISP ActiveX Module.
'
' Dependencies:
' Use of this class module requires the following application:
' 1. VisualLISP

Private VL As Object
Private VLF As Object

Private Sub Class_Initialize()
    '根据AutoCAD的版本判断使用的库类型
    If Left(ThisDrawing.Application.Version, 2) = "15" Then
        Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
    ElseIf Left(ThisDrawing.Application.Version, 2) = "16" Then
        Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
    End If
    
    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)
    '根据LISP表达式调用函数
    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

我在其他地方找到的一段vba如何调用lisp里vlax-curve曲线相关函数的代码(见附件),原代码实现的功能是获取曲线的长度,我依葫芦画瓢想调用lisp的vlax-curve-getClosestPointTo函数实现获取"曲线上离指定点最近的点"的功能(在同一个附件里),但提示"类型不匹配"是什么原因呢

map123

我也遇到同样的问题，而且加载了vl-active-module

dnbcgrass

Sub GetLength()
    Dim obj As AcadEntity
    Dim pnt As Variant
   
    ThisDrawing.Utility.GetEntity obj, pnt, "选取曲线："
    ThisDrawing.SetVariable "cmdecho", 0
    ThisDrawing.SendCommand "(vl-load-com)" & vbCr
    ThisDrawing.SendCommand "(setq ent (handent " & Chr(34) & obj.Handle & Chr(34) & "))" & vbCr
    ThisDrawing.SendCommand "(setvar " & Chr(34) & "USERR1" & Chr(34) & "(vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)))" & vbCr
   
    MsgBox "所选曲线的长度为 " & str(ThisDrawing.GetVariable("USERR1"))
End Sub

Sub GetLength1()
    Dim obj As AcadEntity
    Dim pnt As Variant
   
    ThisDrawing.Utility.GetEntity obj, pnt, "选取曲线："
      
    MsgBox "所选曲线的长度为 " & str(obj.Length)
End Sub

dnbcgrass

'再来一个
Sub GetLength2()
    Dim obj As AcadEntity
    Dim pnt As Variant
   
    ThisDrawing.SendCommand "(vl-load-com)" & vbCr
    ThisDrawing.SendCommand "(defun getLength(ent) (setq ent (handent ent)) (rtos (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 2 5))" & vbCr
   
    ThisDrawing.Utility.GetEntity obj, pnt, "选取曲线："
  
    ThisDrawing.SendCommand "(getLength " & Chr(34) & obj.Handle & Chr(34) & ")" & vbCr
   
      
    MsgBox "所选曲线的长度为 " & ThisDrawing.GetVariable("LASTPROMPT")
End Sub

dnbcgrass

'来一个真正使用vlax-curve曲线相关函数的
Sub Get_Curve_Length()
    Dim VL As Object
    Dim VLF As Object
    Dim Sym As Object
    Dim Ret As Variant
   
    ThisDrawing.SendCommand "(vl-load-com)" & vbCr
        
    If Left(ThisDrawing.Application.Version, 2) = "15" Then
        Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
    Else
        Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
    End If
   
    Set VLF = VL.ActiveDocument.Functions

    On Error Resume Next
      
    Dim Pnt As Variant
    Dim Ent As AcadEntity
    Dim Pdbz As Boolean
   
    Pdbz = True

    Do While Pdbz
        ThisDrawing.Utility.GetEntity Ent, Pnt, "选择曲线："
               
        If Err <> 0 Then
           Exit Do
        End If
     
        If VarType(Ent) = vbObject Then
           If InStr("AcDbLine,AcDbPolyline,AcDb2dPolyline,AcDb3dPolyline,AcDbSpline,AcDbCircle,AcDbArc,AcDbEllipse", Ent.ObjectName) > 0 Then
              Set Sym = VLF.Item("read").funcall("handle")
              Ret = VLF.Item("set").funcall(Sym, Ent.Handle)

              Set Sym = VLF.Item("read").funcall("(setq curve (handent handle))")
              Set Ret = VLF.Item("eval").funcall(Sym)

              Set Sym = VLF.Item("read").funcall("(vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve))")
              Ret = VLF.Item("eval").funcall(Sym)

              MsgBox "选取的曲线长度＝" & Ret, 64, "提示"
            Else
              MsgBox "选取的曲线不具有长度属性!", 64, "提示"
            End If
            Pdbz = True
        Else
           Pdbz = False
        End If
        
    Loop
   
    Set VLF = Nothing
    Set VL = Nothing
End Sub