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

my_computer

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=9328

lee_12345

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=9328

lee_12345

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=9328

雪山飞狐_lzh

将VLAX类的EvalLispExpression子程改动一下可以实现

2. Public Function EvalLispExpression(lispStatement As String)
3.        On Error GoTo ErrClear
4.        Dim sym As Object, ret As Object, retVal
5.        EvalLispExpression = ""
6.        Set sym = VLF.Item("read").funcall(lispStatement)
7.        retVal = VLF.Item("eval").funcall(sym)
8.        EvalLispExpression = retVal
9. ErrClear:
10.        Err.Clear
11. End Function

Public Function EvalLispExpression(lispStatement As String)        On Error GoTo ErrClear        Dim sym As Object, ret As Object, retVal        EvalLispExpression = ""        Set sym = VLF.Item("read").funcall(lispStatement)        retVal = VLF.Item("eval").funcall(sym)        EvalLispExpression = retVal ErrClear:        Err.Clear End Function

总觉得VLAX类不太健壮测试（插入一个块，拖动并旋转）：先导入Lisp函数dd，再生成一个名为"123"的块

2. Sub Test()
3. On Error Resume Next
4.        Dim obj As VLAX, retVal
5.        Dim a As String, b
6.        Dim c(2) As Double, d(2) As Double
7.        Dim pObj As AcadBlockReference, pLine As AcadLine
8.        Set obj = New VLAX
9.        retVal = obj.EvalLispExpression("(dd)")
10.        Set obj = Nothing
11.        a = Split(retVal, ",")(0)
12.        Err.Clear
13.        Set pObj = ThisDrawing.ModelSpace.InsertBlock(c, "123", 1, 1, 1, 0)
14.        ThisDrawing.Utility.Prompt vbCr & "请输入插入点:" & vbCr
15.        Do While a <> "3"
16.                Set obj = New VLAX
17.                retVal = obj.EvalLispExpression("(dd)")
18.                Set obj = Nothing
19.                a = Split(retVal, ",")(0)
20.                Err.Clear
21.                If a = 5 Then
22.                        b = Split(retVal, ",")
23.                        Err.Clear
24.                        c(0) = b(1)
25.                        c(1) = b(2)
26.                        pObj.InsertionPoint = c
27.                        Err.Clear
28.                End If
29.        Loop
30.        a = 5
31.        ThisDrawing.Utility.Prompt vbCr & "请输入旋转角度:" & vbCr
32.        Set pLine = ThisDrawing.ModelSpace.AddLine(c, d)
33.        Do While a <> "3"
34.                Set obj = New VLAX
35.                retVal = obj.EvalLispExpression("(dd)")
36.                Set obj = Nothing
37.                a = Split(retVal, ",")(0)
38.                Err.Clear
39.                If a = 5 Then
40.                        b = Split(retVal, ",")
41.                        Err.Clear
42.                        c(0) = b(1)
43.                        c(1) = b(2)
44.                        pLine.EndPoint = c
45.                        pObj.Rotation = ThisDrawing.Utility.AngleFromXAxis(pObj.InsertionPoint, c)
46.                        Err.Clear
47.                End If
48.        Loop
49.        pLine.Delete
50. End Sub

Sub Test() On Error Resume Next        Dim obj As VLAX, retVal        Dim a As String, b        Dim c(2) As Double, d(2) As Double        Dim pObj As AcadBlockReference, pLine As AcadLine        Set obj = New VLAX        retVal = obj.EvalLispExpression("(dd)")        Set obj = Nothing        a = Split(retVal, ",")(0)        Err.Clear        Set pObj = ThisDrawing.ModelSpace.InsertBlock(c, "123", 1, 1, 1, 0)        ThisDrawing.Utility.Prompt vbCr & "请输入插入点:" & vbCr        Do While a <> "3"                Set obj = New VLAX                retVal = obj.EvalLispExpression("(dd)")                Set obj = Nothing                a = Split(retVal, ",")(0)                Err.Clear                If a = 5 Then                        b = Split(retVal, ",")                        Err.Clear                        c(0) = b(1)                        c(1) = b(2)                        pObj.InsertionPoint = c                        Err.Clear                End If        Loop        a = 5        ThisDrawing.Utility.Prompt vbCr & "请输入旋转角度:" & vbCr        Set pLine = ThisDrawing.ModelSpace.AddLine(c, d)        Do While a <> "3"                Set obj = New VLAX                retVal = obj.EvalLispExpression("(dd)")                Set obj = Nothing                a = Split(retVal, ",")(0)                Err.Clear                If a = 5 Then                        b = Split(retVal, ",")                        Err.Clear                        c(0) = b(1)                        c(1) = b(2)                        pLine.EndPoint = c                        pObj.Rotation = ThisDrawing.Utility.AngleFromXAxis(pObj.InsertionPoint, c)                        Err.Clear                End If        Loop        pLine.Delete End Sub

