紧急求助：谁能编一个框选水平直线、竖直直线的LISP透明命令

lskang001

紧急求助：谁能编一个框选水平直线、竖直直线的LISP透明命令

功能：1、要求为透明命令，以方便在某些CAD命令提示选择对象时可以采用。

           2、框选范围内判断是水平直线（Y坐标增量为0）还是竖直直线（X坐标增量为0）。

           3、虽然用CAD里的快速选择命令可以实现该功能，但是我想要一个LISP的透明命令，因为我想在在其他的LISP程序中调用它，而快速选择中的选择方法我没法调用（就算调用也还需要手动选择几个选项，没法自动化）。

           请高手帮忙，虽然大致知道怎么判断（比如用程序判断X或Y坐标增量是否为0，或判断该条直线的角度是否为0度或90度），小弟LISP不怎么行，写了好久也没反映。

谢谢。

lskang001

顶起来

淮上

透明命令可以定义，但和当前命令交换数据似乎有点麻烦

lskang001

如果实在做不成透明的指令，那么不透明的也可以啊，知识透明的会更方便的使用

lskang001

哎，没人帮忙编，只好自己来乱凑了，凑了好久，凑出了几句语句，可不知道为什么，提示语法错误，请帮忙看下哪里有问题：

(defun c:ttt(/ ss n i ent1 ang1)
   (setq ss (ssget '((0 . "line")))) 
   (if ss                   
     (setq n (sslength ss))
   )                                
   (setq i 0)
   (while (< i n)                   
     (setq ent1 (ssname ss i))
     (setq p1 (entget ent1))
     (setq ang1 (angle (dxf 10 p1)(dxf 11 p1)))
     (if ang1
        (ssdel ent1 ss)
        (setq i (- i 1))
        (setq n (- n 1))
        )
     (setq i (1+ i))
   )
  (command "erase" ss "")
  (princ)
)

(defun dxf (code elist) (cdr (assoc code elist)))

命令: ; 错误: 语法错误
命令: ; 错误: 语法错误

lskang001

试了大半夜

初步调整成这样

大家看看对不对

水平线的：

(defun c:ttt(/ ss n i ent1 ang1)
   (setq ss (ssget '((0 . "line"))))
   (if ss                   
     (setq n (sslength ss))
   )                                
   (setq i 0)
   (while (< i n)                   
     (setq ent1 (ssname ss i))
     (setq p1 (entget ent1))
     (setq ang1 (angle (dxf 10 p1)(dxf 11 p1)))
     (if (not(or(= ang1 0)(= ang1 pi)(= dang (- 0 pi)))) (ssdel ent1 ss))
     (if (not(or(= ang1 0)(= ang1 pi)(= dang (- 0 pi)))) (setq i (- i 1)))
     (if (not(or(= ang1 0)(= ang1 pi)(= dang (- 0 pi)))) (setq n (- n 1)))
     (setq i (1+ i))
   )
  (command "erase" ss "")
  (princ)
)；其中最后的SS为处理过的选择集，就是我们要的水平线

(defun dxf (code elist) (cdr (assoc code elist)))

垂直线的：

(defun c:czz(/ ss n i ent1 ang1)
   (setq ss (ssget '((0 . "line"))))
   (if ss                   
     (setq n (sslength ss))
   )                                
   (setq i 0)
   (while (< i n)                   
     (setq ent1 (ssname ss i))
     (setq p1 (entget ent1))
     (setq ang1 (angle (dxf 10 p1)(dxf 11 p1)))
     (if (not(or(= ang1 (/ pi 2))(= ang1 (- 0 (/ pi 2)))(= ang1 (+ pi (/ pi 2)))(= ang1 (- 0 (+ pi (/ pi 2)))))) (ssdel ent1 ss))
     (if (not(or(= ang1 (/ pi 2))(= ang1 (- 0 (/ pi 2)))(= ang1 (+ pi (/ pi 2)))(= ang1 (- 0 (+ pi (/ pi 2)))))) (setq i (- i 1)))
     (if (not(or(= ang1 (/ pi 2))(= ang1 (- 0 (/ pi 2)))(= ang1 (+ pi (/ pi 2)))(= ang1 (- 0 (+ pi (/ pi 2)))))) (setq n (- n 1)))
     (setq i (1+ i))
   )
  (command "erase" ss "")
  (princ)
))；其中最后的SS为处理过的选择集，就是我们要的垂直线

(defun dxf (code elist) (cdr (assoc code elist)))

Andyhon

3. (vl-load-com)
4. ;; acet-* required
5. (Defun HVLineSS (2Test)
6.    (setq nn (sslength 2Test))
7.    (while (setq ee (ssname 2Test (setq nn (1- nn))))
8.      (mapcar 'set '(pa pb) (acet-ent-geomextents ee))
9.      (if
10.        (or
11.          (equal (car pa) (car pb) 1e-13)
12.          (equal (cadr pa) (cadr pb) 1e-13)
13.        )
14.        nil                  ; (entdel ee)
15.        (ssdel ee 2Test)
16.     )
17.   )
18.   2Test
19. )
20. (Defun HV ()
21.    (Cond
22.     ((null (setq ss (ssget '((0 . "LINE"))))) nil)
23.     (T (setq rtn (HVLineSS ss)))
24.    )
25.    (vla-SendCommand
26.      (vla-get-ActiveDocument (vlax-get-acad-object))
27.      "!rtn "
28.    )
29. )
30. (vlax-remove-cmd "hv")
31. (vlax-add-cmd "hv" 'hv "hv" ACRX_CMD_TRANSPARENT)

(vl-load-com) ;; acet-* required (Defun HVLineSS (2Test)    (setq nn (sslength 2Test))    (while (setq ee (ssname 2Test (setq nn (1- nn))))      (mapcar 'set '(pa pb) (acet-ent-geomextents ee))      (if        (or          (equal (car pa) (car pb) 1e-13)          (equal (cadr pa) (cadr pb) 1e-13)        )        nil                  ; (entdel ee)        (ssdel ee 2Test)     )   )   2Test ) (Defun HV ()    (Cond     ((null (setq ss (ssget '((0 . "LINE"))))) nil)     (T (setq rtn (HVLineSS ss)))    )    (vla-SendCommand      (vla-get-ActiveDocument (vlax-get-acad-object))      "!rtn "    ) ) (vlax-remove-cmd "hv") (vlax-add-cmd "hv" 'hv "hv" ACRX_CMD_TRANSPARENT)

=====================================================
Command: copy
Select objects: 'hv                   ; TRANSPARENT
>>Select objects: All 8 found
>>Select objects:
Resuming COPY command.
Select objects: !rtn <Selection set: 28>
6 found
Select objects:
.....

淮上

变量 rtn 如何清除呢？

lskang001

; 错误: no function definition: ACET-ENT-GEOMEXTENTS
正在恢复执行 COPY 命令。

我运行起来，说是ACET-ENT-GEOMEXTENTS函数没定义，查了好象是EXPRESSTOOL中的公共函數，但是我用的是CAD2009，没法装这个EXPRESSTOOL，请问怎么办？