【源代码分享】vba 获得鼠标坐标

时间：2019-12-11 08:16 作者：AcadApp 阅读：2231 评论：2

Windows10

其他

CASS9

1.创建 VLAX 类
Private VL As Object
Private VLF As Object
Private Sub Class_Initialize()
     If Left(ThisDrawing.Application.Version, 2) = "15" Then
      Set VL = GetInterfaceObject("VL.Application.1")
     ElseIf Left(ThisDrawing.Application.Version, 2) = "16" Then
      Set VL = GetInterfaceObject("VL.Application.16")
     ElseIf Left(ThisDrawing.Application.Version, 2) = "17" Then
      Set VL = 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(ByVal 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(ByVal symbolName As String, ByVal 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(ByVal 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(ByVal 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
2. 获得鼠标位置
Sub GetCursorLocation()
Dim x, y, z As Double
Dim obj As VLAX
Dim mpoint(0 To 2) As Double
ThisDrawing.SendCommand "(vl-load-com) "
Set obj = New VLAX
obj.EvalLispExpression "(setq CursorLocation(grread 1 1))"
obj.EvalLispExpression "(setq XYZList (cadr CursorLocation))"
obj.EvalLispExpression "(setq x (car XYZList))"
obj.EvalLispExpression "(setq y (cadr XYZList))"
obj.EvalLispExpression "(setq z (caddr XYZList))"
x = obj.GetLispSymbol("x")
y = obj.GetLispSymbol("y")
z = obj.GetLispSymbol("z")
mpoint(0) = x: mpoint(1) = y: mpoint(2) = z
MsgBox Str(x) & "," & Str(y) & "," & Str(z)
obj.NullifySymbol "CursorLocation", "XYZList", "x", "y", "z"
Set obj = Nothing
End Sub

全部评论

等级:LV30

积分:44235

hkai2658 2019-12-11 08:35

太深奥，没有看懂

等级:LV30

积分:1030

76575250@qq.com 2019-12-11 19:31

学习了

1