vba能不能获得当前鼠标精确位置?新设想,高手请看看.

lee_12345

别找了!给你,接好了哟!!! 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

anyc100

呵呵