vba能不能获得当前鼠标精确位置?新设想,高手请看看. - VBA/VB/ActiveX/API 编程技术 - AutoCAD论坛 - 明经CAD社区 - 第3页

lee_12345 发表于 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版本 ' <A href="http://www.mjtd.com/" target="_blank" >http://www.mjtd.com</A> ' ' 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 <A href="news://discussion.autodesk.com/autodesk.autocad.customization.vba" target="_blank" >news://discussion.autodesk.com/autodesk.autocad.customization.vba</A>. 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 <A href="http://www.acadx.com/" target="_blank" >http://www.acadx.com</A>

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

anyc100 发表于 2010-11-23 17:15:00

呵呵

页: 1 2 [3]

明经CAD社区's Archiver