求继续修改，把点选改成框选。
本帖最后由 weiqi 于 2013-1-27 13:14 编辑http://bbs.mjtd.com/thread-100064-1-1.html
之前发过这个帖~得到相关LISP代码后，还不是非常理想。
现在 是点选 框，一次一 次点选，最后一次性输出。
我想得到一个是框选 然后一次性输出全部。
麻烦高手的修改一下。
(defun c:cdx1 (/ lst ss lin data pts xx ens len n str strs pt-ins ptlst)
(setvar "cmdecho" 0)
(princ "\n选择方框<空格退出>:")
(setq lst nil i -1)
(setq ss (ssget (list (cons 0 "lwpolyline"))))
(while (setq lin (ssname ss (setq i (1+ i))))
(setqdata (entget lin)
ptsnil
)
(foreach xx data
(if (= 10 (car xx))
(setq pts (cons (cdr xx) pts))
)
)
;;; (command ".zoom" "W" (car pts) (caddr pts))
(setq ens (ssget "cp" pts '((0 . "TEXT") (8 . "E-PE,e-id"))))
;;; (command ".zoom" "p")
(or ens (setq ens (ssadd)))
(setq len(sslength ens)
n 0
strs nil
)
(while (< n len)
(setq en (ssname ens n)
data (entget en)
)
(setq strs (cons (cons (cdr (assoc 10 data))
(strcat " " (cdr (assoc 1 data)))
)
strs
)
)
(setq n (1+ n))
)
(if strs
(progn
(setq
strs (vl-sort strs
'(lambda (e1 e2) (> (cadar e1) (cadar e2)))
)
)
(setq str "")
(foreach xx strs (setq str (strcat str (cdr xx))))
(initget 1)
(setq lst (cons str lst))
)
(princ "\n不包含指定层文字!")
)
(princ "\n选择方框<空格退出>:")
)
(setq pt-ins (getpoint "\n指定一点:"))
(setq ptlst nil)
(repeat (setq n (length lst))
(setq ptlst (cons pt-ins ptlst)
pt-ins (polar pt-ins (* 1.5 pi) 555)
)
)
(mapcar '(lambda (x y)
(entmake
(list
'(0 . "TEXT")
'(100 . "AcDbEntity")
'(8 . "E-PE")
'(62 . 110)
'(100 . "AcDbText")
(cons 10 y)
'(40 . 444.444)
(cons 1 x)
'(41 . 0.7)
'(7 . "HZ")
)
)
)
lst
ptlst
)
(setvar "cmdecho" 1)
(princ)
)
链接给错了 顶一下，望高手出手
页:
[1]