框选复制图形

hphkjz

哪位大哥能帮忙修改一下这个代码？
下面这个代码可以画闭合区域选择删除框内还是框外。能不能修改成另一种代码，不要画框，直接框选把里面的图形给复制出来，原图不要动。
(defun c:tt (/ box el e2 entl n pt pts ss ss1)
(if (and
(setq e1 (car (xdrx_entsel "\n拾取封闭的多段线<退出>:"
(list (cons 0 "*POLYLINE") '(-4 . "&=") '
(70 . 1)
)
)
)
)
(progn
(redraw e1 3)
t
)
(or
(setq pt (getpoint "\n点取裁剪区域<拾取线外多段线>:"))
(setq e2 (car (xdrx_entsel "\n拾取线外封闭多段线确定裁剪区域<退出>:"
(list (cons 0 "*POLYLINE") '
(-4 . "&=") '(70 . 1)
)
)
)
)
)
)
(progn
(XD::Begin)
(xdrx_document_ucson)
(xdrx_sysvar_push '("cmdecho" 0))
(setq pts (xdrx_getsamplept e1)
ss2 (ssget "cp" pts)
)
(if pt
(progn
(if (XD::Pnt:isInSide pt pts)
(progn
(ssdel e1 ss2)
(if (setq ss3 (ssget "wp" pts))
(command ".erase" ss3 "")
)
(xdrx_pickset_clipbypoly ss2 e1)
(xdrx_object_regen e1)
)
(progn
(setq ss1 (ssget "x")
ss (xdrx_pickset_subtract ss1 ss2)
)
(command ".erase" ss "")
(setq box (xd::entity:box ss2))
(apply
'xdrx_polyline_make
(cons t (XD::Pnts:UCS2WCS box))
)
(setq e2 (entlast))
)
)
)
)
(if e2
(progn
(setq el (XD::Geom:PathIsland e1 e2)
entl (XD::SS:Ents ss2)
)
(foreach n el
(ssdel e2 ss2)
(setq ss2 (xdrx_pickset_clipbypoly ss2 n))
(setq entl (append
(XD::SS:Ents ss2)
entl
)
)
(setq ss2 (XD::Entity->PickSet entl))
(entdel n)
)
(entdel e1)
)
)
(if (and pt e2)
(entdel e2)
)
)
)
(xdrx_sysvar_pop)
(XD::End)
(princ)
)

zxq0220

2. (defun c:tt ();/ pt1 pt2 pt3 pt4 pt5 pt6 pts i e1)
   
3. (setvar "CMDECHO" 0)
   
4. (if (and (setq pt1 (getpoint "\n窗选第一点: "))
   
5.             (setq pt2 (getcorner pt1 "\n窗选第二点: "))) (progn
   
6. (command "_.RECTANG" "non" pt1 "non" pt2)
   
7. (setq e1 (entlast))
   
8. (command "_.COPY" "C" "non" pt1 "non" pt2 "" PAUSE PAUSE)
   
9. (entdel e1)
   
10. (setq e1 (entlast))
    
11. (setq pts (list) i -1)
    
12. (foreach x (entget e1) (if (= (car x) 10) (setq pts (cons (cdr x) pts))))
    
13. (setq pt3 (list (apply 'min (mapcar 'car pts)) (apply 'min (mapcar 'cadr pts))))
    
14. (setq pt4 (mapcar '+ pt3 (mapcar 'abs (mapcar '- pt2 pt1))))
    
15. (setq pt5 (mapcar '- (list (car pt3) (cadr pt4)) '(1 -1)))
    
16. (setq pt6 (mapcar '+ (list (car pt4) (cadr pt3)) '(1 -1)))
    
17. (setq pt3 (mapcar '- pt3 '(1 1)))
    
18. (setq pt4 (mapcar '+ pt4 '(1 1)))
    
19. (command "_.TRIM" e1 "" "F" pt3 pt5 pt4 pt6 pt3 "" "F" pt3 pt5 pt4 pt6 pt3 "" "")
    
20. (entdel e1)
    
21. ))
    
22. (setvar "CMDECHO" 1)
    
23. (princ)
    
24. )
    

(defun c:tt ();/ pt1 pt2 pt3 pt4 pt5 pt6 pts i e1)<br /> (setvar "CMDECHO" 0)<br /> (if (and (setq pt1 (getpoint "\n窗选第一点: "))<br />             (setq pt2 (getcorner pt1 "\n窗选第二点: "))) (progn<br /> (command "_.RECTANG" "non" pt1 "non" pt2)<br /> (setq e1 (entlast))<br /> (command "_.COPY" "C" "non" pt1 "non" pt2 "" PAUSE PAUSE)<br /> (entdel e1)<br /> (setq e1 (entlast))<br /> (setq pts (list) i -1)<br /> (foreach x (entget e1) (if (= (car x) 10) (setq pts (cons (cdr x) pts))))<br /> (setq pt3 (list (apply 'min (mapcar 'car pts)) (apply 'min (mapcar 'cadr pts))))<br /> (setq pt4 (mapcar '+ pt3 (mapcar 'abs (mapcar '- pt2 pt1))))<br /> (setq pt5 (mapcar '- (list (car pt3) (cadr pt4)) '(1 -1)))<br /> (setq pt6 (mapcar '+ (list (car pt4) (cadr pt3)) '(1 -1)))<br /> (setq pt3 (mapcar '- pt3 '(1 1)))<br /> (setq pt4 (mapcar '+ pt4 '(1 1)))<br /> (command "_.TRIM" e1 "" "F" pt3 pt5 pt4 pt6 pt3 "" "F" pt3 pt5 pt4 pt6 pt3 "" "")<br /> (entdel e1)<br /> ))<br /> (setvar "CMDECHO" 1)<br /> (princ)<br /> )<br />

hphkjz

zxq0220 发表于 2013-12-2 08:16

哥，有bug，提示:错误*error*函数中出错参数太多       怎么解决呀！

zxq0220

hphkjz 发表于 2013-12-2 08:35
哥，有bug，提示:错误*error*函数中出错参数太多       怎么解决呀！

程序改了。再试试。

hphkjz

zxq0220 发表于 2013-12-2 19:55
程序改了。再试试。

改了的代码在哪儿呢？哥

zxq0220

hphkjz 发表于 2013-12-2 21:38
改了的代码在哪儿呢？哥

在沙发里。

Free-Lancer

(command ".copy" "C")

hphkjz

zxq0220 发表于 2013-12-2 22:39
在沙发里。

哥，试过了，能用，很不错。不过我看拉出来的图都是把框选时涉及的整根线都拉出来了，这样每次还都要修改。能不能就以框选时的框子为边界复制出来呢？

zxq0220

hphkjz 发表于 2013-12-3 05:34
哥，试过了，能用，很不错。不过我看拉出来的图都是把框选时涉及的整根线都拉出来了，这样每次还都要修改 ...

沙发修理了。

hphkjz

zxq0220 发表于 2013-12-3 08:44
沙发修理了。

哥，有bug，鼠标点了两下屏幕出现个矩形框然后就没反应了

hphkjz

zxq0220 发表于 2013-12-3 08:44
沙发修理了。

哥，我试了一下别人电脑能用，我电脑开始用外挂lisp后，现在打开图纸有时候cad都没有响应，这是怎么回事呀？哥知道么

hphkjz

zxq0220 发表于 2013-12-3 08:44
沙发修理了。

哥，能不能帮我看个代码，我想要在“不加密箍num”支前面加个前缀，变成“TEXT   不加密箍num支”   TEXT要键盘键入。原来代码的运算不要动，只需加个前缀即可，哥，小弟LISP不行，希望你能帮忙给弄弄。
[code=lisp]
(defun c:bjm (/ callback p1 p2 h l txt) (princ "\n此命令为不加密箍筋的数量：")
(defun callback (dynpt /)
(xdrx_entity_move txt p1 dynpt)
(setq p1 dynpt)
)
(if (and (setq p1 (getpoint "\n点击梁净跨第一个点: "))
(setq p2 (getpoint p1 "\n点击梁净跨第二个点: "))
)
(progn
(XD::Begin)
(setq l (fix (+ 0.5 (/ (distance p1 p2) 200)))
txt (xdrx_text_make
p1
(strcat "不加密箍" (itoa l) "支")
200;_字高
0.
)
)
(xdrx_pointmonitor "Callback" txt)
(getpoint)
(xdrx_pointmonitor)
(XD::End)
)
)
(princ)
)