修剪并倒角程序修改倒角大小请教

lxdz443

下面的程序，修剪后只能倒直角，现在想改为提示输入倒角大小。我将(setvar "filletrad" 0.0)里面的0.0改为5.0后还是直角，请教该如何修改。原帖链接：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=96716&page=1#pid553496
源程序：
(defun cutnum_lst (oldlst num / k templst)
  (setq        k 0
        templst        '()
  )
  (foreach n oldlst
    (if        (/= k num)
      (setq templst (cons n templst)
            k            (1+ k)
      )
    )
    (setq k (1+ k))
  )
  (setq newlst (reverse templst))
)
;;去除表中指定项
(defun drop (lst item)
  (append (reverse (cdr (member item (reverse lst))))
          (cdr (member item lst))
  )
)
;;将点表中在方框内的点组成新表
(defun pt_inm (oldlst PT1 PT2 PT3 PT4 /        oldlist        n pt1 pt2 pt3 pt4
               templst newlst)
  (setq templst '())
  (foreach n oldlst
    (if        (/= (point_inm n pt1 pt2 pt3 pt4) nil)
      (setq templst (cons n templst))
    )
  )
  (setq newlst (reverse templst))
)
;;将点表中在多边形内的点组成新表
(defun pt_inmx (oldlst pm)
  (setq templst '())
  (foreach n oldlst
    (if        (ea:point_inm n pm)
      (setq templst (cons n templst))
    )
  )
  (setq newlst (reverse templst))
)
;;判断两点是否等
(defun eq_point        (pt1 pt2)
  (if (and (equal (car pt1) (car pt2) 1e-5)
           (equal (cadr pt1) (cadr pt2) 1e-5)
      )
    t
    nil
  )
)
;;判断两直线是否相交
(defun line_int        (se1 se2)
  (if (/= (inters (cdr (assoc 10 (entget se1)))
                  (cdr (assoc 11 (entget se1)))
                  (cdr (assoc 10 (entget se2)))
                  (cdr (assoc 11 (entget se2)))
                  t
          )
          nil
      )
    t
    nil
  )
)
;;点到直线的垂直距离
(defun point_line (pt pt1 pt2 / ptangle ptn pt pt1 pt2 dist jptx)
  (setq        ptangle        (angle pt1 pt2)
        ptn        (polar pt (+ (* 0.5 pi) ptangle) 0.01)
        jptx        (inters pt ptn pt1 pt2 nil)
        dist        (distance pt jptx)
  )
  dist
)
;;判断点是否在方框内
(defun point_inm (pt pt1 pt2 pt3 pt4 / dist1 dist2 dist3 dist4 pt pt1
                  pt2 pr3 pt4)
  (setq        dist1 (point_line pt pt1 pt2)
        dist2 (point_line pt pt2 pt3)
        dist3 (point_line pt pt1 pt4)
        dist4 (point_line pt pt3 pt4)
  )
  (if (equal (+ dist1 dist2 dist3 dist4)
             (+ (distance pt1 pt2) (distance pt2 pt3))
             1e-10
      )
    t
    nil
  )
)
;;测试点是否在多边形内.
(defun ea:point_inm
       (p pm / point_x mx px1 pm edge_int_num pt_online_num)
  (setq        point_x        (mapcar '(lambda (x) (car x)) pm)
        mx        (abs (- (apply 'max point_x) (car p)))
        px1        (polar p 0 (* mx 2))
  )
  (setq        pm              (append pm (list (nth 0 pm)))
        edge_int_num  0
        pt_online_num 0
  )
  (while (> (length pm) 1)
    (setq pc (nth 0 pm)
          pn (nth 1 pm)
    )
    (if        (inters p px1 pc pn)
      (setq edge_int_num (+ 1 edge_int_num))
    )
    (if        (equal (angle p pc) 0 1e-5)
      (setq pt_online_num (+ 1 pt_online_num))
    )
    (if        (and (equal (angle p pc) 0 1e-5)
             (equal (angle p pn) 0 1e-5)
        )
      (setq pt_online_num (- pt_online_num 1))
    )
    (setq pm (cdr pm))
    (if        (= (rem (+ pt_online_num edge_int_num) 2) 1)
      t
      nil
    )
  )
)
;;清理表中的重复项
(defun purge_lst (lst / n m lst1 tmplist)
  (setq        tmplist        '()
        tmplist        (cons (car lst) tmplist)
        lsttmp        (cutnum_lst lst 0)
  )
  (setq        n (length lsttmp)
        m 0
  )
  (while (/= m n)
    (setq id   '()
          lst1 (nth m lsttmp)
    )
    (foreach na        tmplist
      (if (= (eq_point na lst1) nil)
        (setq id (cons 0 id))
        (setq id (cons 1 id))
      )
    )
    (if        (= (member '1 id) nil)
      (setq tmplist (cons lst1 tmplist))
    )
    (setq m (1+ m))
  )
  (setq tmplist (reverse tmplist))
)
;;计算两点的中点
(defun mpt (mpt1 mpt2)
  (polar mpt1 (angle mpt1 mpt2) (/ (distance mpt1 mpt2) 2))
)

(defun se_426 (pt)
  (setq        sex1           (ssname (ssget "c" pt pt) 0)
        sex1ent           (entget sex1)
        sex1name   (cdr (assoc -1 sex1ent))
        sex1pt1           (cdr (assoc 10 sex1ent))
        sex1pt2           (cdr (assoc 11 sex1ent))
        newse           (drop selist sex1name)
        newsen           (length newse)
        newsem           0
        newjptlist '()
  )
  (while (/= newsem newsen)
    (setq newse1   (nth newsem newse)
          newsept1 (cdr (assoc 10 (entget newse1)))
          newsept2 (cdr (assoc 11 (entget newse1)))
    )
    (if
      (setq newjpt1 (inters sex1pt1 sex1pt2 newsept1 newsept2))
       (setq newjptlist (cons newjpt1 newjptlist))
    )
    (setq newsem (1+ newsem))
  )
  (setq        newjptx        (car newjptlist)
        newjpty        (cadr newjptlist)
  )
  (if (> (distance newjptx pt) (distance newjpty pt))
    (setq newjpt newjptx)
    (setq newjpt newjpty)
  )
  (command "break" sex1 newjpt pt)
)
(defun se_123 (lst)
  (setq se1 lst)
  (setq        dptx (cdr (assoc 10 (entget se1)))
        dpty (cdr (assoc 11 (entget se1)))
  )
  (if (or (equal dptlist (list dptx dpty))
          (equal dptlist (list dpty dptx))
      )
    (command "erase" se1 "")
  )
)
;;;
;;; 主程序
;;;
(defun c:ttr (/              pta     ptb     ptax    ptay    ptbx    ptby
              ptaxby  ptbxay  ptbox   se      n              m              nn
              mm      nnn     mmm     ptlist  ptl     lse     sename
              pt1     pt2     pt3     pt4     ptlist1 n1      m1
              ptl     tmplist templist              na      nb      nab
              ptl3    ptl4    jpt1    jpt2    jpt3    jpt4    se1
              jptx    jpty    dptx    dpty    sex1    sex1net sex1name
              sex1pt1 sex1pt2 newse   newsen  newsem  newjptlist
              newsept1              newsept2              newjpt1 newjpt2 newjptx
              newjpty dpt1    dpt2    dpt3    dpt4    se2     se3
             )
  (setq cadver (substr (getvar "acadver") 1 2))
  (setq oldos (getvar "osmode"))
  (if (< oldos 16384)
    (setvar "osmode" (+ oldos 16384))
  )
  (setq oldcmd (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (prompt "\n请选择修剪区域,直接选取(左键)为窗选,右键为栅选<任意键结束>:")
  ;(if (= cadver "14")
    ;(setq pta (grread (grread)))
  (setq pta (grread))
   ; )
  (while (/= (car pta) 2)
    (if        (and (/= (car pta) 12)(listp (cadr pta)))
      (progn
        (setq pta (cadr pta))
        (setq ptb (getcorner pta "\n修剪区域对角:"))
        (if (/= ptb nil)
          (progn
            (setq ptax (car pta)
                  ptay (cadr pta)
                  ptbx (car ptb)
                  ptby (cadr ptb)
            )
            (setq ptaxby (list ptax ptby)
                  ptbxay (list ptbx ptay)
            )
            (setq sebox (list pta ptaxby ptb ptbxay))
            (setq se (ssget "c" pta ptb '((0 . "LINE"))))
          )
          (setq se nil)
        )
      )
    )
    (if        (or (= (car pta) 12)(= (car pta) 25))      
      (progn
        (SETQ PTA (CAR PTA))
        (setq sebox '())
        (setq aa (getpoint "\n选取多边形区域的一个顶点"))
        (if (/= aa nil)
          (progn
            (setq sebox (cons aa sebox))
            (setq dd aa)
            (while
              (setq cc (getpoint aa "\n选取多边形区域的下一顶点"))
               (grdraw aa cc 7 1)
               (setq aa cc)
               (setq sebox (cons aa sebox))
            )
            (grdraw aa dd 7 1)
            (setq se (ssget "cp" sebox '((0 . "LINE"))))
            (redraw)
          )
          (setq se nil)
        )
      )
    )
    (IF        (/= SE NIL)
      (PROGN
        (SETQ n             (sslength se)
              selist '()
              ptl    '()
              ptlist '()
              m             0
        )
        (while (/= m n)
          (setq        lse    (entget (ssname se m))
                sename (cdr (assoc -1 lse))
                selist (cons sename selist)
                pt1    (cdr (assoc 10 lse))
                pt2    (cdr (assoc 11 lse))
                ptl    (cons pt2 ptl)
                ptl    (cons pt1 ptl)
                ptlist (cons ptl ptlist)
                ptl    '()
                m      (1+ m)
          )
        )
        (setq n              (length ptlist)
              m              0
              jptlist '()
        )
        (while (/= m n)
          (setq        ptl1        (car (nth m ptlist))
                ptl2        (cadr (nth m ptlist))
                ptlist1        (cutnum_lst ptlist m)
                m        (1+ m)
                n1        (length ptlist1)
                m1        0
          )
          (while (/= m1 n1)
            (setq ptl3 (car (nth m1 ptlist1))
                  ptl4 (cadr (nth m1 ptlist1))
            )
            (if        (setq jpt (inters ptl1 ptl2 ptl3 ptl4 t))
              (setq jptlist (cons jpt jptlist))
            )
            (setq m1 (1+ m1))
          )
        )
        (setq jptlist (purge_lst jptlist))
        (setq tmptlist '()
              n               (length ptlist)
              m               0
        )
        (while (/= m n)
          (setq        dpt1         (car (nth m ptlist))
                tmptlist (cons dpt1 tmptlist)
                dpt2         (cadr (nth m ptlist))
                tmptlist (cons dpt2 tmptlist)
                m         (1+ m)
          )
        )
        (setq dptlist (reverse tmptlist))
        (if (listp pta)
          (progn
            (if        (= (equal jptlist '(nil)) nil)
              (setq jptlist (pt_inm jptlist pta ptbxay ptb ptaxby)
              )
            )
            (setq dptlist (pt_inm dptlist pta ptbxay ptb ptaxby)
            )
          )
          (progn
            (if        (= (equal jptlist '(nil)) nil)
              (setq jptlist (pt_inmx jptlist sebox))
            )
            (setq dptlist (pt_inmx dptlist sebox)
            )
          )
        )
        (if (/= dptlist nil)
          (setq dptlist (purge_lst dptlist))
        )
        (if (equal jptlist '(nil))
          (setq na 0)
          (setq na (length jptlist))
        )
        (setq nb    (length dptlist)
              nab   (+ na nb)
              nlist (list na nb nab)
        )
;;;
;;;执行操作
;;;
        (if (equal nlist '(2 0 2))
          (command "trim"
                   se
                   ""
                   (mpt (car jptlist) (cadr jptlist))
                   ""
          )
        )
        (if (equal nlist '(4 8 12))
          (command "trim"
                   se
                   ""
                   (car dptlist)
                   (cadr dptlist)
                   (caddr dptlist)
                   (cadddr dptlist)
                   (cadddr (cdr dptlist))
                   (cadddr (cddr dptlist))
                   (cadddr (cdddr dptlist))
                   (cadddr (cdddr (cdr dptlist)))
                   ""
          )
        )
        (if (and (= (* 2 (length selist)) nb) (= na 0))
          (command "ERASE" se "")
        )
        (if
          (and (= na 0) (= (- (length selist) (length dptlist)) 1))
           (progn
             (setq n (length dptlist)
                   m 0
             )
             (while (/= m n)
               (setq dpt (nth m dptlist))
               (setq m (1+ m))
               (command "EXTEND" se "" dpt "")
             )
             (setq yorn (getstring "\n需要修剪吗？Y or N <Y>"))
             (if (or (= yorn "y") (= yorn "") (= yorn nil))
               (progn
                 (setq jptxlist '())
                 (setq n (length selist)
                       m 0
                 )
                 (while        (/= m n)
                   (setq sexx (nth m selist))
                   (setq sexlist (cutnum_lst selist m))
                   (setq nn (length sexlist)
                         mm 0
                   )
                   (while (/= mm nn)
                     (setq sexy (nth mm sexlist))
                     (if (setq
                           jptx
                            (inters (cdr (assoc 10 (entget sexx)))
                                    (cdr (assoc 11 (entget sexx)))
                                    (cdr (assoc 10 (entget sexy)))
                                    (cdr (assoc 11 (entget sexy)))
                            )
                         )
                       (setq jptxlist (cons jptx jptxlist))
                     )
                     (setq mm (1+ mm))
                   )
                   (setq m (1+ m))
                 )
                 (setq jptxlist (purge_lst jptxlist))
                 (while        (>= (length jptxlist) 2)
                   (setq jptx1 (nth 0 jptxlist)
                         jptx2 (nth 1 jptxlist)
                   )
                   (command "trim"
                            se
                            ""
                            (mpt jptx1 jptx2)
                            ""
                   )
                   (setq jptxlist (cdr jptxlist))
                 )
               )
             )
           )
        )
        (if (equal nlist '(4 0 4))
          (progn
            (setq jpt1 (car jptlist)
                  jpt2 (cadr jptlist)
                  jpt3 (caddr jptlist)
                  jpt4 (cadddr jptlist)
            )
            (cond
              ((= (ssget (mpt jpt1 jpt2)) nil)
               (command        "trim"
                        se
                        ""
                        (mpt jpt1 jpt3)
                        (mpt jpt1 jpt4)
                        (mpt jpt2 jpt3)
                        (mpt jpt2 jpt4)
                        ""
               )
              )
              ((= (ssget (mpt jpt1 jpt3))nil)
               (command        "trim"
                        se
                        ""
                        (mpt jpt1 jpt2)
                        (mpt jpt1 jpt4)
                        (mpt jpt2 jpt3)
                        (mpt jpt3 jpt4)
                        ""
               )
              )
              ((= (ssget (mpt jpt1 jpt4))nil)
               (command        "trim"
                        se
                        ""
                        (mpt jpt1 jpt2)
                        (mpt jpt1 jpt3)
                        (mpt jpt2 jpt4)
                        (mpt jpt3 jpt4)
                        ""
               )
              )
            )
          )
        )
        (if (equal nlist '(1 2 3))
          (progn
            (se_123 (car selist))
            (se_123 (cadr selist))
            (command "trim" se "" (car dptlist) (cadr dptlist) "")
          )
        )
        (if (equal nlist '(2 2 4))
          (progn
            (se_123 (car selist))
            (se_123 (cadr selist))
            (se_123 (caddr selist))
            (command "trim"
                     se
                     ""
                     (car dptlist)
                     (cadr dptlist)
                     (mpt (car jptlist) (cadr jptlist))
                     ""
            )
          )
        )
        (if (equal nlist '(4 2 6))
          (progn
            (setq dpt1 (car dptlist)
                  dpt2 (cadr dptlist)
            )
            (se_426 dpt1)
            (setq newjptn newjpt)
            (se_426 dpt2)
            (command "trim" se "" (mpt newjptn newjpt) "")
          )
        )
        (if (and (= (length selist) 2) (equal nlist '(0 2 2)))
          (command "FILLET" (car dptlist) (cadr dptlist))
        )
        (if (equal nlist '(1 1 2))
          (command "trim" se "" (car dptlist) "")
        )
        (if (and (= (length selist) 2) (equal nlist '(1 3 4)))
          (command "ERASE" se "")
        )
        (if (and (= (length selist) 4)
                 (or (equal nlist '(1 3 4)) (equal nlist '(1 4 5)))
            )
          (progn
            (setq sen (length selist)
                  sem 0
            )
            (while (/= sem sen)
              (setq sex1 (nth sem selist))
              (setq newselist (drop selist sex1))
              (foreach n newselist
                (if (line_int sex1 n)
                  (setq        sexa sex1
                        sexb n
                  )
                )
              )
              (setq sem (1+ sem))
            )
            (setq newselist (drop selist sexa)
                  newselist (drop newselist sexb)
            )
            (if        (listp pta)
              (progn
                (if
                  (= (point_inm
                       (setq
                         fpt1
                          (cdr (assoc 10 (entget (car newselist)))
                          )
                       )
                       pta
                       ptbxay
                       ptb
                       ptaxby
                     )
                     nil
                  )
                   (setq
                     fpt1 (cdr (assoc 11 (entget (car newselist))))
                   )
                )
                (if
                  (= (point_inm
                       (setq fpt2
                              (cdr (assoc 10 (entget (cadr newselist))))
                       )
                       pta
                       ptbxay
                       ptb
                       ptaxby
                     )
                     nil
                  )
                   (setq fpt2
                          (cdr (assoc 11 (entget (cadr newselist))))
                   )
                )
              )
              (progn
                (if
                  (= (ea:point_inm
                       (setq
                         fpt1
                          (cdr (assoc 10 (entget (car newselist)))
                          )
                       )
                       sebox
                     )
                     nil
                  )
                   (setq
                     fpt1 (cdr (assoc 11 (entget (car newselist))))
                   )
                )
                (if (= (ea:point_inm
                         (setq
                           fpt2
                            (cdr (assoc 10 (entget (cadr newselist))))
                         )
                         sebox
                       )
                       nil
                    )
                  (setq        fpt2
                         (cdr (assoc 11 (entget (cadr newselist))))
                  )
                )
              )
            )
            (setq oldfillet (getvar "filletrad"))
            (setvar "filletrad" 0.0)
            (command "FILLET" fpt1 fpt2)
            (setvar "filletrad" oldfillet)
            (setq dptlist1 (drop dptlist fpt1)
                  dptlist1 (drop dptlist1 fpt2)
            )
            (command "trim" se "" (car dptlist1) (cadr dptlist1) "")
          )
        )
        (princ nlist)
     (setvar "osmode" 4791)
(setq old (getvar "osmode"))
      )
    )
    (prompt "\n请选择修剪区域,直接选取为窗选,右键为栅选<任意键结束>:")

    (setq pta (grread))   
  )
  (setvar "osmode" oldos)
    (setvar "cmdecho" oldcmd)
)
(PRINC
  "\n智能剪程序已经加载成功,用“TTR”命令运行。"
)
(PRINC)

spp_wall

支持一下！！！！！

edata

程序太长，就只添加圆角部分。

1. (defun cutnum_lst (oldlst num / k templst)
   
2.   (setq        k 0
   
3.         templst        '()
   
4.   )
   
5.   (foreach n oldlst
   
6.     (if        (/= k num)
   
7.       (setq templst (cons n templst)
   
8.             k            (1+ k)
   
9.       )
   
10.     )
    
11.     (setq k (1+ k))
    
12.   )
    
13.   (setq newlst (reverse templst))
    
14. )
    
15. ;;去除表中指定项
    
16. (defun drop (lst item)
    
17.   (append (reverse (cdr (member item (reverse lst))))
    
18.           (cdr (member item lst))
    
19.   )
    
20. )
    
21. ;;将点表中在方框内的点组成新表
    
22. (defun pt_inm (oldlst PT1 PT2 PT3 PT4 /        oldlist        n pt1 pt2 pt3 pt4
    
23.                templst newlst)
    
24.   (setq templst '())
    
25.   (foreach n oldlst
    
26.     (if        (/= (point_inm n pt1 pt2 pt3 pt4) nil)
    
27.       (setq templst (cons n templst))
    
28.     )
    
29.   )
    
30.   (setq newlst (reverse templst))
    
31. )
    
32. ;;将点表中在多边形内的点组成新表
    
33. (defun pt_inmx (oldlst pm)
    
34.   (setq templst '())
    
35.   (foreach n oldlst
    
36.     (if        (ea:point_inm n pm)
    
37.       (setq templst (cons n templst))
    
38.     )
    
39.   )
    
40.   (setq newlst (reverse templst))
    
41. )
    
42. ;;判断两点是否等
    
43. (defun eq_point        (pt1 pt2)
    
44.   (if (and (equal (car pt1) (car pt2) 1e-5)
    
45.            (equal (cadr pt1) (cadr pt2) 1e-5)
    
46.       )
    
47.     t
    
48.     nil
    
49.   )
    
50. )
    
51. ;;判断两直线是否相交
    
52. (defun line_int        (se1 se2)
    
53.   (if (/= (inters (cdr (assoc 10 (entget se1)))
    
54.                   (cdr (assoc 11 (entget se1)))
    
55.                   (cdr (assoc 10 (entget se2)))
    
56.                   (cdr (assoc 11 (entget se2)))
    
57.                   t
    
58.           )
    
59.           nil
    
60.       )
    
61.     t
    
62.     nil
    
63.   )
    
64. )
    
65. ;;点到直线的垂直距离
    
66. (defun point_line (pt pt1 pt2 / ptangle ptn pt pt1 pt2 dist jptx)
    
67.   (setq        ptangle        (angle pt1 pt2)
    
68.         ptn        (polar pt (+ (* 0.5 pi) ptangle) 0.01)
    
69.         jptx        (inters pt ptn pt1 pt2 nil)
    
70.         dist        (distance pt jptx)
    
71.   )
    
72.   dist
    
73. )
    
74. ;;判断点是否在方框内
    
75. (defun point_inm (pt pt1 pt2 pt3 pt4 / dist1 dist2 dist3 dist4 pt pt1
    
76.                   pt2 pr3 pt4)
    
77.   (setq        dist1 (point_line pt pt1 pt2)
    
78.         dist2 (point_line pt pt2 pt3)
    
79.         dist3 (point_line pt pt1 pt4)
    
80.         dist4 (point_line pt pt3 pt4)
    
81.   )
    
82.   (if (equal (+ dist1 dist2 dist3 dist4)
    
83.              (+ (distance pt1 pt2) (distance pt2 pt3))
    
84.              1e-10
    
85.       )
    
86.     t
    
87.     nil
    
88.   )
    
89. )
    
90. ;;测试点是否在多边形内.
    
91. (defun ea:point_inm
    
92.        (p pm / point_x mx px1 pm edge_int_num pt_online_num)
    
93.   (setq        point_x        (mapcar '(lambda (x) (car x)) pm)
    
94.         mx        (abs (- (apply 'max point_x) (car p)))
    
95.         px1        (polar p 0 (* mx 2))
    
96.   )
    
97.   (setq        pm              (append pm (list (nth 0 pm)))
    
98.         edge_int_num  0
    
99.         pt_online_num 0
    
100.   )
     
101.   (while (> (length pm) 1)
     
102.     (setq pc (nth 0 pm)
     
103.           pn (nth 1 pm)
     
104.     )
     
105.     (if        (inters p px1 pc pn)
     
106.       (setq edge_int_num (+ 1 edge_int_num))
     
107.     )
     
108.     (if        (equal (angle p pc) 0 1e-5)
     
109.       (setq pt_online_num (+ 1 pt_online_num))
     
110.     )
     
111.     (if        (and (equal (angle p pc) 0 1e-5)
     
112.              (equal (angle p pn) 0 1e-5)
     
113.         )
     
114.       (setq pt_online_num (- pt_online_num 1))
     
115.     )
     
116.     (setq pm (cdr pm))
     
117.     (if        (= (rem (+ pt_online_num edge_int_num) 2) 1)
     
118.       t
     
119.       nil
     
120.     )
     
121.   )
     
122. )
     
123. ;;清理表中的重复项
     
124. (defun purge_lst (lst / n m lst1 tmplist)
     
125.   (setq        tmplist        '()
     
126.         tmplist        (cons (car lst) tmplist)
     
127.         lsttmp        (cutnum_lst lst 0)
     
128.   )
     
129.   (setq        n (length lsttmp)
     
130.         m 0
     
131.   )
     
132.   (while (/= m n)
     
133.     (setq id   '()
     
134.           lst1 (nth m lsttmp)
     
135.     )
     
136.     (foreach na        tmplist
     
137.       (if (= (eq_point na lst1) nil)
     
138.         (setq id (cons 0 id))
     
139.         (setq id (cons 1 id))
     
140.       )
     
141.     )
     
142.     (if        (= (member '1 id) nil)
     
143.       (setq tmplist (cons lst1 tmplist))
     
144.     )
     
145.     (setq m (1+ m))
     
146.   )
     
147.   (setq tmplist (reverse tmplist))
     
148. )
     
149. ;;计算两点的中点
     
150. (defun mpt (mpt1 mpt2)
     
151.   (polar mpt1 (angle mpt1 mpt2) (/ (distance mpt1 mpt2) 2))
     
152. )
     
153. 
     
154. (defun se_426 (pt)
     
155.   (setq        sex1           (ssname (ssget "c" pt pt) 0)
     
156.         sex1ent           (entget sex1)
     
157.         sex1name   (cdr (assoc -1 sex1ent))
     
158.         sex1pt1           (cdr (assoc 10 sex1ent))
     
159.         sex1pt2           (cdr (assoc 11 sex1ent))
     
160.         newse           (drop selist sex1name)
     
161.         newsen           (length newse)
     
162.         newsem           0
     
163.         newjptlist '()
     
164.   )
     
165.   (while (/= newsem newsen)
     
166.     (setq newse1   (nth newsem newse)
     
167.           newsept1 (cdr (assoc 10 (entget newse1)))
     
168.           newsept2 (cdr (assoc 11 (entget newse1)))
     
169.     )
     
170.     (if
     
171.       (setq newjpt1 (inters sex1pt1 sex1pt2 newsept1 newsept2))
     
172.        (setq newjptlist (cons newjpt1 newjptlist))
     
173.     )
     
174.     (setq newsem (1+ newsem))
     
175.   )
     
176.   (setq        newjptx        (car newjptlist)
     
177.         newjpty        (cadr newjptlist)
     
178.   )
     
179.   (if (> (distance newjptx pt) (distance newjpty pt))
     
180.     (setq newjpt newjptx)
     
181.     (setq newjpt newjpty)
     
182.   )
     
183.   (command "break" sex1 newjpt pt)
     
184. )
     
185. (defun se_123 (lst)
     
186.   (setq se1 lst)
     
187.   (setq        dptx (cdr (assoc 10 (entget se1)))
     
188.         dpty (cdr (assoc 11 (entget se1)))
     
189.   )
     
190.   (if (or (equal dptlist (list dptx dpty))
     
191.           (equal dptlist (list dpty dptx))
     
192.       )
     
193.     (command "erase" se1 "")
     
194.   )
     
195. )
     
196. ;;;
     
197. ;;; 主程序
     
198. ;;;
     
199. (defun c:ttr (/              pta     ptb     ptax    ptay    ptbx    ptby
     
200.               ptaxby  ptbxay  ptbox   se      n              m              nn
     
201.               mm      nnn     mmm     ptlist  ptl     lse     sename
     
202.               pt1     pt2     pt3     pt4     ptlist1 n1      m1
     
203.               ptl     tmplist templist              na      nb      nab
     
204.               ptl3    ptl4    jpt1    jpt2    jpt3    jpt4    se1
     
205.               jptx    jpty    dptx    dpty    sex1    sex1net sex1name
     
206.               sex1pt1 sex1pt2 newse   newsen  newsem  newjptlist
     
207.               newsept1              newsept2              newjpt1 newjpt2 newjptx
     
208.               newjpty dpt1    dpt2    dpt3    dpt4    se2     se3
     
209.               sef2 ent1 ent2 p1 p2 p3 p4 ipts se2com entlst2
     
210.              )
     
211.   (setq cadver (substr (getvar "acadver") 1 2))
     
212.   (setq oldos (getvar "osmode"))
     
213.   (if (< oldos 16384)
     
214.     (setvar "osmode" (+ oldos 16384))
     
215.   )
     
216.   (setq oldcmd (getvar "cmdecho"))
     
217.   (setvar "cmdecho" 0)
     
218.   (or sk_frad (setq sk_frad 0.0));;;设置sk_frad为全局变量
     
219.   (if (setq sk_fr(getreal (strcat "\n请输入圆角半径<" (rtos sk_frad 2 2)  ">:")))(setq sk_frad sk_fr))
     
220.   (prompt "\n请选择修剪区域,直接选取(左键)为窗选,右键为栅选<任意键结束>:")
     
221.   ;(if (= cadver "14")
     
222.     ;(setq pta (grread (grread)))
     
223.   (setq pta (grread))
     
224.    ; )
     
225.   (while (/= (car pta) 2)
     
226.     (if        (and (/= (car pta) 12)(listp (cadr pta)))
     
227.       (progn
     
228.         (setq pta (cadr pta))
     
229.         (setq ptb (getcorner pta "\n修剪区域对角:"))
     
230.         (if (/= ptb nil)
     
231.           (progn
     
232.             (setq ptax (car pta)
     
233.                   ptay (cadr pta)
     
234.                   ptbx (car ptb)
     
235.                   ptby (cadr ptb)
     
236.             )
     
237.             (setq ptaxby (list ptax ptby)
     
238.                   ptbxay (list ptbx ptay)
     
239.             )
     
240.             (setq sebox (list pta ptaxby ptb ptbxay))
     
241.             (setq se (ssget "c" pta ptb '((0 . "LINE"))))
     
242.           )
     
243.           (setq se nil)
     
244.         )
     
245.       )
     
246.     )
     
247.     (if        (or (= (car pta) 12)(= (car pta) 25))      
     
248.       (progn
     
249.         (SETQ PTA (CAR PTA))
     
250.         (setq sebox '())
     
251.         (setq aa (getpoint "\n选取多边形区域的一个顶点"))
     
252.         (if (/= aa nil)
     
253.           (progn
     
254.             (setq sebox (cons aa sebox))
     
255.             (setq dd aa)
     
256.             (while
     
257.               (setq cc (getpoint aa "\n选取多边形区域的下一顶点"))
     
258.                (grdraw aa cc 7 1)
     
259.                (setq aa cc)
     
260.                (setq sebox (cons aa sebox))
     
261.             )
     
262.             (grdraw aa dd 7 1)
     
263.             (setq se (ssget "cp" sebox '((0 . "LINE"))))
     
264.             (redraw)
     
265.           )
     
266.           (setq se nil)
     
267.         )
     
268.       )
     
269.     )
     
270.     (IF        (/= SE NIL)
     
271.       (PROGN
     
272.         (SETQ n             (sslength se)
     
273.               selist '()
     
274.               ptl    '()
     
275.               ptlist '()
     
276.               m             0
     
277.         )
     
278.         (while (/= m n)
     
279.           (setq        lse    (entget (ssname se m))
     
280.                 sename (cdr (assoc -1 lse))
     
281.                 selist (cons sename selist)
     
282.                 pt1    (cdr (assoc 10 lse))
     
283.                 pt2    (cdr (assoc 11 lse))
     
284.                 ptl    (cons pt2 ptl)
     
285.                 ptl    (cons pt1 ptl)
     
286.                 ptlist (cons ptl ptlist)
     
287.                 ptl    '()
     
288.                 m      (1+ m)
     
289.           )
     
290.         )
     
291.         (setq n              (length ptlist)
     
292.               m              0
     
293.               jptlist '()
     
294.         )
     
295.         (while (/= m n)
     
296.           (setq        ptl1        (car (nth m ptlist))
     
297.                 ptl2        (cadr (nth m ptlist))
     
298.                 ptlist1        (cutnum_lst ptlist m)
     
299.                 m        (1+ m)
     
300.                 n1        (length ptlist1)
     
301.                 m1        0
     
302.           )
     
303.           (while (/= m1 n1)
     
304.             (setq ptl3 (car (nth m1 ptlist1))
     
305.                   ptl4 (cadr (nth m1 ptlist1))
     
306.             )
     
307.             (if        (setq jpt (inters ptl1 ptl2 ptl3 ptl4 t))
     
308.               (setq jptlist (cons jpt jptlist))
     
309.             )
     
310.             (setq m1 (1+ m1))
     
311.           )
     
312.         )
     
313.         (setq jptlist (purge_lst jptlist))
     
314.         (setq tmptlist '()
     
315.               n               (length ptlist)
     
316.               m               0
     
317.         )
     
318.         (while (/= m n)
     
319.           (setq        dpt1         (car (nth m ptlist))
     
320.                 tmptlist (cons dpt1 tmptlist)
     
321.                 dpt2         (cadr (nth m ptlist))
     
322.                 tmptlist (cons dpt2 tmptlist)
     
323.                 m         (1+ m)
     
324.           )
     
325.         )
     
326.         (setq dptlist (reverse tmptlist))
     
327.         (if (listp pta)
     
328.           (progn
     
329.             (if        (= (equal jptlist '(nil)) nil)
     
330.               (setq jptlist (pt_inm jptlist pta ptbxay ptb ptaxby)
     
331.               )
     
332.             )
     
333.             (setq dptlist (pt_inm dptlist pta ptbxay ptb ptaxby)
     
334.             )
     
335.           )
     
336.           (progn
     
337.             (if        (= (equal jptlist '(nil)) nil)
     
338.               (setq jptlist (pt_inmx jptlist sebox))
     
339.             )
     
340.             (setq dptlist (pt_inmx dptlist sebox)
     
341.             )
     
342.           )
     
343.         )
     
344.         (if (/= dptlist nil)
     
345.           (setq dptlist (purge_lst dptlist))
     
346.         )
     
347.         (if (equal jptlist '(nil))
     
348.           (setq na 0)
     
349.           (setq na (length jptlist))
     
350.         )
     
351.         (setq nb    (length dptlist)
     
352.               nab   (+ na nb)
     
353.               nlist (list na nb nab)
     
354.         )
     
355. ;;;
     
356. ;;;执行操作
     
357. ;;;
     
358.         (if (equal nlist '(2 0 2))
     
359.           (command "trim"
     
360.                    se
     
361.                    ""
     
362.                    (mpt (car jptlist) (cadr jptlist))
     
363.                    ""
     
364.           )
     
365.         )
     
366.         (if (equal nlist '(4 8 12))
     
367.           (command "trim"
     
368.                    se
     
369.                    ""
     
370.                    (car dptlist)
     
371.                    (cadr dptlist)
     
372.                    (caddr dptlist)
     
373.                    (cadddr dptlist)
     
374.                    (cadddr (cdr dptlist))
     
375.                    (cadddr (cddr dptlist))
     
376.                    (cadddr (cdddr dptlist))
     
377.                    (cadddr (cdddr (cdr dptlist)))
     
378.                    ""
     
379.           )
     
380.         )
     
381.         (if (and (= (* 2 (length selist)) nb) (= na 0))
     
382.           (command "ERASE" se "")
     
383.         )
     
384.         (if
     
385.           (and (= na 0) (= (- (length selist) (length dptlist)) 1))
     
386.            (progn
     
387.              (setq n (length dptlist)
     
388.                    m 0
     
389.              )
     
390.              (while (/= m n)
     
391.                (setq dpt (nth m dptlist))
     
392.                (setq m (1+ m))
     
393.                (command "EXTEND" se "" dpt "")
     
394.              )
     
395.              (setq yorn (getstring "\n需要修剪吗？Y or N <Y>"))
     
396.              (if (or (= yorn "y") (= yorn "") (= yorn nil))
     
397.                (progn
     
398.                  (setq jptxlist '())
     
399.                  (setq n (length selist)
     
400.                        m 0
     
401.                  )
     
402.                  (while        (/= m n)
     
403.                    (setq sexx (nth m selist))
     
404.                    (setq sexlist (cutnum_lst selist m))
     
405.                    (setq nn (length sexlist)
     
406.                          mm 0
     
407.                    )
     
408.                    (while (/= mm nn)
     
409.                      (setq sexy (nth mm sexlist))
     
410.                      (if (setq
     
411.                            jptx
     
412.                             (inters (cdr (assoc 10 (entget sexx)))
     
413.                                     (cdr (assoc 11 (entget sexx)))
     
414.                                     (cdr (assoc 10 (entget sexy)))
     
415.                                     (cdr (assoc 11 (entget sexy)))
     
416.                             )
     
417.                          )
     
418.                        (setq jptxlist (cons jptx jptxlist))
     
419.                      )
     
420.                      (setq mm (1+ mm))
     
421.                    )
     
422.                    (setq m (1+ m))
     
423.                  )
     
424.                  (setq jptxlist (purge_lst jptxlist))
     
425.                  (while        (>= (length jptxlist) 2)
     
426.                    (setq jptx1 (nth 0 jptxlist)
     
427.                          jptx2 (nth 1 jptxlist)
     
428.                    )
     
429.                    (command "trim"
     
430.                             se
     
431.                             ""
     
432.                             (mpt jptx1 jptx2)
     
433.                             ""
     
434.                    )
     
435.                    (setq jptxlist (cdr jptxlist))
     
436.                  )
     
437.                )
     
438.              )
     
439.            )
     
440.         )
     
441.         (if (equal nlist '(4 0 4))
     
442.           (progn
     
443.             (setq jpt1 (car jptlist)
     
444.                   jpt2 (cadr jptlist)
     
445.                   jpt3 (caddr jptlist)
     
446.                   jpt4 (cadddr jptlist)
     
447.             )
     
448.             (cond
     
449.               ((= (ssget (mpt jpt1 jpt2)) nil)
     
450.                (command        "trim"
     
451.                         se
     
452.                         ""
     
453.                         (mpt jpt1 jpt3)
     
454.                         (mpt jpt1 jpt4)
     
455.                         (mpt jpt2 jpt3)
     
456.                         (mpt jpt2 jpt4)
     
457.                         ""
     
458.                )
     
459.               )
     
460.               ((= (ssget (mpt jpt1 jpt3))nil)
     
461.                (command        "trim"
     
462.                         se
     
463.                         ""
     
464.                         (mpt jpt1 jpt2)
     
465.                         (mpt jpt1 jpt4)
     
466.                         (mpt jpt2 jpt3)
     
467.                         (mpt jpt3 jpt4)
     
468.                         ""
     
469.                )
     
470.               )
     
471.               ((= (ssget (mpt jpt1 jpt4))nil)
     
472.                (command        "trim"
     
473.                         se
     
474.                         ""
     
475.                         (mpt jpt1 jpt2)
     
476.                         (mpt jpt1 jpt3)
     
477.                         (mpt jpt2 jpt4)
     
478.                         (mpt jpt3 jpt4)
     
479.                         ""
     
480.                )
     
481.               )
     
482.             )
     
483.           )
     
484.         )
     
485.         (if (equal nlist '(1 2 3))
     
486.           (progn
     
487.             (se_123 (car selist))
     
488.             (se_123 (cadr selist))
     
489.             (command "trim" se "" (car dptlist) (cadr dptlist) "")
     
490.           )
     
491.         )
     
492.         (if (equal nlist '(2 2 4))
     
493.           (progn
     
494.             (se_123 (car selist))
     
495.             (se_123 (cadr selist))
     
496.             (se_123 (caddr selist))
     
497.             (command "trim"
     
498.                      se
     
499.                      ""
     
500.                      (car dptlist)
     
501.                      (cadr dptlist)
     
502.                      (mpt (car jptlist) (cadr jptlist))
     
503.                      ""
     
504.             )
     
505.           )
     
506.         )
     
507.         (if (equal nlist '(4 2 6))
     
508.           (progn
     
509.             (setq dpt1 (car dptlist)
     
510.                   dpt2 (cadr dptlist)
     
511.             )
     
512.             (se_426 dpt1)
     
513.             (setq newjptn newjpt)
     
514.             (se_426 dpt2)
     
515.             (command "trim" se "" (mpt newjptn newjpt) "")
     
516.           )
     
517.         )
     
518.        
     
519.         (if (and (= (length selist) 2) (equal nlist '(0 2 2)))
     
520.           (command "FILLET" (car dptlist) (cadr dptlist))
     
521.         )
     
522.         (if (equal nlist '(1 1 2))
     
523.           (command "trim" se "" (car dptlist) "")
     
524.         )
     
525.         (if (and (= (length selist) 2) (equal nlist '(1 3 4)))
     
526.           (command "ERASE" se "")
     
527.         )
     
528.         (if (and (= (length selist) 4)
     
529.                  (or (equal nlist '(1 3 4)) (equal nlist '(1 4 5)))
     
530.             )
     
531.           (progn
     
532.             (setq sen (length selist)
     
533.                   sem 0
     
534.             )
     
535.             (while (/= sem sen)
     
536.               (setq sex1 (nth sem selist))
     
537.               (setq newselist (drop selist sex1))
     
538.               (foreach n newselist
     
539.                 (if (line_int sex1 n)
     
540.                   (setq        sexa sex1
     
541.                         sexb n
     
542.                   )
     
543.                 )
     
544.               )
     
545.               (setq sem (1+ sem))
     
546.             )
     
547.             (setq newselist (drop selist sexa)
     
548.                   newselist (drop newselist sexb)
     
549.             )
     
550.             (if        (listp pta)
     
551.               (progn
     
552.                 (if
     
553.                   (= (point_inm
     
554.                        (setq
     
555.                          fpt1
     
556.                           (cdr (assoc 10 (entget (car newselist)))
     
557.                           )
     
558.                        )
     
559.                        pta
     
560.                        ptbxay
     
561.                        ptb
     
562.                        ptaxby
     
563.                      )
     
564.                      nil
     
565.                   )
     
566.                    (setq
     
567.                      fpt1 (cdr (assoc 11 (entget (car newselist))))
     
568.                    )
     
569.                 )
     
570.                 (if
     
571.                   (= (point_inm
     
572.                        (setq fpt2
     
573.                               (cdr (assoc 10 (entget (cadr newselist))))
     
574.                        )
     
575.                        pta
     
576.                        ptbxay
     
577.                        ptb
     
578.                        ptaxby
     
579.                      )
     
580.                      nil
     
581.                   )
     
582.                    (setq fpt2
     
583.                           (cdr (assoc 11 (entget (cadr newselist))))
     
584.                    )
     
585.                 )
     
586.               )
     
587.               (progn
     
588.                 (if
     
589.                   (= (ea:point_inm
     
590.                        (setq
     
591.                          fpt1
     
592.                           (cdr (assoc 10 (entget (car newselist)))
     
593.                           )
     
594.                        )
     
595.                        sebox
     
596.                      )
     
597.                      nil
     
598.                   )
     
599.                    (setq
     
600.                      fpt1 (cdr (assoc 11 (entget (car newselist))))
     
601.                    )
     
602.                 )
     
603.                 (if (= (ea:point_inm
     
604.                          (setq
     
605.                            fpt2
     
606.                             (cdr (assoc 10 (entget (cadr newselist))))
     
607.                          )
     
608.                          sebox
     
609.                        )
     
610.                        nil
     
611.                     )
     
612.                   (setq        fpt2
     
613.                          (cdr (assoc 11 (entget (cadr newselist))))
     
614.                   )
     
615.                 )
     
616.               )
     
617.             )
     
618.             (setq oldfillet (getvar "filletrad"))
     
619.             (setvar "filletrad" 10.0)
     
620.             (command "FILLET" fpt1 fpt2)
     
621.             (setvar "filletrad" oldfillet)
     
622.             (setq dptlist1 (drop dptlist fpt1)
     
623.                   dptlist1 (drop dptlist1 fpt2)
     
624.             )
     
625.             (command "trim" se "" (car dptlist1) (cadr dptlist1) "")
     
626.           )
     
627.         )
     
628.         (princ nlist)
     
629.      (setvar "osmode" 4791)
     
630. (setq old (getvar "osmode"))
     
631.       )
     
632.     )
     
633.     (if(setq sef2 (ssget "cp" sebox '((0 . "LINE"))))
     
634.       (progn
     
635.         (setq se2lst (ss2lst sef2))
     
636.         (setq se2com (combination se2lst 2)
     
637.               entlst2 '())
     
638.         (while (setq ent1(car se2com))
     
639.           (setq p1 (sk_dxf (car ent1) 10 )
     
640.                 p2 (sk_dxf (car ent1) 11 )
     
641.                 p3 (sk_dxf (cadr ent1) 10 )
     
642.                 p4 (sk_dxf (cadr ent1) 11 )
     
643.                 ipts(inters p1 p2 p3 p4))
     
644.           (if ipts(setq entlst2(cons ent1 entlst2)))
     
645.           (setq se2com(cdr se2com))
     
646.           )
     
647.         (setq entlst2(reverse entlst2))
     
648.         (if (/= entlst2 '())
     
649.           (progn
     
650.             (setq oldfillet (getvar "filletrad"))
     
651.             (setvar "filletrad" sk_frad)
     
652.             (while (setq ent2(car entlst2))
     
653.             (command "FILLET" (car ent2)(cadr ent2))
     
654.               (setq entlst2(cdr entlst2))
     
655.               )
     
656.             (setvar "filletrad" oldfillet)
     
657.             )
     
658.           )
     
659.        
     
660.         )
     
661.       )
     
662.     (prompt "\n请选择修剪区域,直接选取为窗选,右键为栅选<任意键结束>:")
     
663. 
     
664.     (setq pta (grread))   
     
665.   )
     
666.   (setvar "osmode" oldos)
     
667.     (setvar "cmdecho" oldcmd)
     
668. )
     
669. (PRINC
     
670.   "\n智能剪程序已经加载成功,用“TTR”命令运行。"
     
671. )
     
672. ;;选择集转表
     
673. (defun ss2lst(ss / en lst)
     
674.   (if (= (type ss) 'PICKSET)
     
675.     (progn
     
676.       (setq lst '())
     
677.       (while (setq en (ssname ss 0))
     
678.         (setq lst(cons en lst))
     
679.         (setq ss(ssdel en ss))
     
680.         )
     
681.       (setq lst(reverse lst))
     
682.       )
     
683.     )
     
684.   )
     
685. ;;;组合函数
     
686. (defun combination (lst m)
     
687.   (cond        ((zerop m) '(()))
     
688.         ((null lst) '())
     
689.         (T
     
690.          (append (mapcar '(lambda (y) (cons (car lst) y))
     
691.                          (combination (cdr lst) (- m 1))
     
692.                  )
     
693.                  (combination (cdr lst) m)
     
694.          )
     
695.         )
     
696.   )
     
697. )
     
698. 
     
699. ;;;组码值提取(sk_dxf 图元名 组码)
     
700. (defun sk_dxf(en code)
     
701.     (if(and(=(type en) 'ENAME)(= (type code) 'INT))
     
702.       (cdr(assoc code (entget en))))
     
703.   )
     
704. (PRINC)

(defun cutnum_lst (oldlst num / k templst)<br />   (setq        k 0<br />         templst        '()<br />   )<br />   (foreach n oldlst<br />     (if        (/= k num)<br />       (setq templst (cons n templst)<br />             k            (1+ k)<br />       )<br />     )<br />     (setq k (1+ k))<br />   )<br />   (setq newlst (reverse templst))<br /> )<br /> ;;去除表中指定项<br /> (defun drop (lst item)<br />   (append (reverse (cdr (member item (reverse lst))))<br />           (cdr (member item lst))<br />   )<br /> )<br /> ;;将点表中在方框内的点组成新表<br /> (defun pt_inm (oldlst PT1 PT2 PT3 PT4 /        oldlist        n pt1 pt2 pt3 pt4<br />                templst newlst)<br />   (setq templst '())<br />   (foreach n oldlst<br />     (if        (/= (point_inm n pt1 pt2 pt3 pt4) nil)<br />       (setq templst (cons n templst))<br />     )<br />   )<br />   (setq newlst (reverse templst))<br /> )<br /> ;;将点表中在多边形内的点组成新表<br /> (defun pt_inmx (oldlst pm)<br />   (setq templst '())<br />   (foreach n oldlst<br />     (if        (ea:point_inm n pm)<br />       (setq templst (cons n templst))<br />     )<br />   )<br />   (setq newlst (reverse templst))<br /> )<br /> ;;判断两点是否等<br /> (defun eq_point        (pt1 pt2)<br />   (if (and (equal (car pt1) (car pt2) 1e-5)<br />            (equal (cadr pt1) (cadr pt2) 1e-5)<br />       )<br />     t<br />     nil<br />   )<br /> )<br /> ;;判断两直线是否相交<br /> (defun line_int        (se1 se2)<br />   (if (/= (inters (cdr (assoc 10 (entget se1)))<br />                   (cdr (assoc 11 (entget se1)))<br />                   (cdr (assoc 10 (entget se2)))<br />                   (cdr (assoc 11 (entget se2)))<br />                   t<br />           )<br />           nil<br />       )<br />     t<br />     nil<br />   )<br /> )<br /> ;;点到直线的垂直距离<br /> (defun point_line (pt pt1 pt2 / ptangle ptn pt pt1 pt2 dist jptx)<br />   (setq        ptangle        (angle pt1 pt2)<br />         ptn        (polar pt (+ (* 0.5 pi) ptangle) 0.01)<br />         jptx        (inters pt ptn pt1 pt2 nil)<br />         dist        (distance pt jptx)<br />   )<br />   dist<br /> )<br /> ;;判断点是否在方框内<br /> (defun point_inm (pt pt1 pt2 pt3 pt4 / dist1 dist2 dist3 dist4 pt pt1<br />                   pt2 pr3 pt4)<br />   (setq        dist1 (point_line pt pt1 pt2)<br />         dist2 (point_line pt pt2 pt3)<br />         dist3 (point_line pt pt1 pt4)<br />         dist4 (point_line pt pt3 pt4)<br />   )<br />   (if (equal (+ dist1 dist2 dist3 dist4)<br />              (+ (distance pt1 pt2) (distance pt2 pt3))<br />              1e-10<br />       )<br />     t<br />     nil<br />   )<br /> )<br /> ;;测试点是否在多边形内.<br /> (defun ea:point_inm<br />        (p pm / point_x mx px1 pm edge_int_num pt_online_num)<br />   (setq        point_x        (mapcar '(lambda (x) (car x)) pm)<br />         mx        (abs (- (apply 'max point_x) (car p)))<br />         px1        (polar p 0 (* mx 2))<br />   )<br />   (setq        pm              (append pm (list (nth 0 pm)))<br />         edge_int_num  0<br />         pt_online_num 0<br />   )<br />   (while (> (length pm) 1)<br />     (setq pc (nth 0 pm)<br />           pn (nth 1 pm)<br />     )<br />     (if        (inters p px1 pc pn)<br />       (setq edge_int_num (+ 1 edge_int_num))<br />     )<br />     (if        (equal (angle p pc) 0 1e-5)<br />       (setq pt_online_num (+ 1 pt_online_num))<br />     )<br />     (if        (and (equal (angle p pc) 0 1e-5)<br />              (equal (angle p pn) 0 1e-5)<br />         )<br />       (setq pt_online_num (- pt_online_num 1))<br />     )<br />     (setq pm (cdr pm))<br />     (if        (= (rem (+ pt_online_num edge_int_num) 2) 1)<br />       t<br />       nil<br />     )<br />   )<br /> )<br /> ;;清理表中的重复项<br /> (defun purge_lst (lst / n m lst1 tmplist)<br />   (setq        tmplist        '()<br />         tmplist        (cons (car lst) tmplist)<br />         lsttmp        (cutnum_lst lst 0)<br />   )<br />   (setq        n (length lsttmp)<br />         m 0<br />   )<br />   (while (/= m n)<br />     (setq id   '()<br />           lst1 (nth m lsttmp)<br />     )<br />     (foreach na        tmplist<br />       (if (= (eq_point na lst1) nil)<br />         (setq id (cons 0 id))<br />         (setq id (cons 1 id))<br />       )<br />     )<br />     (if        (= (member '1 id) nil)<br />       (setq tmplist (cons lst1 tmplist))<br />     )<br />     (setq m (1+ m))<br />   )<br />   (setq tmplist (reverse tmplist))<br /> )<br /> ;;计算两点的中点<br /> (defun mpt (mpt1 mpt2)<br />   (polar mpt1 (angle mpt1 mpt2) (/ (distance mpt1 mpt2) 2))<br /> )<br /> <br /> (defun se_426 (pt)<br />   (setq        sex1           (ssname (ssget "c" pt pt) 0)<br />         sex1ent           (entget sex1)<br />         sex1name   (cdr (assoc -1 sex1ent))<br />         sex1pt1           (cdr (assoc 10 sex1ent))<br />         sex1pt2           (cdr (assoc 11 sex1ent))<br />         newse           (drop selist sex1name)<br />         newsen           (length newse)<br />         newsem           0<br />         newjptlist '()<br />   )<br />   (while (/= newsem newsen)<br />     (setq newse1   (nth newsem newse)<br />           newsept1 (cdr (assoc 10 (entget newse1)))<br />           newsept2 (cdr (assoc 11 (entget newse1)))<br />     )<br />     (if<br />       (setq newjpt1 (inters sex1pt1 sex1pt2 newsept1 newsept2))<br />        (setq newjptlist (cons newjpt1 newjptlist))<br />     )<br />     (setq newsem (1+ newsem))<br />   )<br />   (setq        newjptx        (car newjptlist)<br />         newjpty        (cadr newjptlist)<br />   )<br />   (if (> (distance newjptx pt) (distance newjpty pt))<br />     (setq newjpt newjptx)<br />     (setq newjpt newjpty)<br />   )<br />   (command "break" sex1 newjpt pt)<br /> )<br /> (defun se_123 (lst)<br />   (setq se1 lst)<br />   (setq        dptx (cdr (assoc 10 (entget se1)))<br />         dpty (cdr (assoc 11 (entget se1)))<br />   )<br />   (if (or (equal dptlist (list dptx dpty))<br />           (equal dptlist (list dpty dptx))<br />       )<br />     (command "erase" se1 "")<br />   )<br /> )<br /> ;;;<br /> ;;; 主程序<br /> ;;;<br /> (defun c:ttr (/              pta     ptb     ptax    ptay    ptbx    ptby<br />               ptaxby  ptbxay  ptbox   se      n              m              nn<br />               mm      nnn     mmm     ptlist  ptl     lse     sename<br />               pt1     pt2     pt3     pt4     ptlist1 n1      m1<br />               ptl     tmplist templist              na      nb      nab<br />               ptl3    ptl4    jpt1    jpt2    jpt3    jpt4    se1<br />               jptx    jpty    dptx    dpty    sex1    sex1net sex1name<br />               sex1pt1 sex1pt2 newse   newsen  newsem  newjptlist<br />               newsept1              newsept2              newjpt1 newjpt2 newjptx<br />               newjpty dpt1    dpt2    dpt3    dpt4    se2     se3<br />               sef2 ent1 ent2 p1 p2 p3 p4 ipts se2com entlst2<br />              )<br />   (setq cadver (substr (getvar "acadver") 1 2))<br />   (setq oldos (getvar "osmode"))<br />   (if (< oldos 16384)<br />     (setvar "osmode" (+ oldos 16384))<br />   )<br />   (setq oldcmd (getvar "cmdecho"))<br />   (setvar "cmdecho" 0)<br />   (or sk_frad (setq sk_frad 0.0));;;设置sk_frad为全局变量<br />   (if (setq sk_fr(getreal (strcat "\n请输入圆角半径<" (rtos sk_frad 2 2)  ">:")))(setq sk_frad sk_fr))<br />   (prompt "\n请选择修剪区域,直接选取(左键)为窗选,右键为栅选<任意键结束>:")<br />   ;(if (= cadver "14")<br />     ;(setq pta (grread (grread)))<br />   (setq pta (grread))<br />    ; )<br />   (while (/= (car pta) 2)<br />     (if        (and (/= (car pta) 12)(listp (cadr pta)))<br />       (progn<br />         (setq pta (cadr pta))<br />         (setq ptb (getcorner pta "\n修剪区域对角:"))<br />         (if (/= ptb nil)<br />           (progn<br />             (setq ptax (car pta)<br />                   ptay (cadr pta)<br />                   ptbx (car ptb)<br />                   ptby (cadr ptb)<br />             )<br />             (setq ptaxby (list ptax ptby)<br />                   ptbxay (list ptbx ptay)<br />             )<br />             (setq sebox (list pta ptaxby ptb ptbxay))<br />             (setq se (ssget "c" pta ptb '((0 . "LINE"))))<br />           )<br />           (setq se nil)<br />         )<br />       )<br />     )<br />     (if        (or (= (car pta) 12)(= (car pta) 25))      <br />       (progn<br />         (SETQ PTA (CAR PTA))<br />         (setq sebox '())<br />         (setq aa (getpoint "\n选取多边形区域的一个顶点"))<br />         (if (/= aa nil)<br />           (progn<br />             (setq sebox (cons aa sebox))<br />             (setq dd aa)<br />             (while<br />               (setq cc (getpoint aa "\n选取多边形区域的下一顶点"))<br />                (grdraw aa cc 7 1)<br />                (setq aa cc)<br />                (setq sebox (cons aa sebox))<br />             )<br />             (grdraw aa dd 7 1)<br />             (setq se (ssget "cp" sebox '((0 . "LINE"))))<br />             (redraw)<br />           )<br />           (setq se nil)<br />         )<br />       )<br />     )<br />     (IF        (/= SE NIL)<br />       (PROGN<br />         (SETQ n             (sslength se)<br />               selist '()<br />               ptl    '()<br />               ptlist '()<br />               m             0<br />         )<br />         (while (/= m n)<br />           (setq        lse    (entget (ssname se m))<br />                 sename (cdr (assoc -1 lse))<br />                 selist (cons sename selist)<br />                 pt1    (cdr (assoc 10 lse))<br />                 pt2    (cdr (assoc 11 lse))<br />                 ptl    (cons pt2 ptl)<br />                 ptl    (cons pt1 ptl)<br />                 ptlist (cons ptl ptlist)<br />                 ptl    '()<br />                 m      (1+ m)<br />           )<br />         )<br />         (setq n              (length ptlist)<br />               m              0<br />               jptlist '()<br />         )<br />         (while (/= m n)<br />           (setq        ptl1        (car (nth m ptlist))<br />                 ptl2        (cadr (nth m ptlist))<br />                 ptlist1        (cutnum_lst ptlist m)<br />                 m        (1+ m)<br />                 n1        (length ptlist1)<br />                 m1        0<br />           )<br />           (while (/= m1 n1)<br />             (setq ptl3 (car (nth m1 ptlist1))<br />                   ptl4 (cadr (nth m1 ptlist1))<br />             )<br />             (if        (setq jpt (inters ptl1 ptl2 ptl3 ptl4 t))<br />               (setq jptlist (cons jpt jptlist))<br />             )<br />             (setq m1 (1+ m1))<br />           )<br />         )<br />         (setq jptlist (purge_lst jptlist))<br />         (setq tmptlist '()<br />               n               (length ptlist)<br />               m               0<br />         )<br />         (while (/= m n)<br />           (setq        dpt1         (car (nth m ptlist))<br />                 tmptlist (cons dpt1 tmptlist)<br />                 dpt2         (cadr (nth m ptlist))<br />                 tmptlist (cons dpt2 tmptlist)<br />                 m         (1+ m)<br />           )<br />         )<br />         (setq dptlist (reverse tmptlist))<br />         (if (listp pta)<br />           (progn<br />             (if        (= (equal jptlist '(nil)) nil)<br />               (setq jptlist (pt_inm jptlist pta ptbxay ptb ptaxby)<br />               )<br />             )<br />             (setq dptlist (pt_inm dptlist pta ptbxay ptb ptaxby)<br />             )<br />           )<br />           (progn<br />             (if        (= (equal jptlist '(nil)) nil)<br />               (setq jptlist (pt_inmx jptlist sebox))<br />             )<br />             (setq dptlist (pt_inmx dptlist sebox)<br />             )<br />           )<br />         )<br />         (if (/= dptlist nil)<br />           (setq dptlist (purge_lst dptlist))<br />         )<br />         (if (equal jptlist '(nil))<br />           (setq na 0)<br />           (setq na (length jptlist))<br />         )<br />         (setq nb    (length dptlist)<br />               nab   (+ na nb)<br />               nlist (list na nb nab)<br />         )<br /> ;;;<br /> ;;;执行操作<br /> ;;;<br />         (if (equal nlist '(2 0 2))<br />           (command "trim"<br />                    se<br />                    ""<br />                    (mpt (car jptlist) (cadr jptlist))<br />                    ""<br />           )<br />         )<br />         (if (equal nlist '(4 8 12))<br />           (command "trim"<br />                    se<br />                    ""<br />                    (car dptlist)<br />                    (cadr dptlist)<br />                    (caddr dptlist)<br />                    (cadddr dptlist)<br />                    (cadddr (cdr dptlist))<br />                    (cadddr (cddr dptlist))<br />                    (cadddr (cdddr dptlist))<br />                    (cadddr (cdddr (cdr dptlist)))<br />                    ""<br />           )<br />         )<br />         (if (and (= (* 2 (length selist)) nb) (= na 0))<br />           (command "ERASE" se "")<br />         )<br />         (if<br />           (and (= na 0) (= (- (length selist) (length dptlist)) 1))<br />            (progn<br />              (setq n (length dptlist)<br />                    m 0<br />              )<br />              (while (/= m n)<br />                (setq dpt (nth m dptlist))<br />                (setq m (1+ m))<br />                (command "EXTEND" se "" dpt "")<br />              )<br />              (setq yorn (getstring "\n需要修剪吗？Y or N <Y>"))<br />              (if (or (= yorn "y") (= yorn "") (= yorn nil))<br />                (progn<br />                  (setq jptxlist '())<br />                  (setq n (length selist)<br />                        m 0<br />                  )<br />                  (while        (/= m n)<br />                    (setq sexx (nth m selist))<br />                    (setq sexlist (cutnum_lst selist m))<br />                    (setq nn (length sexlist)<br />                          mm 0<br />                    )<br />                    (while (/= mm nn)<br />                      (setq sexy (nth mm sexlist))<br />                      (if (setq<br />                            jptx<br />                             (inters (cdr (assoc 10 (entget sexx)))<br />                                     (cdr (assoc 11 (entget sexx)))<br />                                     (cdr (assoc 10 (entget sexy)))<br />                                     (cdr (assoc 11 (entget sexy)))<br />                             )<br />                          )<br />                        (setq jptxlist (cons jptx jptxlist))<br />                      )<br />                      (setq mm (1+ mm))<br />                    )<br />                    (setq m (1+ m))<br />                  )<br />                  (setq jptxlist (purge_lst jptxlist))<br />                  (while        (>= (length jptxlist) 2)<br />                    (setq jptx1 (nth 0 jptxlist)<br />                          jptx2 (nth 1 jptxlist)<br />                    )<br />                    (command "trim"<br />                             se<br />                             ""<br />                             (mpt jptx1 jptx2)<br />                             ""<br />                    )<br />                    (setq jptxlist (cdr jptxlist))<br />                  )<br />                )<br />              )<br />            )<br />         )<br />         (if (equal nlist '(4 0 4))<br />           (progn<br />             (setq jpt1 (car jptlist)<br />                   jpt2 (cadr jptlist)<br />                   jpt3 (caddr jptlist)<br />                   jpt4 (cadddr jptlist)<br />             )<br />             (cond<br />               ((= (ssget (mpt jpt1 jpt2)) nil)<br />                (command        "trim"<br />                         se<br />                         ""<br />                         (mpt jpt1 jpt3)<br />                         (mpt jpt1 jpt4)<br />                         (mpt jpt2 jpt3)<br />                         (mpt jpt2 jpt4)<br />                         ""<br />                )<br />               )<br />               ((= (ssget (mpt jpt1 jpt3))nil)<br />                (command        "trim"<br />                         se<br />                         ""<br />                         (mpt jpt1 jpt2)<br />                         (mpt jpt1 jpt4)<br />                         (mpt jpt2 jpt3)<br />                         (mpt jpt3 jpt4)<br />                         ""<br />                )<br />               )<br />               ((= (ssget (mpt jpt1 jpt4))nil)<br />                (command        "trim"<br />                         se<br />                         ""<br />                         (mpt jpt1 jpt2)<br />                         (mpt jpt1 jpt3)<br />                         (mpt jpt2 jpt4)<br />                         (mpt jpt3 jpt4)<br />                         ""<br />                )<br />               )<br />             )<br />           )<br />         )<br />         (if (equal nlist '(1 2 3))<br />           (progn<br />             (se_123 (car selist))<br />             (se_123 (cadr selist))<br />             (command "trim" se "" (car dptlist) (cadr dptlist) "")<br />           )<br />         )<br />         (if (equal nlist '(2 2 4))<br />           (progn<br />             (se_123 (car selist))<br />             (se_123 (cadr selist))<br />             (se_123 (caddr selist))<br />             (command "trim"<br />                      se<br />                      ""<br />                      (car dptlist)<br />                      (cadr dptlist)<br />                      (mpt (car jptlist) (cadr jptlist))<br />                      ""<br />             )<br />           )<br />         )<br />         (if (equal nlist '(4 2 6))<br />           (progn<br />             (setq dpt1 (car dptlist)<br />                   dpt2 (cadr dptlist)<br />             )<br />             (se_426 dpt1)<br />             (setq newjptn newjpt)<br />             (se_426 dpt2)<br />             (command "trim" se "" (mpt newjptn newjpt) "")<br />           )<br />         )<br />         <br />         (if (and (= (length selist) 2) (equal nlist '(0 2 2)))<br />           (command "FILLET" (car dptlist) (cadr dptlist))<br />         )<br />         (if (equal nlist '(1 1 2))<br />           (command "trim" se "" (car dptlist) "")<br />         )<br />         (if (and (= (length selist) 2) (equal nlist '(1 3 4)))<br />           (command "ERASE" se "")<br />         )<br />         (if (and (= (length selist) 4)<br />                  (or (equal nlist '(1 3 4)) (equal nlist '(1 4 5)))<br />             )<br />           (progn<br />             (setq sen (length selist)<br />                   sem 0<br />             )<br />             (while (/= sem sen)<br />               (setq sex1 (nth sem selist))<br />               (setq newselist (drop selist sex1))<br />               (foreach n newselist<br />                 (if (line_int sex1 n)<br />                   (setq        sexa sex1<br />                         sexb n<br />                   )<br />                 )<br />               )<br />               (setq sem (1+ sem))<br />             )<br />             (setq newselist (drop selist sexa)<br />                   newselist (drop newselist sexb)<br />             )<br />             (if        (listp pta)<br />               (progn<br />                 (if<br />                   (= (point_inm<br />                        (setq<br />                          fpt1<br />                           (cdr (assoc 10 (entget (car newselist)))<br />                           )<br />                        )<br />                        pta<br />                        ptbxay<br />                        ptb<br />                        ptaxby<br />                      )<br />                      nil<br />                   )<br />                    (setq<br />                      fpt1 (cdr (assoc 11 (entget (car newselist))))<br />                    )<br />                 )<br />                 (if<br />                   (= (point_inm<br />                        (setq fpt2<br />                               (cdr (assoc 10 (entget (cadr newselist))))<br />                        )<br />                        pta<br />                        ptbxay<br />                        ptb<br />                        ptaxby<br />                      )<br />                      nil<br />                   )<br />                    (setq fpt2<br />                           (cdr (assoc 11 (entget (cadr newselist))))<br />                    )<br />                 )<br />               )<br />               (progn<br />                 (if<br />                   (= (ea:point_inm<br />                        (setq<br />                          fpt1<br />                           (cdr (assoc 10 (entget (car newselist)))<br />                           )<br />                        )<br />                        sebox<br />                      )<br />                      nil<br />                   )<br />                    (setq<br />                      fpt1 (cdr (assoc 11 (entget (car newselist))))<br />                    )<br />                 )<br />                 (if (= (ea:point_inm<br />                          (setq<br />                            fpt2<br />                             (cdr (assoc 10 (entget (cadr newselist))))<br />                          )<br />                          sebox<br />                        )<br />                        nil<br />                     )<br />                   (setq        fpt2<br />                          (cdr (assoc 11 (entget (cadr newselist))))<br />                   )<br />                 )<br />               )<br />             )<br />             (setq oldfillet (getvar "filletrad"))<br />             (setvar "filletrad" 10.0)<br />             (command "FILLET" fpt1 fpt2)<br />             (setvar "filletrad" oldfillet)<br />             (setq dptlist1 (drop dptlist fpt1)<br />                   dptlist1 (drop dptlist1 fpt2)<br />             )<br />             (command "trim" se "" (car dptlist1) (cadr dptlist1) "")<br />           )<br />         )<br />         (princ nlist)<br />      (setvar "osmode" 4791)<br /> (setq old (getvar "osmode"))<br />       )<br />     )<br />     (if(setq sef2 (ssget "cp" sebox '((0 . "LINE"))))<br />       (progn<br />         (setq se2lst (ss2lst sef2))<br />         (setq se2com (combination se2lst 2)<br />               entlst2 '())<br />         (while (setq ent1(car se2com))<br />           (setq p1 (sk_dxf (car ent1) 10 )<br />                 p2 (sk_dxf (car ent1) 11 )<br />                 p3 (sk_dxf (cadr ent1) 10 )<br />                 p4 (sk_dxf (cadr ent1) 11 )<br />                 ipts(inters p1 p2 p3 p4))<br />           (if ipts(setq entlst2(cons ent1 entlst2)))<br />           (setq se2com(cdr se2com))<br />           )<br />         (setq entlst2(reverse entlst2))<br />         (if (/= entlst2 '())<br />           (progn<br />             (setq oldfillet (getvar "filletrad"))<br />             (setvar "filletrad" sk_frad)<br />             (while (setq ent2(car entlst2))<br />             (command "FILLET" (car ent2)(cadr ent2))<br />               (setq entlst2(cdr entlst2))<br />               )<br />             (setvar "filletrad" oldfillet)<br />             )<br />           )<br />         <br />         )<br />       )<br />     (prompt "\n请选择修剪区域,直接选取为窗选,右键为栅选<任意键结束>:")<br /> <br />     (setq pta (grread))    <br />   )<br />   (setvar "osmode" oldos)<br />     (setvar "cmdecho" oldcmd)<br /> )<br /> (PRINC<br />   "\n智能剪程序已经加载成功,用“TTR”命令运行。"<br /> )<br /> ;;选择集转表<br /> (defun ss2lst(ss / en lst)<br />   (if (= (type ss) 'PICKSET)<br />     (progn<br />       (setq lst '())<br />       (while (setq en (ssname ss 0))<br />         (setq lst(cons en lst))<br />         (setq ss(ssdel en ss))<br />         )<br />       (setq lst(reverse lst))<br />       )<br />     )<br />   )<br /> ;;;组合函数<br /> (defun combination (lst m)<br />   (cond        ((zerop m) '(()))<br />         ((null lst) '())<br />         (T<br />          (append (mapcar '(lambda (y) (cons (car lst) y))<br />                          (combination (cdr lst) (- m 1))<br />                  )<br />                  (combination (cdr lst) m)<br />          )<br />         )<br />   )<br /> )<br /> <br /> ;;;组码值提取(sk_dxf 图元名 组码)<br /> (defun sk_dxf(en code)<br />     (if(and(=(type en) 'ENAME)(= (type code) 'INT))<br />       (cdr(assoc code (entget en))))<br />   )<br /> (PRINC)

lxdz443

edatad大大还是厉害，我把问题还是想的太简单了，以为只需要修改其中的参数就可以了。谢谢edatad大大。

77077

edatad大大，还有PL线不支持啊！

chenbh2

最好支持PL线倒角!

水仙的错

看看怎么样