[转贴]：VLAX类库
提供Lisp接口，增强VBA的开发功能。以下是调用前应注意的。AutoCAD 或 Visual LISP 启动时并没有自动加载 ActiveX 功能，所以，如果要使用 ActiveX，就必须确保已加载了 ActiveX。下述函数可以完成该任务：
(vl-load-com)
如果没有加载 ActiveX 支持程序，那么运行 vl-load-com 可以初始化 AutoLISP ActiveX 环境。如果已加载 ActiveX，vl-load-com 将不做任何工作。
VERSION 1.0 CLASS
BEGIN
MultiUse = -1'True
END
Attribute VB_Name = "VLAX"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' VLAX.CLS v1.4 (Last updated 8/27/2001)
' Copyright 1999-2001 by Frank Oquendo
'
' 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. Government 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 news://discussion.autodesk.com/autodesk.autocad.customization.vba. 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()
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) '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处理曲线类对象的能力。
VERSION 1.0 CLASS
BEGIN
MultiUse = -1'True
END
Attribute VB_Name = "Curve"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' Curve.cls v1.3 (Last updated 12/18/2001)
' Copyright 2000, 2001 by Frank Oquendo
'
' 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. Government 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.
'
' Curve.cls allows developers to access the various VLAX-CURVE functions
' from Visual Basic or VBA.
'
' Notes:
' I do not claim copyright or authorship of the code being wrapped by this module,
' only on this compilation of that code.
'
' Dependencies:
' Use of this class module requires the following files:
' 1. VLAX.CLS - This file can be obtained by visiting http://www.acadx.com
Private objVLAX As VLAX
Private mvarEntity As AcadEntity
Private types(8) As String
Private Sub Class_Initialize()
Set objVLAX = New VLAX
types(0) = "AcDbCircle": types(1) = "AcDbLine"
types(2) = "AcDbArc": types(3) = "AcDbSpline"
types(4) = "AcDb3dPolyline": types(5) = "AcDbPolyline"
types(6) = "AcDb2dPolyline": types(7) = "AcDbEllipse"
types(8) = "AcDbLeader"
End Sub
Private Sub Class_Terminate()
Set objVLAX = Nothing
End Sub
Public Property Set Entity(ent As AcadEntity)
Dim tmp As String, i As Long, bFound As Boolean
tmp = ent.ObjectName
For i = 0 To 8
If tmp = types(i) Then
Set mvarEntity = ent
bFound = True
Exit For
End If
Next
If Not bFound Then Err.Raise vbObjectError + 1, , "That entity is not a curve."
End Property
Public Property Get Entity() As AcadEntity
Set entityt = mvarEntity
End Property
Public Property Get CurveType() As String
CurveType = mvarEntity.ObjectName
End Property
Public Property Get Area() As Double
Dim retval As Double
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
retval = .EvalLispExpression("(vlax-curve-getArea (handent handle))")
.NullifySymbol "handle"
End With
Area = retval
End Property
Public Property Get Closed() As Boolean
Dim retval As Boolean
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
retval = .EvalLispExpression("(vlax-curve-isClosed (handent handle))")
.NullifySymbol "handle"
End With
Closed = retval
End Property
Public Property Get EndParameter() As Double
Dim retval As Double
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
retval = .EvalLispExpression("(vlax-curve-getEndParam (handent handle))")
.NullifySymbol "handle"
End With
EndParameter = retval
End Property
Public Property Get EndPoint() As Variant
Dim retval As Variant, pt(0 To 2) As Double
Dim i As Long
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.EvalLispExpression "(setq lst (vlax-curve-getEndPoint (handent handle)))"
retval = .GetLispList("lst")
.NullifySymbol "handle", "lst"
End With
For i = 0 To 2
pt(i) = retval(i)
Next
EndPoint = pt
End Property
Public Function GetClosestPointTo(Point, Optional Extend As Boolean = False) As Variant
Dim retval As Variant, pt(0 To 2) As Double
Dim i As Long
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.SetLispSymbol "givenPt", Point
If Extend Then .EvalLispExpression "(setq ext T)"
.EvalLispExpression "(setq lst (vlax-curve-getClosestPointTo (handent handle) givenPt ext))"
retval = .GetLispList("lst")
.NullifySymbol "handle", "lst", "ext", "givenPt"
End With
For i = 0 To 2
pt(i) = retval(i)
Next
GetClosestPointTo = pt
End Function
Public Function GetDistanceAtParameter(Param As Double) As Double
Dim retval As Double
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.SetLispSymbol "param", Param
retval = .EvalLispExpression("(vlax-curve-getDistAtParam (handent handle) param)")
.NullifySymbol "handle", "param"
End With
GetDistanceAtParameter = retval
End Function
Public Function GetDistanceAtPoint(Point As Variant) As Double
Dim retval As Double
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.SetLispSymbol "point", Point
retval = .EvalLispExpression("(vlax-curve-getDistAtPoint (handent handle) point)")
.NullifySymbol "handle", "point"
End With
GetDistanceAtPoint = retval
End Function
Public Function GetFirstDerivative(Param As Double) As Variant
Dim retval As Variant
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.SetLispSymbol "param", Param
.EvalLispExpression "(setq lst (vlax-curve-getFirstDeriv (handent handle) param))"
retval = .GetLispList("lst")
.NullifySymbol "handle", "param", "lst"
End With
GetFirstDerivative = retval
End Function
Public Function GetParameterAtDistance(Dist As Double) As Double
Dim retval As Double
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.SetLispSymbol "dist", Dist
retval = .EvalLispExpression("(vlax-curve-getParamAtDist (handent handle) dist)")
.NullifySymbol "handle", "dist"
End With
GetParameterAtDistance = retval
End Function
Public Function GetParameterAtPoint(Point As Variant) As Double
Dim retval As Double
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.SetLispSymbol "point", Point
retval = .EvalLispExpression("(vlax-curve-getparamAtPoint (handent handle) point)")
.NullifySymbol "handle", "point"
End With
GetParameterAtPoint = retval
End Function
Public Function GetPointAtDistance(Dist As Double) As Variant
Dim retval As Variant, pt(0 To 2) As Double
Dim i As Long
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.SetLispSymbol "dist", Dist
.EvalLispExpression "(setq lst (vlax-curve-getPointAtDist (handent handle) dist))"
retval = .GetLispList("lst")
.NullifySymbol "handle", "dist", "lst"
End With
For i = 0 To 2
pt(i) = retval(i)
Next
GetPointAtDistance = pt
End Function
Public Function GetPointAtParameter(Param As Double) As Variant
Dim retval As Variant, pt(0 To 2) As Double
Dim i As Long
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.SetLispSymbol "param", Param
.EvalLispExpression "(setq lst (vlax-curve-getPointAtParam (handent handle) param))"
retval = .GetLispList("lst")
.NullifySymbol "handle", "param", "lst"
End With
For i = 0 To 2
pt(i) = retval(i)
Next
GetPointAtParameter = pt
End Function
Public Function GetSecondDerivative(Param As Double) As Variant
Dim retval As Variant
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.SetLispSymbol "param", Param
.EvalLispExpression "(setq lst (vlax-curve-getSecondDeriv (handent handle) param))"
retval = .GetLispList("lst")
.NullifySymbol "handle", "param", "lst"
End With
GetSecondDerivative = retval
End Function
Public Property Get length() As Double
Dim retval As Double
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.EvalLispExpression "(setq curve (handent handle))"
retval = .EvalLispExpression("(vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve))")
.NullifySymbol "handle", "curve"
End With
length = retval
End Property
Public Property Get Periodic() As Boolean
Dim retval As Boolean
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
retval = .EvalLispExpression("(vlax-curve-isPeriodic (handent handle))")
.NullifySymbol "handle"
End With
Periodic = retval
End Property
Public Property Get Planar() As Boolean
Dim retval As Boolean
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
retval = .EvalLispExpression("(vlax-curve-isPlanar (handent handle))")
.NullifySymbol "handle"
End With
Planar = retval
End Property
Public Property Get StartPoint() As Variant
Dim retval As Variant, pt(0 To 2) As Double
dim As Long
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.EvalLispExpression "(setq lst (vlax-curve-getStartPoint (handent handle)))"
retval = .GetLispList("lst")
.NullifySymbol "handle", "lst"
End With
For i = 0 To 2
pt(i) = retval(i)
Next
StartPoint = pt
End Property
Public Function GetClosestPointToProjection(Point As Variant, Normal As Variant, Optional Extend As Boolean = False) As Variant
Dim retval As Variant, pt(0 To 2) As Double
Dim i As Long
With objVLAX
.SetLispSymbol "handle", mvarEntity.Handle
.SetLispSymbol "givenPt", Point
.SetLispSymbol "normal", Normal
If Extend Then .EvalLispExpression "(setq ext T)"
.EvalLispExpression "(setq lst (vlax-curve-getClosestPointToProjection (handent handle) givenPt normal ext))"
retval = .GetLispList("lst")
.NullifySymbol "handle", "lst", "normal", "ext", "givenPt"
End With
For i = 0 To 2
pt(i) = retval(i)
Next
GetClosestPointToProjection = pt
End Function
这个附件是用于vb.net的vlax类库，有兴趣的朋友可以研究一下。 think you 如：
DIM OBJ AS VLAX
SET OBJ =NEW VLAX
在上一行时出错，何故？
另，
上述程序行
Attribute VB_Name = "VLAX"
VB并不支持 终于找到lisp和vba的交流方式了
SetLispSymbol( symbolName, value)
GetLispSymbol(symbolName)
还是容易出错，主要是lisp变量类型会变化，感觉要做个完美的GetLispSymbol比较困难 好东东，可惜我还不能下载。 我很喜欢这个接口，万分感谢 好像兼容性不是很好，使用过程有不稳定的现象 好，有没有更详细的说明，acad帮助中有这个吗？ VB.Net不需vlax类库，vlax类是弥补VBA的缺陷的，可以看Lisp的帮助 最初由 efan2000 发布
下面的类库扩充了VBA处理曲线类对象的能力。
VERSION 1.0 CLASS
BEGIN
MultiUse = -1'True
END
Attribute VB_Name = "Curve"
Attribute VB_GlobalNameSpace = False
Attri...
VERSION 1.0 CLASS
BEGIN
MultiUse = -1'True
END
Attribute VB_Name = "VLAX"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
我搞不清这些东西是什么？所以我把他们注释掉了，可以使用，为什么？？ 很多机器上只有按照2002 vlax类不存在，怎么注册？ 好象看来不错,下拉! 我的CAD2002，vlax类不存在，怎么注册？ 哪里有下，谢谢！！
页:
[1]
2