Lisp函数

2. (defun dd()
3.    (setq a (grread t))
4.    (if (OR (= 3 (car a)) (= 5 (car a)))
5.        (setq str (strcat (itoa (car a))
6.                ","
7.                (rtos (caadr a) 2 4)
8.                ","
9.                (rtos (cadadr a) 2 4)
10.                ","
11.                (rtos (cadr (cdadr a)) 2 4)
12.              )
13.        )
14.    )
15.    (IF (OR (= 2 (car a)) (= 11 (car a)))
16.        (setq str (strcat (itoa (car a))
17.                ","
18.                (itoa (cadr a))
19.              )
20.        )
21.    )
22.        str
23.   )

(defun dd()    (setq a (grread t))    (if (OR (= 3 (car a)) (= 5 (car a)))        (setq str (strcat (itoa (car a))                ","                (rtos (caadr a) 2 4)                ","                (rtos (cadadr a) 2 4)                ","                (rtos (cadr (cdadr a)) 2 4)              )        )    )    (IF (OR (= 2 (car a)) (= 11 (car a)))        (setq str (strcat (itoa (car a))                ","                (itoa (cadr a))              )        )    )        str   )

雪山飞狐_lzh

还是VLAX类不够健壮的原因，上述测试有10％的几率会使AutoCad崩溃



可能需要在VBA与Lisp间传递数据，使VBA中的While语句等VLAX处理完Lisp语句后再运行下次循环


或者将程序分为两部分，橡皮筋处理用Lisp做，其余的用VBA做

雪山飞狐_lzh

2. Function GetPoint()
3. '功能：返回当前鼠标状态
4. 'Vlax类请小心使用，该函数可能使AutoCad崩溃
5. '返回值：一维数组
6. '返回0，0，－1表示按下鼠标左键，返回0，0，1表示按下鼠标右键，返回a，b，0表示当前鼠标坐标
7. On Error GoTo ErrClear
8. Dim obj As VLAX
9. Dim pRetVal(2) As Double, retVal
10. Set obj = New VLAX
11. obj.EvalLispExpression ("(setq a (grread t) b (car a) c (cadr a))")
12. Select Case obj.GetLispSymbol("b")
13. Case 3
14. pRetVal(2) = -1
15. Case 5
16. retVal = obj.GetLispList("c")
17. pRetVal(0) = retVal(0)
18. pRetVal(1) = retVal(1)
19. Case Else
20. pRetVal(2) = 1
21. End Select
22. GetPoint = pRetVal
23. ErrClear:
24. Set obj = Nothing
25. End Function

Function GetPoint() '功能：返回当前鼠标状态 'Vlax类请小心使用，该函数可能使AutoCad崩溃 '返回值：一维数组 '返回0，0，－1表示按下鼠标左键，返回0，0，1表示按下鼠标右键，返回a，b，0表示当前鼠标坐标 On Error GoTo ErrClear Dim obj As VLAX Dim pRetVal(2) As Double, retVal Set obj = New VLAX obj.EvalLispExpression ("(setq a (grread t) b (car a) c (cadr a))") Select Case obj.GetLispSymbol("b") Case 3 pRetVal(2) = -1 Case 5 retVal = obj.GetLispList("c") pRetVal(0) = retVal(0) pRetVal(1) = retVal(1) Case Else pRetVal(2) = 1 End Select GetPoint = pRetVal ErrClear: Set obj = Nothing End Function

2. Sub Test()
3. On Error Resume Next
4. Dim c(2) As Double
5.        Do While 1
6.        a = GetPoint
7.        ThisDrawing.Utility.Prompt a(0) & "," & a(1) & "," & a(2) & vbCrLf
8.        Select Case a(2)
9.        Case -1
10.        Exit Sub
11.        Case 0
12.        Case 1
13.        End Select
14.        Loop
15. End Sub

Sub Test() On Error Resume Next Dim c(2) As Double        Do While 1        a = GetPoint        ThisDrawing.Utility.Prompt a(0) & "," & a(1) & "," & a(2) & vbCrLf        Select Case a(2)        Case -1        Exit Sub        Case 0        Case 1        End Select        Loop End Sub

yingxunxue

lzh741206发表于2004-5-13 13:01:00Function GetPoint()'功能：返回当前鼠标状态'Vlax类请小心使用，该函数可能使A...

求助VLAX的使用,上面这段程序怎么用不了,好象直接跳出去了,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.FunctionsEnd Sub  到Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")直接跳到ErrCleargetpoint函数)
Set obj = Nothing

复制代码

mccad

有关VL类不能使用问题主要是该控件没有注册，必须先注册。

yingxunxue

如何注册?希望指点一下!

yicol

好复杂啊