二次开发 超级延伸剪切

2564277832

再找找看吧

半听可乐

2564277832 发表于 2012-6-30 23:37
再找找看吧

想法不错，同求！

5537420

00000000000000000000000000000000000

tangjunasd58

;;可点可框的修剪
(defun c:tt (/ PO SS I J S1 P1 P2 p3 p4 len  e1 e1co pt0 fs g z pt  code_12)
  (vl-load-com)
  (setq cm(GETVAR "CMDECHO") os(getvar "osmode"))
  (SETVAR "CMDECHO" 0)
  (setvar "osmode" 0)
  (setq        plist NIL lst nil new nil ss nil en  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))
         (setq        box (* (/ (getvar "pickbox") (cadr (getvar "screensize")))
               (getvar "viewsize")));取当前拾取盒宽
         (setq box(* 0.5 box));取当前拾取盒宽的0.5倍作为偏移值
         (setq e1co (entget e1));;保存实体数据
         (command ".offset" box e1 po "")
         (setq en(entlast) dx0(dxf 0 e1))
         (if po
             (setq plist(dingd en));; 求顶点表
         )
         (command "trim" S1 "")
         (repeat 5
           (COMMAND "f")
           (apply 'command plist)
           (COMMAND "")
          )
           (COMMAND "")
         (command "erase" e1 "");;删除修剪后的修剪线
         (entmake e1co);;防止剪掉自己生成一个和原来一样的线
        )
        ((> len 1);;;;;;;;;;如果是多选
         (prompt"\n请选择修剪方式<F栏选/左击移动/右击框选>:")
         (setq code_12 (grread (setq code (grread))));将类型代码 12 的数据从缓冲区中清除
         (initget 128)
         (setq g(grread nil 4 0) fs(car g))
         (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 "")
                )
                ((MEMBER (cadr g) '(70 102));;;如果选f
                  (setvar 'cmdecho 1)
                  (command "trim" s1 "" "f")
                  (while(/= 0 (getvar "cmdactive"))(command PAUSE))
                  (setvar 'cmdecho 0)
                )
                ((member (cadr g) '(0 13 32));;;如果是右击或空格或回车
                  (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);;如果没有选择
         (setvar 'cmdecho 1)
         (command ".trim" "")
         (while(/= 0 (getvar "cmdactive"))(command PAUSE))
         (setvar 'cmdecho 0)
        )
);;;;;;;;;;;;;;;;;;;;
         (command "undo" "e")
         (setvar 'cmdecho cm)
         (setvar 'osmode os)
         (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 dingd (x / et st)
  (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))))
        ((or(= dx0 "LWPOLYLINE")(= dx0 "POLYLINE"))
         (setq dx90(dxf 90 en))
         (setq plist(vxs obj));;多段线另外求
         )
         ((OR(= dx0 "SPLINE")(= dx0 "CIRCLE")(= dx0 "ELLIPSE")(= dx0 "ARC"))
            (if (> (fix zc) 0)(setq zc(fix zc))
              (setq zc(fix(* 100 zc)))
              )
            (setq 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 vxs (e /  i j p12 bihe)
  (setq        i  -1 lst nil pn 0 j -1)
  (vl-load-com)
  ;(setq dx90(dxf 90 e));;取顶点数
  (setq bihe(vlax-curve-isClosed e));是否闭合
  (while (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
    (if bihe;;如果曲线闭合
       (if(and (/= i dx90 )(/= (vla-getbulge e i) 0))
             (setq  p12 (append  p12 (list v)) pn(1+ pn));提取出现弧度的点放在一起
         )
       (progn ;;如果曲线不闭合
        (if(/= (vla-getbulge e i) 0)        ;判断是否有弧度
          (setq  p12 (append  p12 (list v)) pn(1+ pn));提取出现弧度的点放在一起
        )
      )
    )
    (setq lst (append  lst (list v)));不含拟合点的原始点表
    )
      (repeat pn;;循环弧的次数逐个求出拟合点
        (setq j(1+ j))
        (setq pa1(nth j p12) pa2(cadr(member pa1 lst)));弧的两个端点
        (addpn pa1 pa2);;调用求拟合点函数
        (setq lst newlst)
      )
   lst
  )
;;;根据弧的两端点求出其长度
;;;再根据长度求其拟合点
;;;;;;;;求p1-p2之间的拟合点
(defun addpn (p1 p2 / ln ps pe pk pko plt)
  (setq newlst nil)
  (setq        ln (abs        (- (vlax-curve-getDistAtPoint obj p2)
                                        ;返回曲线从开始点到指定点的曲线段的长度
                   (vlax-curve-getDistAtPoint obj p1)
                )
           )
  )                                        ;求得p1到p2的长度
  (setq ps (vlax-curve-getDistAtPoint obj p1));;开始点到弧起点的长度
  (setq pe (vlax-curve-getDistAtPoint obj p2));;开始点到弧端点的长度
  (if (= 0 pe)(setq pe zc));;如果长度为0说明与起点重合此时长度应为总长
  (setq pk (+ ps 1))
  (while (and (> pk ps) (< pk pe));;确保拟合点在弧起始点之间
    (setq pko (vlax-curve-getPointAtDist obj pk))
                                        ;返回曲线上距开始点为指定距离的点          
    (setq plt (cons pko plt))                ;求p1-p2之间的拟合点
    (setq pk (+ box pk));;用box作为步长
  )
  (setq plt(reverse plt));;倒置
  (foreach n lst
    (setq newlst (append newlst (list n)))
    (if        (and (= (car n) (car p1)) (= (cadr n) (cadr p1)))
      (setq newlst (append newlst plt))
      ;;;在表中指定位置插入拟合点形成新表
    )
  )
  newlst
)

myqzq

挺好用的，感谢分享！

香田里浪人

tangjunasd58 发表于 2013-4-23 16:45
;;可点可框的修剪
(defun c:tt (/ PO SS I J S1 P1 P2 p3 p4 len  e1 e1co pt0 fs g z pt  code_12)
  (v ...

挺好用的，感谢分享！

wangdaobin

程序在哪去了！

hehaidizhi

找了一天了，万分感谢

hehaidizhi

但还是没有达到楼主的要求啊

iamxx

不错，顶一个