[测试]：钝刀斩乱麻，请大家测试下！

taner · 发表于 2007-11-6 16:00:57

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

总想搞个和院长的“快刀”差不多的东东，现在终于有点成型。请大家测试，并提出指导！

[FONT=courier new]
;;; ==================================================================
;;; 主程序，偶尔还有点毛病
(defun c:ddzlm (/ curve mark ss ss0 ss1 ss2)
(p-s '(("CMDECHO" 0) ("OSMODE" 0)) t)
(setq mark (ukword 1 "1 2 3 4" "\n\t方式 : 1-打断/2-打断内部删除(不含不与钝刀相交者)/3-打断内部删除(含不与钝刀相交者)/4-打断外部删除"
mark
)
)
(setq curve (car (entsel "\n请选择钝刀<回车退出>:"))) ; (repeat 5
; 添加此循环，可减少毛病，至今令我迷
; 惑
(cond
((= mark "1")
(if (setq ss0 (txt-sel-intofobj curve))
(th-ss-break-by-curve ss0 curve)
)
)
((= mark "2")
(if (setq ss0 (txt-sel-intofobj curve))
(th-ss-break-by-curve ss0 curve)
)
(setq ss (th-touch-in-curve curve))
(command "_.erase" ss "")
)
((= mark "3")
(if (setq ss0 (txt-sel-intofobj curve))
(th-ss-break-by-curve ss0 curve)
)
(setq ss1 (th-touch-in-curve curve))
(setq ss2 (txt-sel-inobj curve))
(setq ss (th-ss-union ss1 ss2))
(command "_.erase" ss "")
)
((= mark "4")
(if (setq ss0 (txt-sel-intofobj curve))
(th-ss-break-by-curve ss0 curve)
)
(setq ss (th-touch-out-curve curve))
(command "_.erase" ss "")
)
(t
nil
)
) ; )
(p-e)
)
;;; ==================================================================
;;; 相关函数,大部分是从网上抄来的。没有注明出处，请原作者原谅！
;;; ==================================================================
;;; 用于程序开头，varlst为重设的系统变量及其值的列表，无改变时用nil替代。
;;; mark为t时，调用undo,nil时不调用。
(defun p-s (varlst mark / sysnamelst valuelst)
(setq undo$mark mark)
(if undo$mark
(vla-startundomark (vla-get-activedocument
(vlax-get-acad-object)
)
)
)
(if varlst
(setq *#$*sysvarnl*#$* (mapcar
'car
varlst
)
sysnamelst *#$*sysvarnl*#$*
valuelst (mapcar
'cadr
varlst
)
)
)
(defun myerr (errmsg)
(if (not (member errmsg '("console break" "Function Cancelled")))
(princ (strcat "\nError: " errmsg))
)
(p-e)
)
(setq errtmp *error*)
(setq *error* myerr)
(if *#$*sysvarnl*#$*
(progn
(setq *#$*svarl*#$* (mapcar
'getvar
*#$*sysvarnl*#$*
)
)
(mapcar
'setvar
sysnamelst
valuelst
)
)
)
(princ)
)
;;; ==================================================================
;;; 用于程序开头结尾
(defun p-e ()
(if undo$mark
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
)
(if *#$*svarl*#$*
(mapcar
'setvar
*#$*sysvarnl*#$*
*#$*svarl*#$*
)
)
(setq *error* errtmp)
(setq *#$*sysvarnl*#$* nil
*#$*svarl*#$* nil
errtmp nil
undo$mark nil
)
(princ)
)
;;; ==================================================================
;;; 关键字输入格式化(院长的)
;;; 方式 : (setq tx1 (ukword 1 "1 2" "\n\t1-任意点/2-中心点" tx1))
;;; ==================================================================
(defun ukword (bit kwd msg def / inp)
(if (and
def
(/= def "")
)
(setq msg (strcat "\n" msg "<" def ">:")
bit (* 2 (fix (/ bit 2)))
)
(setq msg (strcat "\n" msg ":"))
)
(initget bit kwd)
(setq inp (getkword msg))
(if inp
inp
def
)
)
;;; ==================================================================
;;; 建立与obj相交的实体选择集
(defun txt-sel-intofobj (s0 / i len pt1 pt9 s1 ss ss1)
(p-s '(("osmode" 0)) t)
(setq pt1 (txt-getobj-nof9pt s0 1)
pt9 (txt-getobj-nof9pt s0 9)
ss (ssget "c" pt1 pt9)
ss1 (ssadd)
len (sslength ss)
i -1
)
(if (> len 1)
(progn
(command "select" ss "r" s0 "")
(setq ss (ssget "P"))
(while (setq s1 (ssname ss (setq i (1+ i))))
(if (txt1-get-2eint s0 s1 0)
(setq ss1 (ssadd s1 ss1))
)
)
)
)
(p-e)
ss1
)
;;; ==================================================================
;;; 求两实体交点
(defun txt1-get-2eint (fst nxt k / intlst pntlst)
(setq intlst (vlax-invoke (e2o fst) 'intersectwith (e2o nxt) k))
(repeat (/ (length intlst) 3)
(setq pntlst (cons (list (car intlst) (cadr intlst) (caddr intlst))
pntlst
)
intlst (cdddr intlst)
)
)
pntlst ; (reverse pntlst)
)
;;; ==================================================================
(defun e2o (ename)
(vlax-ename->vla-object ename)
)
(defun o2e (obj)
(vlax-vla-object->ename obj)
)
;;; ==================================================================
;;; 实体最小包盒上的9个点之一。
(defun txt-getobj-nof9pt (ename mode)
(txt-get-nof9point (txt-getobj-llur ename) mode)
)
;;; ==================================================================
;;; 实体最小包围盒的对角点
(defun txt-getobj-llur (ename / ll ur)
(vla-getboundingbox (e2o ename) 'll 'ur)
(list (vlax-safearray->list ll) (vlax-safearray->list ur))
)
;;; ==================================================================
;;; ptlist为实体最小包围盒的对角点
(defun txt-get-nof9point (ptlist mode / pointmax pointmin dx dy pt1 pt2 pt3
pt4 pt5 pt6 pt7 pt8 pt9 point
)
(setq pointmax (cadr ptlist)
pointmin (car ptlist)
dx (/ (- (car pointmax) (car pointmin)) 2.0)
dy (/ (- (cadr pointmax) (cadr pointmin)) 2.0)
pt1 pointmin
pt2 (polar pt1 0 dx)
pt3 (polar pt2 0 dx)
pt4 (polar pt1 (* pi 0.5) dy)
pt5 (polar pt4 0 dx)
pt6 (polar pt5 0 dx)
pt7 (polar pt4 (* pi 0.5) dy)
pt8 (polar pt7 0 dx)
pt9 pointmax
)
(cond
((= mode 1)
(setq point pt1)
)
((= mode 2)
(setq point pt2)
)
((= mode 3)
(setq point pt3)
)
((= mode 4)
(setq point pt4)
)
((= mode 5)
(setq point pt5)
)
((= mode 6)
(setq point pt6)
)
((= mode 7)
(setq point pt7)
)
((= mode 8)
(setq point pt8)
)
((= mode 9)
(setq point pt9)
)
(t
(setq point pt1)
)
)
point
)
;;; ==================================================================
(defun th-ss-break-by-curve (ss curve)
(foreach n (th-ss2lst ss)
(if (txt1-get-2eint n curve 0)
(th-curve-break-by-curve n curve)
)
)
)
;;; 将选择集ss在与curve相交处打断
;;; ==================================================================
;;; 选择集转ename表
(defun th-ss2lst (ss)
(vl-remove-if 'listp (mapcar
'cadr
(ssnamex ss)
)
)
)
;;; ==================================================================
(defun th-curve-break-by-curve (ent edgeent / lst)
(if (setq lst (txt1-get-2eint ent edgeent 0))
(th-curve-break-by-ptlst ent lst)
)
)
;;; 将曲线ent在ent与edgeent的交点处打断
;;; ==================================================================
(defun th-ss-break-by-curve (ss curve)
(foreach n (th-ss2lst ss)
(if (txt1-get-2eint n curve 0)
(th-curve-break-by-curve n curve)
)
)
)
;;; 将选择集ss在与curve相交处打断
;;; ==================================================================
(defun th-curve-break-by-ptlst (ent brkptlst / brkpt brkptlst1 brkptlst2
brkptlst3 enttype p1param p2
)
(p-s '(("CMDECHO" 0) ("OSMODE" 0)) t)
(setq enttype (txt-get-dxf 0 ent)
brkptlst1 (th-pts-sort-on-curve ent brkptlst)
brkptlst2 (reverse brkptlst1)
)
(cond
((= "CIRCLE" enttype)
(if (> (length brkptlst) 1)
(progn
(setq brkptlst3 (reverse (cons (car brkptlst1) (reverse
(cdr brkptlst1)
)
)
)
)
(mapcar
(function (lambda (x y)
(txt-mkarc-byc ent x y)
)
)
brkptlst1
brkptlst3
)
(entdel ent)
)
)
)
((and
(= "ELLIPSE" enttype)
(vlax-curve-isclosed ent)
)
(if (> (length brkptlst) 1)
(progn
(setq brkptlst3 (reverse (cons (car brkptlst1) (reverse
(cdr brkptlst1)
)
)
)
)
(mapcar
(function (lambda (x y)
(txt-mkelarc-bye ent x y)
)
)
brkptlst1
brkptlst3
)
(entdel ent)
)
)
)
(t
(foreach brkpt brkptlst2
(cond
((and
(= "SPLINE" enttype)
(vlax-curve-isclosed ent)
)
(setq p1param (vlax-curve-getparamatpoint ent brkpt)
p2 (vlax-curve-getpointatparam ent (+ p1param 0.000001))
)
(command "._break" ent "_non" (trans brkpt 0 1) "_non"
(trans p2 0 1)
)
)
(t
(command "._break" ent "_non" (trans brkpt 0 1) "_non"
(trans brkpt 0 1)
)
)
)
)
)
)
(p-e)
)
;;; 将曲线ent在曲线ent上的点 brkptlst处打断。
;;; ==================================================================
(defun txt-get-dxf (key ename)
(cdr (assoc key (entget ename)))
)
;;; ==================================================================
;;; 点集按pl起点到终点排序
(defun th-pts-sort-on-curve (pl pts)
(setq pts (mapcar
'(lambda (x)
(list (vlax-curve-getdistatpoint pl
(vlax-curve-getclosestpointto pl x)
) x
)
)
pts
)
pts (vl-sort pts '(lambda (e1 e2)
(< (car e1) (car e2))
)
)
)
(mapcar
'cadr
pts
)
)
;;; ==================================================================
;;; 已知圆和其上两点，建弧
(defun txt-mkarc-byc (ename pt1 pt2 / ang1 ang2 cen ent entlst)
(setq entlst (entget ename)
entlst (vl-remove (assoc -1 entlst) entlst)
entlst (vl-remove (assoc 330 entlst) entlst)
entlst (vl-remove (assoc 5 entlst) entlst)
entlst (vl-remove (assoc 0 entlst) entlst)
entlst (vl-remove (assoc 50 entlst) entlst)
entlst (vl-remove (assoc 51 entlst) entlst)
cen (txt-get-dxf 10 ename)
ang1 (angle cen pt1)
ang2 (angle cen pt2)
entlst (append
(list (cons 0 "arc") (cons 100 "AcDbArc"))
entlst
(list (cons 50 ang1) (cons 51 ang2))
)
)
(if (setq ent (entmakex entlst))
ent
)
)
;;; ==================================================================
;;; 已知椭圆和其上两点，建弧
(defun txt-mkelarc-bye (ename pt1 pt2 / ang1 ang2 cen endp ent entlst ratio)
(setq entlst (entget ename)
entlst (vl-remove (assoc -1 entlst) entlst)
entlst (vl-remove (assoc 330 entlst) entlst)
entlst (vl-remove (assoc 5 entlst) entlst)
entlst (vl-remove (assoc 0 entlst) entlst)
entlst (vl-remove (assoc 41 entlst) entlst)
entlst (vl-remove (assoc 42 entlst) entlst)
cen (txt-get-dxf 10 ename)
endp (txt-get-dxf 11 ename)
ratio (txt-get-dxf 40 ename)
ang1 (txt-pt2ell-param pt1 cen endp ratio)
ang2 (txt-pt2ell-param pt2 cen endp ratio)
entlst (append
(list (cons 0 "ELLIPSE"))
entlst
(list (cons 41 ang1) (cons 42 ang2))
)
)
(if (setq ent (entmakex entlst))
ent
)
)
;;; ==================================================================
;;; 椭圆弧端点参数
(defun txt-pt2ell-param (pt cen axis ratio / ang param)
(setq ang (- (angle cen pt) (angle '(0. 0. 0.) axis)))
(cond
((= (cos ang) 0.0) ; 防止分母cos为零出错
(if (> (sin ang) 0.0)
(setq param (* 0.5 pi))
(setq param (* 1.5 pi))
)
)
((= (sin ang) 0.0)
(if (> (cos ang) 0.0)
(setq param 0.0)
(setq param pi)
)
)
(t
(setq param (atan (/ (sin ang) (* (cos ang) ratio))))
(if (< (cos ang) 0.0)
(setq param (+ pi param))
)
)
)
param
)
;;; ==================================================================
;;; ==================================================================
;;; 在obj(封闭曲线)内的实体集
(defun txt-sel-inobj (obj / endp n pt1 pt9 ss ss1 ss2 ss3 ssnamen)
(p-s '(("CMDECHO" 0) ("OSMODE" 0)) t)
(setq ss1 (txt-sel-intofobj obj)
pt1 (txt-getobj-nof9pt obj 1)
pt9 (txt-getobj-nof9pt obj 9)
ss (ssget "c" pt1 pt9)
)
(ssdel obj ss)
(setq ss2 (th-ss-diff ss ss1)
n -1
ss3 (ssadd)
)
(while (setq ssnamen (ssname ss2 (setq n (1+ n))))
(setq endp (vlax-curve-getendpoint ssnamen))
(if (= "in" (th-if-pt-in-curve endp obj))
(ssadd ssnamen ss3)
)
)
(p-e)
ss3
)
;;; ==================================================================
;;; 选择集差集
(defun th-ss-diff (ss1 ss2 / n ss ssnamen)
(setq n -1
m -1
ss (ssadd)
)
(if (= (type ss1) 'ename)
(setq ss1 (ssadd ss1))
)
(if (= (type ss2) 'ename)
(setq ss2 (ssadd ss2))
)
(while (setq ssnamem (ssname ss1 (setq m (1+ m))))
(ssadd ssnamem ss)
)
(while (setq ssnamen (ssname ss2 (setq n (1+ n))))
(if (ssmemb ssnamen ss)
(ssdel ssnamen ss)
)
)
ss
)
;;; ==================================================================
;;; 选择集并集
(defun th-ss-union (ss1 ss2 / m n ss ssnamem ssnamen)
(setq n -1
m -1
ss (ssadd)
)
(if (= (type ss1) 'ename)
(setq ss1 (ssadd ss1))
)
(if (= (type ss2) 'ename)
(setq ss2 (ssadd ss2))
)
(while (setq ssnamen (ssname ss2 (setq n (1+ n))))
(ssadd ssnamen ss)
)
(while (setq ssnamem (ssname ss1 (setq m (1+ m))))
(ssadd ssnamem ss)
)
ss
)
;;; ==================================================================
;;; [url]http://www.xdcad.net/forum/showthread.php?s=&threadid=624082[/url]
(defun th-if-pt-in-curve (pt ent / count mark tmpray)
(if (equal pt (vlax-curve-getclosestpointto ent pt) 1e-6)
(setq mark "on")
(progn
(setq ent (vlax-ename->vla-object ent)
tmpray (vlax-ename->vla-object (entmakex (list '(0 . "RAY") '
(100 . "AcDbEntity")
'(100 . "AcDbRay")
(cons 10 pt)
(cons 11
(mapcar
'+
pt
'
(1 0)
)
) ; 相当于(polar
; pt 0 1)
)
)
)
pt (vlax-3d-point pt)
count 0
)
(repeat 60
(vla-rotate tmpray pt (/ pi 30))
(if (zerop (rem (length (vlax-invoke ent 'intersectwith tmpray 0)) 6))
(setq count (1- count))
(setq count (1+ count))
)
)
(vla-delete tmpray)
(if (minusp count)
(setq mark "out")
(setq mark "in")
)
)
)
mark
)
;;; 点与封闭曲线位置关系
;;; ==================================================================
(defun th-touch-in-curve (curve / disx disy endp intlst intlstlen mark midpt
midxy pt snamelength snamelst ss ssn startp
)
(p-s '(("CMDECHO" 0) ("OSMODE" 0)) t)
(setq ss (txt-sel-intofobj curve)
snamelst (th-ss2lst ss)
ssn (ssadd)
)
(foreach sname snamelst
(setq intlst (th-pts-sort-on-curve sname (txt1-get-2eint sname curve 0))
intlstlen (length intlst)
)
(cond
((= intlstlen 1)
(setq endp (vlax-curve-getendpoint sname))
(setq startp (vlax-curve-getstartpoint sname))
(if (vlax-curve-isclosed sname)
(if (equal endp (car intlst) 1e-6)
(progn
(setq snamelength (vlax-curve-getdistatpoint sname endp))
(setq midpt (vlax-curve-getpointatdist sname (/ snamelength 2)))
(if (= "in" (th-if-pt-in-curve midpt curve))
(ssadd sname ssn)
)
)
(if (= "in" (th-if-pt-in-curve endp curve))
(ssadd sname ssn)
)
)
(if (and
(/= "out" (th-if-pt-in-curve startp curve))
(/= "out" (th-if-pt-in-curve endp curve))
)
(ssadd sname ssn)
)
)
)
((= nil (txt-remove "in" (mapcar
(function (lambda (x y)
(setq disx
(vlax-curve-getdistatpoint sname
(vlax-curve-getclosestpointto sname x)
)
disy
(vlax-curve-getdistatpoint sname
(vlax-curve-getclosestpointto sname y)
)
midxy (/ (+ disx disy) 2)
pt
(vlax-curve-getpointatdist sname midxy)
mark
(th-if-pt-in-curve pt
curve
)
)
)
)
intlst
(reverse (cons (car intlst)
(reverse (cdr intlst))
)
)
)
)
)
(ssadd sname ssn)
)
)
)
(p-e)
ssn
)
;;; 筛选与curve相交并除交点外，其余部分全部在curve内。curve为封闭实体.
;;; ==================================================================
(defun th-touch-out-curve (curve / disx disy endp intlst intlstlen mark
midpt midxy pt snamelength snamelst ss ssn
startp
)
(p-s '(("CMDECHO" 0) ("OSMODE" 0)) t)
(setq ss (txt-sel-intofobj curve)
snamelst (th-ss2lst ss)
ssn (ssadd)
)
(foreach sname snamelst
(setq intlst (th-pts-sort-on-curve sname (txt1-get-2eint sname curve 0))
intlstlen (length intlst)
)
(cond
((= intlstlen 1)
(setq endp (vlax-curve-getendpoint sname))
(setq startp (vlax-curve-getstartpoint sname))
(if (vlax-curve-isclosed sname)
(if (equal endp (car intlst) 1e-6)
(progn
(setq snamelength (vlax-curve-getdistatpoint sname endp))
(setq midpt (vlax-curve-getpointatdist sname (/ snamelength 2)))
(if (= "out" (th-if-pt-in-curve midpt curve))
(ssadd sname ssn)
)
)
(if (= "out" (th-if-pt-in-curve endp curve))
(ssadd sname ssn)
)
)
(if (and
(/= "in" (th-if-pt-in-curve startp curve))
(/= "in" (th-if-pt-in-curve endp curve))
)
(ssadd sname ssn)
)
)
)
((= nil (txt-remove "out" (mapcar
(function (lambda (x y)
(setq disx
(vlax-curve-getdistatpoint sname
(vlax-curve-getclosestpointto sname x)
)
disy
(vlax-curve-getdistatpoint sname
(vlax-curve-getclosestpointto sname y)
)
midxy (/ (+ disx disy) 2)
pt
(vlax-curve-getpointatdist sname midxy)
mark
(th-if-pt-in-curve pt curve)
)
)
)
intlst
(reverse (cons (car intlst)
(reverse (cdr intlst))
)
)
)
)
)
(ssadd sname ssn)
)
)
)
(p-e)
ssn
)
;;; 筛选与curve相交并除交点外，其余部分全部在curve外。curve为封闭实体.
;;; ==================================================================
;;; 从表中移除某元素
(defun txt-remove (x lst)
(setq lst (txt-list-subtract lst (list x)))
)
;;; ==================================================================
;;; 语法: (txt-list-subtract 表1 表2). 表差集
;;; ==================================================================
(defun txt-list-subtract (lst1 lst2 / lst)
(setq lst '())
(if lst1
(foreach tmp lst1
(if (not (member tmp lst2))
(setq lst (cons tmp lst))
)
)
)
(setq lst (reverse lst))
lst
)
;;; ==================================================================
[/FONT]

[FONT=courier new] 
;;; ================================================================== 
;;; 主程序，偶尔还有点毛病 
(defun c:ddzlm (/ curve mark ss ss0 ss1 ss2) 
  (p-s '(("CMDECHO" 0) ("OSMODE" 0)) t) 
  (setq mark (ukword 1 "1 2 3 4" "\n\t方式 : 1-打断/2-打断内部删除(不含不与钝刀相交者)/3-打断内部删除(含不与钝刀相交者)/4-打断外部删除" 
                     mark 
             ) 
  ) 
  (setq curve (car (entsel "\n请选择钝刀<回车退出>:")))        ;  (repeat 5 
                                       ; 添加此循环，可减少毛病，至今令我迷 
                                       ; 惑 
  (cond 
    ((= mark "1") 
      (if (setq ss0 (txt-sel-intofobj curve)) 
        (th-ss-break-by-curve ss0 curve) 
      ) 
    ) 
    ((= mark "2") 
      (if (setq ss0 (txt-sel-intofobj curve)) 
        (th-ss-break-by-curve ss0 curve) 
      ) 
      (setq ss (th-touch-in-curve curve)) 
      (command "_.erase" ss "") 
    ) 
    ((= mark "3") 
      (if (setq ss0 (txt-sel-intofobj curve)) 
        (th-ss-break-by-curve ss0 curve) 
      ) 
      (setq ss1 (th-touch-in-curve curve)) 
      (setq ss2 (txt-sel-inobj curve)) 
      (setq ss (th-ss-union ss1 ss2)) 
      (command "_.erase" ss "") 
    ) 
    ((= mark "4") 
      (if (setq ss0 (txt-sel-intofobj curve)) 
        (th-ss-break-by-curve ss0 curve) 
      ) 
      (setq ss (th-touch-out-curve curve)) 
      (command "_.erase" ss "") 
    ) 
    (t 
      nil 
    ) 
  )                                       ;  ) 
  (p-e) 
) 
;;; ================================================================== 
;;; 相关函数,大部分是从网上抄来的。没有注明出处，请原作者原谅！ 
;;; ================================================================== 
;;; 用于程序开头，varlst为重设的系统变量及其值的列表，无改变时用nil替代。 
;;; mark为t时，调用undo,nil时不调用。 
(defun p-s (varlst mark / sysnamelst valuelst) 
  (setq undo$mark mark) 
  (if undo$mark 
    (vla-startundomark (vla-get-activedocument 
                                               (vlax-get-acad-object) 
                       ) 
    ) 
  ) 
  (if varlst 
    (setq *#$*sysvarnl*#$* (mapcar 
                             'car 
                             varlst 
                           ) 
          sysnamelst *#$*sysvarnl*#$* 
          valuelst (mapcar 
                     'cadr 
                     varlst 
                   ) 
    ) 
  ) 
  (defun myerr (errmsg) 
    (if (not (member errmsg '("console break" "Function Cancelled"))) 
      (princ (strcat "\nError: " errmsg)) 
    ) 
    (p-e) 
  ) 
  (setq errtmp *error*) 
  (setq *error* myerr) 
  (if *#$*sysvarnl*#$* 
    (progn 
      (setq *#$*svarl*#$* (mapcar 
                            'getvar 
                            *#$*sysvarnl*#$* 
                          ) 
      ) 
      (mapcar 
        'setvar 
        sysnamelst 
        valuelst 
      ) 
    ) 
  ) 
  (princ) 
) 
;;; ================================================================== 
;;; 用于程序开头结尾 
(defun p-e () 
  (if undo$mark 
    (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) 
  ) 
  (if *#$*svarl*#$* 
    (mapcar 
      'setvar 
      *#$*sysvarnl*#$* 
      *#$*svarl*#$* 
    ) 
  ) 
  (setq *error* errtmp) 
  (setq *#$*sysvarnl*#$* nil 
        *#$*svarl*#$* nil 
        errtmp nil 
        undo$mark nil 
  ) 
  (princ) 
) 
;;; ================================================================== 
;;;                   关键字输入格式化(院长的) 
;;; 方式 : (setq tx1 (ukword 1 "1 2" "\n\t1-任意点/2-中心点" tx1)) 
;;; ================================================================== 
(defun ukword (bit kwd msg def / inp) 
  (if (and 
        def 
        (/= def "") 
      ) 
    (setq msg (strcat "\n" msg "<" def ">:") 
          bit (* 2 (fix (/ bit 2))) 
    ) 
    (setq msg (strcat "\n" msg ":")) 
  ) 
  (initget bit kwd) 
  (setq inp (getkword msg)) 
  (if inp 
    inp 
    def 
  ) 
) 
;;; ================================================================== 
;;; 建立与obj相交的实体选择集 
(defun txt-sel-intofobj (s0 / i len pt1 pt9 s1 ss ss1) 
  (p-s '(("osmode" 0)) t) 
  (setq pt1 (txt-getobj-nof9pt s0 1) 
        pt9 (txt-getobj-nof9pt s0 9) 
        ss (ssget "c" pt1 pt9) 
        ss1 (ssadd) 
        len (sslength ss) 
        i -1 
  ) 
  (if (> len 1) 
    (progn 
      (command "select" ss "r" s0 "") 
      (setq ss (ssget "P")) 
      (while (setq s1 (ssname ss (setq i (1+ i)))) 
        (if (txt1-get-2eint s0 s1 0) 
          (setq ss1 (ssadd s1 ss1)) 
        ) 
      ) 
    ) 
  ) 
  (p-e) 
  ss1 
) 
;;; ================================================================== 
;;; 求两实体交点 
(defun txt1-get-2eint (fst nxt k / intlst pntlst) 
  (setq intlst (vlax-invoke (e2o fst) 'intersectwith (e2o nxt) k)) 
  (repeat (/ (length intlst) 3) 
    (setq pntlst (cons (list (car intlst) (cadr intlst) (caddr intlst)) 
                       pntlst 
                 ) 
          intlst (cdddr intlst) 
    ) 
  ) 
  pntlst                               ; (reverse pntlst) 
) 
;;; ================================================================== 
(defun e2o (ename) 
  (vlax-ename->vla-object ename) 
) 
(defun o2e (obj) 
  (vlax-vla-object->ename obj) 
) 
;;; ================================================================== 
;;; 实体最小包盒上的9个点之一。 
(defun txt-getobj-nof9pt (ename mode) 
  (txt-get-nof9point (txt-getobj-llur ename) mode) 
) 
;;; ================================================================== 
;;; 实体最小包围盒的对角点 
(defun txt-getobj-llur (ename / ll ur) 
  (vla-getboundingbox (e2o ename) 'll 'ur) 
  (list (vlax-safearray->list ll) (vlax-safearray->list ur)) 
) 
;;; ================================================================== 
;;; ptlist为实体最小包围盒的对角点 
(defun txt-get-nof9point (ptlist mode / pointmax pointmin dx dy pt1 pt2 pt3 
                                 pt4 pt5 pt6 pt7 pt8 pt9 point 
                         ) 
  (setq pointmax (cadr ptlist) 
        pointmin (car ptlist) 
        dx (/ (- (car pointmax) (car pointmin)) 2.0) 
        dy (/ (- (cadr pointmax) (cadr pointmin)) 2.0) 
        pt1 pointmin 
        pt2 (polar pt1 0 dx) 
        pt3 (polar pt2 0 dx) 
        pt4 (polar pt1 (* pi 0.5) dy) 
        pt5 (polar pt4 0 dx) 
        pt6 (polar pt5 0 dx) 
        pt7 (polar pt4 (* pi 0.5) dy) 
        pt8 (polar pt7 0 dx) 
        pt9 pointmax 
  ) 
  (cond 
    ((= mode 1) 
      (setq point pt1) 
    ) 
    ((= mode 2) 
      (setq point pt2) 
    ) 
    ((= mode 3) 
      (setq point pt3) 
    ) 
    ((= mode 4) 
      (setq point pt4) 
    ) 
    ((= mode 5) 
      (setq point pt5) 
    ) 
    ((= mode 6) 
      (setq point pt6) 
    ) 
    ((= mode 7) 
      (setq point pt7) 
    ) 
    ((= mode 8) 
      (setq point pt8) 
    ) 
    ((= mode 9) 
      (setq point pt9) 
    ) 
    (t 
      (setq point pt1) 
    ) 
  ) 
  point 
) 
;;; ================================================================== 
(defun th-ss-break-by-curve (ss curve) 
  (foreach n (th-ss2lst ss) 
    (if (txt1-get-2eint n curve 0) 
      (th-curve-break-by-curve n curve) 
    ) 
  ) 
) 
;;; 将选择集ss在与curve相交处打断 
;;; ================================================================== 
;;; 选择集转ename表 
(defun th-ss2lst (ss) 
  (vl-remove-if 'listp (mapcar 
                         'cadr 
                         (ssnamex ss) 
                       ) 
  ) 
) 
;;; ================================================================== 
(defun th-curve-break-by-curve (ent edgeent / lst) 
  (if (setq lst (txt1-get-2eint ent edgeent 0)) 
    (th-curve-break-by-ptlst ent lst) 
  ) 
) 
;;; 将曲线ent在ent与edgeent的交点处打断 
;;; ================================================================== 
(defun th-ss-break-by-curve (ss curve) 
  (foreach n (th-ss2lst ss) 
    (if (txt1-get-2eint n curve 0) 
      (th-curve-break-by-curve n curve) 
    ) 
  ) 
) 
;;; 将选择集ss在与curve相交处打断 
;;; ================================================================== 
(defun th-curve-break-by-ptlst (ent brkptlst / brkpt brkptlst1 brkptlst2 
                                    brkptlst3 enttype p1param p2 
                               ) 
  (p-s '(("CMDECHO" 0) ("OSMODE" 0)) t) 
  (setq enttype (txt-get-dxf 0 ent) 
        brkptlst1 (th-pts-sort-on-curve ent brkptlst) 
        brkptlst2 (reverse brkptlst1) 
  ) 
  (cond 
    ((= "CIRCLE" enttype) 
      (if (> (length brkptlst) 1) 
        (progn 
          (setq brkptlst3 (reverse (cons (car brkptlst1) (reverse 
                                                                  (cdr brkptlst1) 
                                                         ) 
                                   ) 
                          ) 
          ) 
          (mapcar 
            (function (lambda (x y) 
                        (txt-mkarc-byc ent x y) 
                      ) 
            ) 
            brkptlst1 
            brkptlst3 
          ) 
          (entdel ent) 
        ) 
      ) 
    ) 
    ((and 
       (= "ELLIPSE" enttype) 
       (vlax-curve-isclosed ent) 
     ) 
      (if (> (length brkptlst) 1) 
        (progn 
          (setq brkptlst3 (reverse (cons (car brkptlst1) (reverse 
                                                                  (cdr brkptlst1) 
                                                         ) 
                                   ) 
                          ) 
          ) 
          (mapcar 
            (function (lambda (x y) 
                        (txt-mkelarc-bye ent x y) 
                      ) 
            ) 
            brkptlst1 
            brkptlst3 
          ) 
          (entdel ent) 
        ) 
      ) 
    ) 
    (t 
      (foreach brkpt brkptlst2 
        (cond 
          ((and 
             (= "SPLINE" enttype) 
             (vlax-curve-isclosed ent) 
           ) 
            (setq p1param (vlax-curve-getparamatpoint ent brkpt) 
                  p2 (vlax-curve-getpointatparam ent (+ p1param 0.000001)) 
            ) 
            (command "._break" ent "_non" (trans brkpt 0 1) "_non" 
                     (trans p2 0 1) 
            ) 
          ) 
          (t 
            (command "._break" ent "_non" (trans brkpt 0 1) "_non" 
                     (trans brkpt 0 1) 
            ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (p-e) 
) 
;;; 将曲线ent在曲线ent上的点 brkptlst处打断。 
;;; ================================================================== 
(defun txt-get-dxf (key ename) 
  (cdr (assoc key (entget ename))) 
) 
;;; ================================================================== 
;;; 点集按pl起点到终点排序 
(defun th-pts-sort-on-curve (pl pts) 
  (setq pts (mapcar 
              '(lambda (x) 
                 (list (vlax-curve-getdistatpoint pl 
                                                  (vlax-curve-getclosestpointto pl x) 
                       ) x 
                 ) 
               ) 
              pts 
            ) 
        pts (vl-sort pts '(lambda (e1 e2) 
                            (< (car e1) (car e2)) 
                          ) 
            ) 
  ) 
  (mapcar 
    'cadr 
    pts 
  ) 
) 
;;; ================================================================== 
;;; 已知圆和其上两点，建弧 
(defun txt-mkarc-byc (ename pt1 pt2 / ang1 ang2 cen ent entlst) 
  (setq entlst (entget ename) 
        entlst (vl-remove (assoc -1 entlst) entlst) 
        entlst (vl-remove (assoc 330 entlst) entlst) 
        entlst (vl-remove (assoc 5 entlst) entlst) 
        entlst (vl-remove (assoc 0 entlst) entlst) 
        entlst (vl-remove (assoc 50 entlst) entlst) 
        entlst (vl-remove (assoc 51 entlst) entlst) 
        cen (txt-get-dxf 10 ename) 
        ang1 (angle cen pt1) 
        ang2 (angle cen pt2) 
        entlst (append 
                 (list (cons 0 "arc") (cons 100 "AcDbArc")) 
                 entlst 
                 (list (cons 50 ang1) (cons 51 ang2)) 
               ) 
  ) 
  (if (setq ent (entmakex entlst)) 
    ent 
  ) 
) 
;;; ================================================================== 
;;; 已知椭圆和其上两点，建弧 
(defun txt-mkelarc-bye (ename pt1 pt2 / ang1 ang2 cen endp ent entlst ratio) 
  (setq entlst (entget ename) 
        entlst (vl-remove (assoc -1 entlst) entlst) 
        entlst (vl-remove (assoc 330 entlst) entlst) 
        entlst (vl-remove (assoc 5 entlst) entlst) 
        entlst (vl-remove (assoc 0 entlst) entlst) 
        entlst (vl-remove (assoc 41 entlst) entlst) 
        entlst (vl-remove (assoc 42 entlst) entlst) 
        cen (txt-get-dxf 10 ename) 
        endp (txt-get-dxf 11 ename) 
        ratio (txt-get-dxf 40 ename) 
        ang1 (txt-pt2ell-param pt1 cen endp ratio) 
        ang2 (txt-pt2ell-param pt2 cen endp ratio) 
        entlst (append 
                 (list (cons 0 "ELLIPSE")) 
                 entlst 
                 (list (cons 41 ang1) (cons 42 ang2)) 
               ) 
  ) 
  (if (setq ent (entmakex entlst)) 
    ent 
  ) 
) 
;;; ================================================================== 
;;; 椭圆弧端点参数 
(defun txt-pt2ell-param (pt cen axis ratio / ang param) 
  (setq ang (- (angle cen pt) (angle '(0. 0. 0.) axis))) 
  (cond 
    ((= (cos ang) 0.0)                       ; 防止分母cos为零出错 
      (if (> (sin ang) 0.0) 
        (setq param (* 0.5 pi)) 
        (setq param (* 1.5 pi)) 
      ) 
    ) 
    ((= (sin ang) 0.0) 
      (if (> (cos ang) 0.0) 
        (setq param 0.0) 
        (setq param pi) 
      ) 
    ) 
    (t 
      (setq param (atan (/ (sin ang) (* (cos ang) ratio)))) 
      (if (< (cos ang) 0.0) 
        (setq param (+ pi param)) 
      ) 
    ) 
  ) 
  param 
) 
;;; ================================================================== 
;;; ================================================================== 
;;; 在obj(封闭曲线)内的实体集 
(defun txt-sel-inobj (obj / endp n pt1 pt9 ss ss1 ss2 ss3 ssnamen) 
  (p-s '(("CMDECHO" 0) ("OSMODE" 0)) t) 
  (setq ss1 (txt-sel-intofobj obj) 
        pt1 (txt-getobj-nof9pt obj 1) 
        pt9 (txt-getobj-nof9pt obj 9) 
        ss (ssget "c" pt1 pt9) 
  ) 
  (ssdel obj ss) 
  (setq ss2 (th-ss-diff ss ss1) 
        n -1 
        ss3 (ssadd) 
  ) 
  (while (setq ssnamen (ssname ss2 (setq n (1+ n)))) 
    (setq endp (vlax-curve-getendpoint ssnamen)) 
    (if (= "in" (th-if-pt-in-curve endp obj)) 
      (ssadd ssnamen ss3) 
    ) 
  ) 
  (p-e) 
  ss3 
) 
;;; ================================================================== 
;;; 选择集差集 
(defun th-ss-diff (ss1 ss2 / n ss ssnamen) 
  (setq n -1 
        m -1 
        ss (ssadd) 
  ) 
  (if (= (type ss1) 'ename) 
    (setq ss1 (ssadd ss1)) 
  ) 
  (if (= (type ss2) 'ename) 
    (setq ss2 (ssadd ss2)) 
  ) 
  (while (setq ssnamem (ssname ss1 (setq m (1+ m)))) 
    (ssadd ssnamem ss) 
  ) 
  (while (setq ssnamen (ssname ss2 (setq n (1+ n)))) 
    (if (ssmemb ssnamen ss) 
      (ssdel ssnamen ss) 
    ) 
  ) 
  ss 
) 
;;; ================================================================== 
;;; 选择集并集 
(defun th-ss-union (ss1 ss2 / m n ss ssnamem ssnamen) 
  (setq n -1 
        m -1 
        ss (ssadd) 
  ) 
  (if (= (type ss1) 'ename) 
    (setq ss1 (ssadd ss1)) 
  ) 
  (if (= (type ss2) 'ename) 
    (setq ss2 (ssadd ss2)) 
  ) 
  (while (setq ssnamen (ssname ss2 (setq n (1+ n)))) 
    (ssadd ssnamen ss) 
  ) 
  (while (setq ssnamem (ssname ss1 (setq m (1+ m)))) 
    (ssadd ssnamem ss) 
  ) 
  ss 
) 
;;; ================================================================== 
;;; [url]http://www.xdcad.net/forum/showthread.php?s=&threadid=624082[/url] 
(defun th-if-pt-in-curve (pt ent / count mark tmpray) 
  (if (equal pt (vlax-curve-getclosestpointto ent pt) 1e-6) 
    (setq mark "on") 
    (progn 
      (setq ent (vlax-ename->vla-object ent) 
            tmpray (vlax-ename->vla-object (entmakex (list '(0 . "RAY") ' 
                                                           (100 . "AcDbEntity") 
                                                           '(100 . "AcDbRay") 
                                                           (cons 10 pt) 
                                                           (cons 11 
                                                                 (mapcar 
                                                                   '+ 
                                                                   pt 
                                                                   ' 
                                                                   (1 0) 
                                                                 ) 
                                                           ) ; 相当于(polar 
                                       ; pt 0 1) 
                                                     ) 
                                           ) 
                   ) 
            pt (vlax-3d-point pt) 
            count 0 
      ) 
      (repeat 60 
        (vla-rotate tmpray pt (/ pi 30)) 
        (if (zerop (rem (length (vlax-invoke ent 'intersectwith tmpray 0)) 6)) 
          (setq count (1- count)) 
          (setq count (1+ count)) 
        ) 
      ) 
      (vla-delete tmpray) 
      (if (minusp count) 
        (setq mark "out") 
        (setq mark "in") 
      ) 
    ) 
  ) 
  mark 
) 
;;; 点与封闭曲线位置关系 
;;; ================================================================== 
(defun th-touch-in-curve (curve / disx disy endp intlst intlstlen mark midpt 
                                midxy pt snamelength snamelst ss ssn startp 
                         ) 
  (p-s '(("CMDECHO" 0) ("OSMODE" 0)) t) 
  (setq ss (txt-sel-intofobj curve) 
        snamelst (th-ss2lst ss) 
        ssn (ssadd) 
  ) 
  (foreach sname snamelst 
    (setq intlst (th-pts-sort-on-curve sname (txt1-get-2eint sname curve 0)) 
          intlstlen (length intlst) 
    ) 
    (cond 
      ((= intlstlen 1) 
        (setq endp (vlax-curve-getendpoint sname)) 
        (setq startp (vlax-curve-getstartpoint sname)) 
        (if (vlax-curve-isclosed sname) 
          (if (equal endp (car intlst) 1e-6) 
            (progn 
              (setq snamelength (vlax-curve-getdistatpoint sname endp)) 
              (setq midpt (vlax-curve-getpointatdist sname (/ snamelength 2))) 
              (if (= "in" (th-if-pt-in-curve midpt curve)) 
                (ssadd sname ssn) 
              ) 
            ) 
            (if (= "in" (th-if-pt-in-curve endp curve)) 
              (ssadd sname ssn) 
            ) 
          ) 
          (if (and 
                (/= "out" (th-if-pt-in-curve startp curve)) 
                (/= "out" (th-if-pt-in-curve endp curve)) 
              ) 
            (ssadd sname ssn) 
          ) 
        ) 
      ) 
      ((= nil (txt-remove "in" (mapcar 
                                 (function (lambda (x y) 
                                             (setq disx 
                                                   (vlax-curve-getdistatpoint sname 
                                                                              (vlax-curve-getclosestpointto sname x) 
                                                   ) 
                                                   disy 
                                                   (vlax-curve-getdistatpoint sname 
                                                                              (vlax-curve-getclosestpointto sname y) 
                                                   ) 
                                                   midxy (/ (+ disx disy) 2) 
                                                   pt 
                                                   (vlax-curve-getpointatdist sname midxy) 
                                                   mark 
                                                   (th-if-pt-in-curve pt 
                                                                      curve 
                                                   ) 
                                             ) 
                                           ) 
                                 ) 
                                 intlst 
                                 (reverse (cons (car intlst) 
                                                (reverse (cdr intlst)) 
                                          ) 
                                 ) 
                               ) 
              ) 
       ) 
        (ssadd sname ssn) 
      ) 
    ) 
  ) 
  (p-e) 
  ssn 
) 
;;; 筛选与curve相交并除交点外，其余部分全部在curve内。curve为封闭实体. 
;;; ================================================================== 
(defun th-touch-out-curve (curve / disx disy endp intlst intlstlen mark 
                                 midpt midxy pt snamelength snamelst ss ssn 
                                 startp 
                          ) 
  (p-s '(("CMDECHO" 0) ("OSMODE" 0)) t) 
  (setq ss (txt-sel-intofobj curve) 
        snamelst (th-ss2lst ss) 
        ssn (ssadd) 
  ) 
  (foreach sname snamelst 
    (setq intlst (th-pts-sort-on-curve sname (txt1-get-2eint sname curve 0)) 
          intlstlen (length intlst) 
    ) 
    (cond 
      ((= intlstlen 1) 
        (setq endp (vlax-curve-getendpoint sname)) 
        (setq startp (vlax-curve-getstartpoint sname)) 
        (if (vlax-curve-isclosed sname) 
          (if (equal endp (car intlst) 1e-6) 
            (progn 
              (setq snamelength (vlax-curve-getdistatpoint sname endp)) 
              (setq midpt (vlax-curve-getpointatdist sname (/ snamelength 2))) 
              (if (= "out" (th-if-pt-in-curve midpt curve)) 
                (ssadd sname ssn) 
              ) 
            ) 
            (if (= "out" (th-if-pt-in-curve endp curve)) 
              (ssadd sname ssn) 
            ) 
          ) 
          (if (and 
                (/= "in" (th-if-pt-in-curve startp curve)) 
                (/= "in" (th-if-pt-in-curve endp curve)) 
              ) 
            (ssadd sname ssn) 
          ) 
        ) 
      ) 
      ((= nil (txt-remove "out" (mapcar 
                                  (function (lambda (x y) 
                                              (setq disx 
                                                    (vlax-curve-getdistatpoint sname 
                                                                               (vlax-curve-getclosestpointto sname x) 
                                                    ) 
                                                    disy 
                                                    (vlax-curve-getdistatpoint sname 
                                                                               (vlax-curve-getclosestpointto sname y) 
                                                    ) 
                                                    midxy (/ (+ disx disy) 2) 
                                                    pt 
                                                    (vlax-curve-getpointatdist sname midxy) 
                                                    mark 
                                                    (th-if-pt-in-curve pt curve) 
                                              ) 
                                            ) 
                                  ) 
                                  intlst 
                                  (reverse (cons (car intlst) 
                                                 (reverse (cdr intlst)) 
                                           ) 
                                  ) 
                                ) 
              ) 
       ) 
        (ssadd sname ssn) 
      ) 
    ) 
  ) 
  (p-e) 
  ssn 
) 
;;; 筛选与curve相交并除交点外，其余部分全部在curve外。curve为封闭实体. 
;;; ================================================================== 
;;; 从表中移除某元素 
(defun txt-remove (x lst) 
  (setq lst (txt-list-subtract lst (list x))) 
) 
;;; ================================================================== 
 
;;; 语法: (txt-list-subtract 表1 表2). 表差集 
;;; ================================================================== 
(defun txt-list-subtract (lst1 lst2 / lst) 
  (setq lst '()) 
  (if lst1 
    (foreach tmp lst1 
      (if (not (member tmp lst2)) 
        (setq lst (cons tmp lst)) 
      ) 
    ) 
  ) 
  (setq lst (reverse lst)) 
  lst 
) 
;;; ================================================================== 
 
  [/FONT]

zml84 · 发表于 2007-11-7 08:52:52

拿是拿来了，可是没消化啊。。

pipeng611 · 发表于 2007-11-7 11:46:28

测试完成，还是对带高程的平面图没用！

WHGF · 发表于 2007-11-7 15:33:57

刀是快了，可掌握和使用还要一段时间

sfjlx · 发表于 2007-11-7 19:11:12

可否介绍一下是干什么用的？

dwg001 · 发表于 2007-11-8 09:11:58

1,刀的提示含义不确切。对2、3、4选项刀似乎应是封闭的，否则内外区分不了。
2,俺在cad2006下小测试简单图形，封闭的刀可以完成楼主的功能。
3，俺在cad2004下小测试带尺寸和图框的稍复杂图形，程序莫名退出，不能完成楼主的功能。

animal212 · 发表于 2007-11-9 16:38:27

我想要乱麻斩快刀的程序，有谁有呢？

小菜 · 发表于 2007-12-2 09:50:44

粗看一下，似乎不支持UCS
我也做过类似的功能，想了解楼主说的偶尔有点毛病的情况，或者把有毛病的图发一个给我测试一下:ge-betz@tom.com，谢谢

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

[测试]：钝刀斩乱麻，请大家测试下！

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子