[讨论]帮忙修改一下程序（修剪命令工具）

feelg · 发表于 2010-8-5 21:15:00

本帖最后由作者于 2010-8-6 21:09:18 编辑

;;可点可框的修剪
(defun c:tt (/ PO SS I J S1 P1 P2 )
(vl-load-com)
(SETVAR "CMDECHO" 0)
(setvar "osmode" 0)
(setq plist NIL ss nil pt0 nil len NIL)
(if(setq s1 (ssget))(setq len (sslength s1)))
(command "undo" "be")
(cond ((= len 1);;;;;;;;;;;;;;;;;;;;如果是单选
(setq po(getpoint "\n请点选要被剪的一侧:") e1(ssname s1 0))
(command ".offset" 0.2 e1 po "") ;偏移值太小修剪会不准确
(setq en(entlast) dx0(dxf 0 e1))
(if po
(setq plist(dd en))
)
(command "trim" S1 "")
(repeat 5
(command "f")
(apply 'command plist)
(COMMAND "")
)
(COMMAND "")
)
((> len 1);;;;;;;;;;如果是多选
(prompt"\n请选择修剪方式<左击移动/右击框选>:")
(setq code_12 (grread (setq code (grread))));将类型代码 12 的数据从缓冲区中清除
(initget 128)
(if (= (car (setq g (grread nil 4 0))) 3)
(setq fs 3)
(setq fs nil)
)
(cond ((= fs 3);;;;;如果是左击
(setq z t)
(command "trim" s1 "")
(while z
(prompt"\n点击鼠标后开始修剪")
(if g (setq pt(cadr g) g nil)(setq pt (getpoint)))
(if pt
(progn (command "f")
(mapcar'(lambda(x)(command "NON" x)) (getpts))
(command "")
)
(setq z nil)
)
)
(command "")
)
((not fs);;;如果是右击
(setq p1 (getpoint "\n请框选被修剪对象:")
p3 (getcorner p1)
ss (ssget "c" p1 p3)
)
(setq z t)
(while z;
(SETq LEN2 (SSLENGTH SS))
(setq p2 (list (car p1) (cadr p3))
p4 (list (car p3) (cadr p1))
)
(command "trim" s1 "")
(REPEAT LEN2
(COMMAND "NON" "f" p1 p2 p3 p4 p1 "")
)
(COMMAND "")
(setq ss nil)
(initget 128)
(if (setq p1 (getpoint "\n请框选被修剪对象:"))
(setq p3 (getcorner p1)
ss (ssget "c" p1 p3)
)
)
(if (not ss)
(setq z nil)
)
);
);;;
);;;;;
);;;;;;;;;;
((not len);;如果没有选择
(command ".trim" "")
)
);;;;;;;;;;;;;;;;;;;;
(command "undo" "e")
(setvar 'cmdecho 1)
(setvar 'osmode 1)
(PRINC)
)
;;;
(defun dxf(n ename)
(cdr(assoc n (entget ename)))
)
;;;
(defun getpts(/ gr pt0 pt dis)
(setq pts nil)
(setq dis (* 0.001 (getvar "viewsize")))
(while (= 5 (car (setq gr (grread t 4 0))))
(setq pt (cadr gr))
(if (not pt0)
(setq pt0 pt
pts (cons pt0 pts)
)
)
(if (> (distance pt pt0) dis)
(progn
(grdraw pt pt0 1 1)
(setq pts (cons pt pts)
pt0 pt
)
)
)
)
(redraw)
(reverse pts)
)
;;;;
(defun dd (x)
(setq obj x obj(vlax-ename->vla-object obj))
(setq zc (vlax-curve-getdistatparam
obj
(vlax-curve-getendparam obj)
)
)
(setq et(vlax-curve-getEndPoint obj)
st(vlax-curve-getStartPoint obj)
)
(cond ((= dx0 "LINE")
(setq plist(append(list st et))))
((= dx0 "LWPOLYLINE")
(mapcar '(lambda (x)
(if (= (car x) 10)
(setq plist (cons (cdr x) plist))
)
)
(entget en)
)
(if(= 1 (dxf 70 x))(setq p0(car plist) plist(append plist (list p0))))
)
((OR(= dx0 "SPLINE")(= dx0 "CIRCLE")(= dx0 "ELLIPSE"))
(setq zc(fix zc) k 0)
(command "_.divide" x zc)
(setq snew(ssget "p"))
(repeat (sslength snew)
(setq s(ssname snew k))
(setq dx(dxf 10 s))
(setq plist(cons dx plist))
(setq k(1+ k))
)
(command "erase" snew "")
(setq plist(reverse plist))
(IF(/= dx0 "SPLINE")
(setq plist(append plist (list et)))
(setq plist(append (list st) plist (list et)))
)
)
)
(entdel x)
plist
)

;;可点可框的修剪 
(defun c:tt (/ PO SS I J S1 P1 P2 ) 
(vl-load-com) 
(SETVAR "CMDECHO" 0) 
(setvar "osmode" 0) 
(setq    plist NIL ss nil pt0 nil len NIL) 
(if(setq s1 (ssget))(setq len (sslength s1))) 
(command "undo" "be") 
(cond    ((= len 1);;;;;;;;;;;;;;;;;;;;如果是单选 
     (setq po(getpoint "\n请点选要被剪的一侧:") e1(ssname s1 0)) 
     (command ".offset" 0.2 e1 po "") ;偏移值太小修剪会不准确 
     (setq en(entlast) dx0(dxf 0 e1)) 
     (if po 
     (setq plist(dd en)) 
     ) 
     (command "trim" S1 "") 
     (repeat 5 
     (command "f") 
     (apply 'command plist) 
     (COMMAND "") 
     ) 
     
     (COMMAND "") 
    ) 
    ((> len 1);;;;;;;;;;如果是多选 
     (prompt"\n请选择修剪方式<左击移动/右击框选>:") 
     (setq code_12 (grread (setq code (grread))));将类型代码 12 的数据从缓冲区中清除 
     (initget 128) 
     (if (= (car (setq g (grread nil 4 0))) 3) 
     (setq fs 3) 
     (setq fs nil) 
     ) 
     (cond ((= fs 3);;;;;如果是左击 
        (setq z t) 
        (command "trim" s1 "") 
        (while z 
         (prompt"\n点击鼠标后开始修剪") 
         (if g (setq pt(cadr g) g nil)(setq pt (getpoint))) 
         (if pt 
         (progn (command "f") 
         (mapcar'(lambda(x)(command "NON" x)) (getpts)) 
             (command "") 
     ) 
         (setq z nil) 
         ) 
         ) 
        (command "") 
        ) 
        ((not fs);;;如果是右击 
         (setq    p1 (getpoint "\n请框选被修剪对象:") 
            p3 (getcorner p1) 
            ss (ssget "c" p1 p3) 
         ) 
         (setq z t) 
         (while z; 
         (SETq LEN2 (SSLENGTH SS)) 
         (setq p2 (list (car p1) (cadr p3)) 
             p4 (list (car p3) (cadr p1)) 
         ) 
         (command "trim" s1 "") 
         (REPEAT LEN2 
         (COMMAND "NON" "f" p1 p2 p3 p4 p1 "") 
         ) 
         (COMMAND "") 
         (setq ss nil) 
         (initget 128) 
         (if    (setq p1 (getpoint "\n请框选被修剪对象:")) 
         (setq p3 (getcorner p1) 
             ss (ssget "c" p1 p3) 
         ) 
         ) 
         (if    (not ss) 
         (setq z nil) 
         ) 
         ); 
        );;; 
     );;;;; 
     );;;;;;;;;; 
    ((not len);;如果没有选择 
     (command ".trim" "") 
     ) 
    );;;;;;;;;;;;;;;;;;;; 
     (command "undo" "e") 
     (setvar 'cmdecho 1) 
     (setvar 'osmode 1) 
     (PRINC) 
) 
;;; 
(defun dxf(n ename) 
(cdr(assoc n (entget ename))) 
) 
;;; 
(defun getpts(/ gr pt0 pt dis) 
(setq pts nil) 
(setq dis (* 0.001 (getvar "viewsize"))) 
(while (= 5 (car (setq gr (grread t 4 0)))) 
(setq pt (cadr gr)) 
(if    (not pt0) 
(setq pt0    pt 
     pts    (cons pt0 pts) 
) 
) 
(if    (> (distance pt pt0) dis) 
(progn 
    (grdraw pt pt0 1 1) 
    (setq pts (cons pt pts) 
     pt0 pt 
    ) 
) 
) 
) 
(redraw) 
(reverse pts) 
) 
;;;; 
(defun dd (x) 
(setq obj x obj(vlax-ename->vla-object obj)) 
(setq zc (vlax-curve-getdistatparam 
            obj 
            (vlax-curve-getendparam obj) 
         ) 
     ) 
(setq et(vlax-curve-getEndPoint obj) 
    st(vlax-curve-getStartPoint obj) 
    ) 
(cond ((= dx0 "LINE") 
    (setq plist(append(list st et)))) 
    ((= dx0 "LWPOLYLINE") 
(mapcar '(lambda (x) 
            (if (= (car x) 10) 
             (setq plist (cons (cdr x) plist)) 
            ) 
         ) 
         (entget en) 
     ) 
     (if(= 1 (dxf 70 x))(setq p0(car plist) plist(append plist (list p0)))) 
) 
     ((OR(= dx0 "SPLINE")(= dx0 "CIRCLE")(= dx0 "ELLIPSE")) 
(setq zc(fix zc) k 0) 
(command "_.divide" x zc) 
(setq snew(ssget "p")) 
(repeat (sslength snew) 
(setq s(ssname snew k)) 
(setq dx(dxf 10 s)) 
(setq plist(cons dx plist)) 
(setq k(1+ k)) 
) 
(command "erase" snew "") 
     (setq plist(reverse plist)) 
     (IF(/= dx0 "SPLINE") 
     (setq plist(append plist (list et))) 
     (setq plist(append (list st) plist (list et))) 
     ) 
     ) 
) 
(entdel x) 
plist 
)

这个程序有两个缺点，麻烦高手帮忙修改一下。
第一个，程序循环不稳定有时候可以有时不可以用
第二个，每次用完，对象捕捉全部没有。
谢谢，修改完重新上传一下。

AMTONNY · 发表于 2010-8-6 00:08:00

设置对象捕捉如下红色部分代码

;;可点可框的修剪

(defun c:tt (/ PO SS I J S1 P1 P2 )

(vl-load-com)

(setq osvalue (getvar "osmode"))

(SETVAR "CMDECHO" 0)

(setvar "osmode" 0)

。。。。。。。。。。。。

。。。。。。。

(setvar "osmode" osvalue )
(setvar "ORTHOMODE" 1)

feelg · 发表于 2010-8-6 21:33:00

后面这一段LSP具体加在哪个位置的？

AMTONNY · 发表于 2010-8-9 00:27:00

这个程序有两个缺点，麻烦高手帮忙修改一下。

第一个，程序循环不稳定有时候可以有时不可以用

第二个，每次用完，对象捕捉全部没有。

谢谢，修改完重新上传一下。

回楼主，我试过程序没有发现第一个缺点的现象呀，捕捉设置已经添加完成，请试用一下吧

feelg · 发表于 2010-8-9 20:11:00

呵呵，AMTONNY 真是麻烦你，谢谢。

longer1000 · 发表于 2012-2-8 12:01:41

004 · 发表于 2012-12-21 22:41:21

本帖最后由 004 于 2012-12-21 22:42 编辑

http://zml84.blog.sohu.com

;;;==========================================
;;;功能：可以框选的修剪
;;;日期：ZML84 于 2007-08-20
;;;==========================================
(defun C:TT (/ S1 S2 PT1 PT2 CMDECHO_OLD OSMODE_OLD I XX)
(princ "\n★★可以框选的修剪★★")
(setq CMDECHO_OLD (getvar "CMDECHO")
OSMODE_OLD (getvar "OSMODE")
)
(setvar "CMDECHO" 0)
(setvar "OSMODE" 0)
(princ
(strcat
"\n当前设置:投影="
(nth (getvar "PROJMODE") '("不投影" "当前UCS" "当前视图"))
"，边="
(nth (getvar "EDGEMODE") '("不延伸" "延伸"))
)
)
(princ "\n选择剪切边...")
;;若没有选取边界，就将全部对象作为边界
(if (setq S1 (ssget))
()
(setq S1 (ssget "all"))
)
(while (progn (initget 4 "P E U")
(setq PT1
(getpoint
"\n选择要修剪的对象，或 [投影(P)/边(E)/放弃(U)]:"
)
)
)
(cond
;;分支一：投影选项设置
((= PT1 "P")
(progn
(initget 4)
(setq
XX (getint
(strcat
"\n输入投影选项 [无(0)/UCS(1)/视图(2)] <"
(itoa (getvar "PROJMODE"))
">:"
)
)
)
(if (or (= XX 0) (= XX 1) (= XX 2))
(setvar "PROJMODE" XX)
)
)
)
;;分支二：边延伸选项设置
((= PT1 "E")
(progn
(initget 4)
(setq XX (getint
(strcat
"\n输入隐含边延伸模式 [不延伸(0)/延伸(1)] <"
(itoa (getvar "EDGEMODE"))
">:"
)
)
)
(if (or (= XX 0) (= XX 1))
(setvar "EDGEMODE" XX)
)
)
)
;;分支四：撤销上一步操作
((= PT1 "U")
(command "_.undo" 1)
)
;;分支五：对选中的对象进行修剪操作
((listp PT1)
(progn
(if (setq S2 (ssget PT1))
(progn
(command "_.undo" "be")
(command "_.trim" S1 "" S2 "")
(command "_.undo" "e")
)
(if (and (setq PT2
(getcorner PT1
" >>>第二角点: "
)
)
(setq S2 (ssget "c" PT1 PT2))
)
(progn
(command "_.undo" "be")
(command "_.trim" S1 "")
(setq I 0)
(repeat (sslength S2)
(command
(list (ssname S2 I) PT1)
)
(setq I (1+ I))
)
(command "")
(command "_.undo" "e")
)
(princ "\n★未选择到对象。")
)
)
)
) ;_结束分支五
) ;_结束 cond 结束分支
) ;_结束 while
(setvar "OSMODE" OSMODE_OLD)
(setvar "CMDECHO" CMDECHO_OLD)
(princ "\n★正常结束。谢谢使用。")
(princ)
) ;_结束 defun
;;;===========================================================
(alert (princ "\n★可以框选的修剪。\n键入命令\"TT\"执行。"))
(princ)

;;;========================================== 
 
;;;功能：可以框选的修剪 
;;;日期：ZML84 于 2007-08-20 
;;;========================================== 
(defun C:TT (/ S1 S2 PT1 PT2 CMDECHO_OLD OSMODE_OLD I XX) 
    (princ "\n★★可以框选的修剪★★") 
    (setq CMDECHO_OLD (getvar "CMDECHO") 
          OSMODE_OLD  (getvar "OSMODE") 
    ) 
    (setvar "CMDECHO" 0) 
    (setvar "OSMODE" 0) 
    (princ 
        (strcat 
            "\n当前设置:投影=" 
            (nth (getvar "PROJMODE") '("不投影" "当前UCS" "当前视图")) 
            "，边=" 
            (nth (getvar "EDGEMODE") '("不延伸" "延伸")) 
        ) 
    ) 
    (princ "\n选择剪切边...") 
    ;;若没有选取边界，就将全部对象作为边界 
    (if        (setq S1 (ssget)) 
        () 
        (setq S1 (ssget "all")) 
    ) 
    (while (progn (initget 4 "P E U") 
                  (setq        PT1 
                           (getpoint 
                               "\n选择要修剪的对象，或 [投影(P)/边(E)/放弃(U)]:" 
                           ) 
                  ) 
           ) 
        (cond 
            ;;分支一：投影选项设置 
            ((= PT1 "P") 
             (progn 
                 (initget 4) 
                 (setq 
                     XX        (getint 
                            (strcat 
                                "\n输入投影选项 [无(0)/UCS(1)/视图(2)] <" 
                                (itoa (getvar "PROJMODE")) 
                                ">:" 
                            ) 
                        ) 
                 ) 
                 (if (or (= XX 0) (= XX 1) (= XX 2)) 
                     (setvar "PROJMODE" XX) 
                 ) 
             ) 
            ) 
            ;;分支二：边延伸选项设置 
            ((= PT1 "E") 
             (progn 
                 (initget 4) 
                 (setq XX (getint 
                              (strcat 
                                  "\n输入隐含边延伸模式 [不延伸(0)/延伸(1)] <" 
                                  (itoa (getvar "EDGEMODE")) 
                                  ">:" 
                              ) 
                          ) 
                 ) 
                 (if (or (= XX 0) (= XX 1)) 
                     (setvar "EDGEMODE" XX) 
                 ) 
             ) 
            ) 
            ;;分支四：撤销上一步操作 
            ((= PT1 "U") 
             (command "_.undo" 1) 
            ) 
            ;;分支五：对选中的对象进行修剪操作 
            ((listp PT1) 
             (progn 
                 (if (setq S2 (ssget PT1)) 
                     (progn 
                         (command "_.undo" "be") 
                         (command "_.trim" S1 "" S2 "") 
                         (command "_.undo" "e") 
                     ) 
                     (if (and (setq PT2 
                                       (getcorner PT1 
                                                  " >>>第二角点: " 
                                       ) 
                              ) 
                              (setq S2 (ssget "c" PT1 PT2)) 
                         ) 
                         (progn 
                             (command "_.undo" "be") 
                             (command "_.trim" S1 "") 
                             (setq I 0) 
                             (repeat (sslength S2) 
                                 (command 
                                     (list (ssname S2 I) PT1) 
                                 ) 
                                 (setq I (1+ I)) 
                             ) 
                             (command "") 
                             (command "_.undo" "e") 
                         ) 
                         (princ "\n★未选择到对象。") 
                     ) 
                 ) 
             ) 
            ) ;_结束 分支五 
        ) ;_结束 cond 结束分支 
    ) ;_结束 while 
    (setvar "OSMODE" OSMODE_OLD) 
    (setvar "CMDECHO" CMDECHO_OLD) 
    (princ "\n★正常结束。谢谢使用。") 
    (princ) 
) ;_结束 defun 
;;;=========================================================== 
(alert (princ "\n★可以框选的修剪。\n键入命令\"TT\"执行。")) 
(princ)

注册 · 发表于 2012-12-23 21:49:20

高板的cad不是自带吗？

账号		自动登录	找回密码
密码			注册

[讨论]帮忙修改一下程序（修剪命令工具）

本帖子中包含更多资源

本帖子中包含更多资源