一个结合Lisp的拖动例子

雪山飞狐_lzh

Lisp函数：，先导入一下

2. (defun Drag( pBlock / ppnt ed ped)
3. (defun GetPoint( / a pnt )
4.    (setq a (grread t))
5.    (setq pnt (list 0 0 1))
6.    (if (= 3 (car a)) (setq pnt (list 0 0 -1)))
7.    (if (= 5 (car a)) (setq pnt (cadr a)))
8.    pnt
9.   )
10.    (while (not (= (caddr (setq ppnt (GetPoint)))   -1))
11.    (setq ed (entget (handent pBlock)))
12.    (setq ped (list 10 (car ppnt) (cadr ppnt) (caddr ppnt)))
13.    (setq ed (subst ped (assoc 10 ed) ed))
14.    (entmod ed)
15.    )
16. )

(defun Drag( pBlock / ppnt ed ped) (defun GetPoint( / a pnt )    (setq a (grread t))    (setq pnt (list 0 0 1))    (if (= 3 (car a)) (setq pnt (list 0 0 -1)))    (if (= 5 (car a)) (setq pnt (cadr a)))    pnt   )    (while (not (= (caddr (setq ppnt (GetPoint)))   -1))    (setq ed (entget (handent pBlock)))    (setq ped (list 10 (car ppnt) (cadr ppnt) (caddr ppnt)))    (setq ed (subst ped (assoc 10 ed) ed))    (entmod ed)    ) )

测试（由于拖动在Lisp中做好了，不需频繁调用Vlax类，应该不会使AutoCAD崩溃）：

2. Sub Test()
3.        Dim obj As VLAX
4.        Dim c(2) As Double
5.        Dim pObj As AcadBlockReference
6.        Set obj = New VLAX
7.        Set pObj = ThisDrawing.ModelSpace.InsertBlock(c, "123", 1, 1, 1, 0)
8.        a = "(drag " & Chr(34) & pObj.Handle & Chr(34) & ")"
9.        obj.EvalLispExpression (a)
10.        Set obj = Nothing
11. End Sub

Sub Test()        Dim obj As VLAX        Dim c(2) As Double        Dim pObj As AcadBlockReference        Set obj = New VLAX        Set pObj = ThisDrawing.ModelSpace.InsertBlock(c, "123", 1, 1, 1, 0)        a = "(drag " & Chr(34) & pObj.Handle & Chr(34) & ")"        obj.EvalLispExpression (a)        Set obj = Nothing End Sub

mikewolf2k

看不懂啊~~~


是不是插入图块时能显示图块？

雪山飞狐_lzh

差不多是这个意思



思路是在VBA里插入一个块


再通过Vlax类调用Lisp函数Drag做拖动


模拟Move命令的操作


（当然没有Move做的好，因为Lisp毕竟不是我的强项，只懂点皮毛）

雪山飞狐_lzh

改良版（不需导入Lisp函数）

2. Public Sub BlockInsert(Name As String)
3.        Dim pLisp As String
4.        Dim obj As VLAX
5.        Dim pnt(2) As Double
6.        Set obj = New VLAX
7.        Set pObj = ThisDrawing.ModelSpace.InsertBlock(pnt, Name, 1, 1, 1, 0)
8.        obj.EvalLispExpression "(setq ed (entget (handent " & ToStr(pObj.Handle) & ")))"
9.        pLisp = "(while (not (= (caddr " & _
10.                        "(setq pTime (grread t) " & _
11.                                    "pSt (car pTime) " & _
12.                                    "pnt (cond ((= pSt 3) (List 0 0 -1)) ((= pSt 5) (cadr pTime)) (t (List 0 0 1)))))   -1)) " & _
13.                        "(setq ed (subst (cons 10 pnt) (assoc 10 ed) ed)) " & _
14.                        "(entmod ed) " & _
15.                        ") "
16.        obj.EvalLispExpression pLisp
17.        Set obj = Nothing
18. End Sub

Public Sub BlockInsert(Name As String)        Dim pLisp As String        Dim obj As VLAX        Dim pnt(2) As Double        Set obj = New VLAX        Set pObj = ThisDrawing.ModelSpace.InsertBlock(pnt, Name, 1, 1, 1, 0)        obj.EvalLispExpression "(setq ed (entget (handent " & ToStr(pObj.Handle) & ")))"        pLisp = "(while (not (= (caddr " & _                        "(setq pTime (grread t) " & _                                    "pSt (car pTime) " & _                                    "pnt (cond ((= pSt 3) (List 0 0 -1)) ((= pSt 5) (cadr pTime)) (t (List 0 0 1)))))   -1)) " & _                        "(setq ed (subst (cons 10 pnt) (assoc 10 ed) ed)) " & _                        "(entmod ed) " & _                        ") "        obj.EvalLispExpression pLisp        Set obj = Nothing End Sub

2. Public function ToStr(ByVal str) As String
3.        ToStr = Chr(34) & str & Chr(34)
4. End Function

Public function ToStr(ByVal str) As String        ToStr = Chr(34) & str & Chr(34) End Function

2. Sub test()
3.        BlockInsert "123"
4. End Sub

Sub test()        BlockInsert "123" End Sub

cag

2002怎么没有VLAX类？

mikewolf2k

vlax 如何引用？


"Dim obj As VLAX"

雪山飞狐_lzh

Dim obj As VLAX
Set obj = New VLAX

mikewolf2k

执行到"Dim obj As VLAX"是显示用户类型未定义。也就是说你的代码不能直接运行（cad2000）。请指教，谢谢。

雪山飞狐_lzh

VLAX类未导入

mikewolf2k

究竟怎么导入？我对vlax一窍不通。


要想运行你的代码，还要设置些什么？谢谢