pzweng 发表于 2012-4-11 09:41:13

这个功能可能用得到，先下来看看

linheyuanpcb 发表于 2012-4-11 10:20:53

看下，斜线切割应该也可以吧

xin888 发表于 2012-4-11 10:23:33

学习学习！需要此功能！

crtrccrt 发表于 2012-4-11 10:31:49

一个字
很好

crtrccrt 发表于 2012-4-11 10:40:30

注意:
遇上Spline
ellipse
及新画 切割 自身
就很可能 出错.

crtrccrt 发表于 2012-4-11 10:41:55


;;;明经通道 编制 By Gu_xl 2011年7月5日双线切割 修改 crtrccrt;;
(defun c:Dtm (/ p1 p3 p4 dis pl s1en wenpline pline1 pline1 ss ssbj kd ss1 ss2 ss3 ss4 pl1 pl2 removesel)
(setq os (getvar 'osmode))
(setq cmd (getvar 'cmdecho))
(mapcar 'setvar (list 'osmode 'cmdecho) '(0 0))
   (if *w*
   (progn
       (initget 6);;增加;;
   (setq w (getdist ;|(getvar "viewctr")|; (strcat "\n 双线宽度<" (rtos *w* 2 2) ">: ")));;修改;;
   (if (null w) (setq w *w*) (setq *w* w))
   )
   (progn
       (initget 6);;增加;;
       (setq w (getdist (strcat "\n 双线宽度<100.0>: ")));;修改;;
       (if (null w) (setq w 100.0 *w* w) (setq *w* w));;修改;;
       )
   )
   (princ w);;增加;;
   (initget 7 "Yes No")
   (setq kd (getkword "\n 是否删除双线<No>:"))
   (setq en (entlast))
   (princ "\n 请绘制双线中线: ")
   (setvar 'osmode 3071)
   (vl-cmdf "_pline")
   (while (= 1 (getvar "cmdactive"))
   (vl-cmdf pause)
   )
   (setvar 'osmode 0)
   (setq enpline (entlast))
   (if (not (equal en enpline))
   (progn
   (vla-Offset (vlax-ename->vla-object enpline) (/ w 2.0))
   (setq pline1 (entlast))
   (vla-Offset (vlax-ename->vla-object enpline) (/ w -2.0))
   (setq pline2 (entlast))
   (setq ssbj (ssadd pline1))
   (ssadd pline2 ssbj)
   (setq pl (mapcar 'cdr (vl-remove-if '(lambda (x) (/= 10 (car x))) (entget pline1))))
   (setq pl (append pl (reverse (mapcar 'cdr (vl-remove-if '(lambda (x) (/= 10 (car x))) (entget pline2))))))
   (setq p1 (apply 'mapcar (cons 'min pl))
         p3 (apply 'mapcar (cons 'max pl))
         )
   (command "_.Zoom" "_Window" p1 p3 "._Zoom" "0.95x")
   (setq dis (* 0.15 w))
   (vla-Offset (vlax-ename->vla-object enpline) (- (/ w 2.0) dis))
   (setq pline3 (entlast))
   (vla-Offset (vlax-ename->vla-object enpline) (+ dis (/ w -2.0)))
   (setq pline4 (entlast))
   (setq pl1 (mapcar 'cdr (vl-remove-if '(lambda (x) (/= 10 (car x))) (entget pline3))))
   (setq pl2 (reverse (mapcar 'cdr (vl-remove-if '(lambda (x) (/= 10 (car x))) (entget pline4)))))
   (entdel pline3)
   (entdel pline4)
   (vla-put-Visible (vlax-ename->vla-object pline1) :vlax-false)
   (vla-put-Visible (vlax-ename->vla-object pline2) :vlax-false)
   (setq ss1 (ssget "f" (list (car pl1) (last pl2))) ss2 (ssget "f" (list (last pl1) (car pl2))))
   (if ss1
   (repeat (setq n (sslength ss1))
       (setq removesel (cons (ssname ss1 (setq n (1- n))) removesel))
       )
   )
   (if ss2
   (repeat (setq n (sslength ss2))
       (setq removesel (cons (ssname ss2 (setq n (1- n))) removesel))
       )
   )
   (mapcar '(lambda (x) (vla-put-Visible (vlax-ename->vla-object x) :vlax-false)) removesel)
   (vla-put-Visible (vlax-ename->vla-object pline1) :vlax-true)
   (vla-put-Visible (vlax-ename->vla-object pline2) :vlax-true)
   (setq pl1 (append pl1 pl2))
   (command "trim" ssbj "" )
   (setq p1 (car pl1))
   (foreach a (cdr pl1)
   (command "f" p1 a "")
   (setq p1 a)
   )
   (command "")
   (mapcar '(lambda (x) (vla-put-Visible (vlax-ename->vla-object x) :vlax-true)) removesel)
   (entdel enpline)
   (setq ss (ssget "wp" pl))
   (if ss (command "erase" ss ""))
   (if (= "Yes" kd)
   (progn
       (entdel pline1)
       (entdel pline2)
       )
   )
   )
   )
(mapcar 'setvar (list 'osmode 'cmdecho) (list os cmd))
   (princ)
   )

sqqr 发表于 2012-4-11 12:58:06

非常了得！！

ejingsong 发表于 2012-4-11 18:03:22

看看

vlisp2012 发表于 2012-4-11 19:46:14

还能减分呢？才知道！！！

【KAIXIN】 发表于 2012-4-11 19:51:14

看看，虽然有思路，见识下G版的程序
页: 1 2 [3] 4 5 6 7 8 9 10 11 12
查看完整版本: 【求双线切割工具】Gu_xl版主已完美解决！~~