- 积分
- 245
- 明经币
- 个
- 注册时间
- 2003-7-15
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
发表于 2004-6-6 09:37:00
|
显示全部楼层
别找了!给你,接好了哟!!!
VLAX类 - VLAX.cls:
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 v2.0 (Last updated 8/1/2003) ' Copyright 1999-2001 by Frank Oquendo ' ' 该程序由明经通道修改支持2004版本 ' http://www.mjtd.com ' ' 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()
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)
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
====================================================================================== 曲线操作Curve.cls:
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
|
|