求一个标注断开的lisp 和标注合并

0_zh_0

求版主帮忙改革lisp ,是一个标注断开的lisp 和标注合并 

 下面的lsp在cad里不能用 请帮忙给我改一个 谢谢了  非常感谢

 标注断开的lsp     (defun c:bzhdKk(/ getpnt getzf e p3 q0 d1 le le1 lna tfdo tfdo0 tfdd tfzf)(defun getpnt()(foreach e le(redraw e 3))(while(and(progn(initget 128)(setq d1 nil tfdo nil q0(_xdin_"\n再点取要断开的点(或键入新尺寸值) <退出>: ")))(/='LIST(type q0))(/='INT(type(setq d1(read q0))))(/='REAL(type d1)))(princ"\n*** 应取点或输入尺寸值, 请重新输入!"))q0)(defun getzf(e p / mx q1 q2 q3 q4 q5 p0 a0 a1 a2 r1 r2 r3 tf)(setq mx 1e5)(_calsun2_ e)(dm_tl3)(cond((dm_tl4 tf)(dm_tl5 tf)(dm_tl6)(_getnb q1)(_getnb q2)(>(distance q1 p)(distance q2 p)))((member tf'(37 165 5 133))(dm_tl8)(>(distance p(polar p0 a1 r1))(distance p(polar p0 a2 r1))))((member tf'(34 162 2 130))(dm_tl11)(setq r1(distance p0 q5))(>(distance p(polar p0 a1 r1))(distance p(polar p0 a2 r1))))))(setq tfdd($getcfg"bzhdk"nil)tfdo0 T lna'((0 . "DIMENSION")))(_chshx_ lna)(_drags_)(_zoomw_)(while(and tfdo0(progn(setq e(_hopendwg_ T"D"(strcat"\n请拾取要断开的尺寸标注[D－"(if tfdd"单尺寸多断开""多尺寸单断开")"] <退出>: ")lna))))(if(="D"e)(progn(setq tfdd(not tfdd))(setcfg(strcat app_data"bzhdk")(if tfdd"T""nil")))(progn(setq p3(last e)e(car e)le(list e)tfzf(getzf e p3))(while(and tfdo0(getpnt))(setq tfdo0(not tfdd))(foreach e le(if(and(not tfdo)(setq tfdo(bzhdk0 e q0 p3 d1)))(setq le(if tfzf(cons(entlast)le)(append le(list(entlast)))))))(command".undo""m"))(dim_adj(append le le1))(foreach e le(redraw e 4))(setq le nil le1 nil tfdo0 tfdd))))(foreach e le(redraw e 4))(_wtor_)(_socas_))

 标注合并的lsp    (defun c:bzhhb(/ mkal hbdma mm mma mx ss e e70 c1 c2 q1 q2 q3 q4 q5 p0 a0 a1 a2 d d1 d2 r1 r2 r3 l l_ ll lfd ldm1 ldm2 ldm3 le tf tfzf tfhb tf2)(defun mkal(tf23 q1 q3 q4 q5 q6 / x)(setq c1(if tfzf 14 10)c2(if tfzf 13 15))(if(not tf23)(progn(if(<(distance p0 q3)(distance p0 q5))(setq x q3 q3 q5 q5 x c1(if tfzf 14 15)c2(if tfzf 13 10)))(if(<(distance p0 q4)(distance p0 q6))(setq x q4 q4 q6 q6 x c1(if tfzf 13 10)c2(if tfzf 14 15)))))(setq a0(angle p0 q1)a1(angle p0 q3)a2(angle p0 q4)r1(distance p0 q1)r2(distance p0(cutz(_midp_ 11))))(if(> a1 a2)(setq a2(+ a2 _2pi)))(if(> a1 a0)(setq a0(+ a0 _2pi)))(setq tfzf(> a2 a0 a1)a2(if(> a2 _2pi)(- a2 _2pi)a2))(if(not tfzf)(setq a0 a1 a1 a2 a2 a0))(setq l_(list p0 r1)ll(assoc1 l_ ldm2 mm)q3(if tfzf q3 q4)q5(if tfzf q5 q6)l(if(> a1 a2)(list(list a1 _2pi tfzf tf23 q3 q5 r2 e)(list 0 a2))(list(list a1 a2 tfzf tf23 q3 q5 r2 e)))ldm2(if ll(subst(append ll l)ll ldm2)(cons(cons l_ l)ldm2))))(defun hbdma(/ e rt r1 r2 a a1 p1 p2 q x tfzf tf23)(if le(progn(foreach e le(entdel e))(mapcar'set'(a1 x tfzf tf23 p1 p2 rt e)l)(_calsun2_ e)(setq a(- a2 a1)a(/(if(< a 0)(+ a _2pi)a)2)q(polar p0(+ a1 a)rt)r1(distance p0 p1)p1(polar p0 a2 r1))(if tf23(_keyon_ 11 q(if tfzf 13 14)p1)(progn(setq r2(distance p0 q2)p2(polar p0 a2 r2))(_keyon_ 11 q c1 p1 c2 p2))))))(princ"\n请选取要合并的尺寸标注 <退出>: ")(if(setq ss(ssget'((0 . "DIMENSION"))))(progn(setq mm(* 0.005(getvar"viewsize"))mma 1e-3 mx 1e5)(_drags_)(_zoomw_)(_drag_ ss 0)(while(setq e(_slb_slb_ 0))(dm_tl3)(cond((dm_tl4 tf)(dm_tl5 tf)(dm_tl6)(setq a1(mergang a1)ll(assoc1 a1 ldm1 mma)l(list q1 q2 q3 q4 e)ldm1(if ll(subst(append ll(list l))ll ldm1)(cons(list a1 l)ldm1))))((member tf'(37 165 5 133))(setq p0(cutz(_midp_ 15)))(mkal T q1 q3 q4 nil nil))((member tf'(34 162 2 130))(setq q2(cutz(_midp_ 15))q5(cutz(_midp_ 16))p0(inters q1 q2 q3 q4 nil))(mkal nil q5 q1 q3 q2 q4))))(foreach ll ldm1(setq a1(car ll)a2(+ a1 _pi2)l(cadr ll)q1(car l)q2(polar q1 a1 mx)q3(polar q1 a2 mx)lfd nil)(foreach l(cdr ll)(setq d(_fren_(car l)q1 q2)d1(_fren_(car l)q1 q3)d2(_fren_(cadr l)q1 q3)tfzf(< d1 d2)l(cons(if tfzf d1 d2)(cons(if tfzf d2 d1)(cons tfzf l)))l_(assoc1 d lfd mm)lfd(if l_(subst(append l_(list l))l_ lfd)(cons(list d l)lfd))))(foreach ll lfd(setq ll(apply'_modent_(cdr ll))tf2(= 2(length ll)))(while(setq l(car ll))(setq d(cadr l)tfhb nil)(while(and(setq ll(cdr ll)l_(car ll))(or(> d(-(car l_)mm))tf2))(setq d(cadr l_)tfhb T)(entdel(last l_)))(if tfhb(progn(_calsun2_(last l))(setq e70(_midp_ 70)d(- d(car l)))(apply'_keyon_(if(caddr l)(list 13(polar(nth 5 l)a1 d))(list 14(polar(nth 6 l)a1 d))))(if(= 128(logand 128 e70))(command".dim1""hom"(last l)"")))))))(foreach ll ldm2(setq l(car ll)p0(car l)ll(apply'_modent_(cdr ll))tf2(= 2(length ll)))(while(setq l(car ll))(setq a2(cadr l)le nil)(while(and(setq ll(cdr ll)l_(car ll))(or(> a2(-(car l_)mma))tf2))(setq a2(cadr l_)e(last l_)le(if(='ENAME(type e))(cons e le)le)))(if(equal(car l)0 mma)(cond((not ll)(princ"\n360度尺寸无法合并！"))((equal(cadr(last ll))_2pi mma)(setq ll(reverse ll)l(car ll))(while(and(setq ll(cdr ll)l_(car ll))(>(cadr l_)(-(car l)mm)))(setq e(last l)le(if(='ENAME(type e))(cons e le)le)l l_))(setq ll(reverse ll))(hbdma))(T(hbdma)))(hbdma))))(_wtor_)(_socas_))))

Timnis

找到另一个了。
;;;标注断开
(defun c:12 (/ ent ent1 pt0 pt1 pt2 ppp);;
(setvar "cmdecho" 0)
(command "undo" "be")
  (if (setq ent (car (entsel "\n 选择要断开的标注<退出>:")))
    (if (= (cdr (assoc 0 (entget ent))) "DIMENSION")
      (progn
         (redraw ent 3)(setq pt0 (getpoint "\n 点取断开点:"))(redraw ent 4)
         (if pt0 (progn
         (command "copy" ent "" '(1 1) "@")
         (setq ent1 (entlast))
         (setq pt1 (cdr (assoc 13 (entget ent)))  ;;原标注起止点
               pt2 (cdr (assoc 14 (entget ent))))
         (setq pt0 (inters pt0 (polar pt0 (+ (angle pt1 pt2) (/ pi 2)) 1.0) pt1 pt2 nil))
         (setq ppp (maxL pt1 pt2 pt0) pt0 (car ppp) pt1 (cadr ppp) pt2 (caddr ppp))
         (dmup 13 pt0 ent)(dmup 14 pt1 ent)(dmup 13 pt1 ent1)(dmup 14 pt2 ent1)
      )(princ " 未拾取断点，程序取消")))(princ "\n 无效的标注样式，程序取消"))
  )(command "undo" "e")(princ)
)
(defun maxL(p1 p2 p3 / pt A1 A2 A3)
(setq A1 (distance p1 p2)
       A2 (distance p2 p3)
       A3 (distance p1 p3))
(if (= A1 (max A1 A2 A3)) (setq pt p2 p2 p3 p3 pt))
(if (= A2 (max A1 A2 A3)) (setq pt p2 p2 p1 p1 pt))
(list p1 p2 p3))
(defun dmup(n pt en)(entmod (subst (cons n pt) (assoc n (entget en))(entget en))))

;;;标注合并
(defun c:21( / d13 d14 dxf dxfn e1 e2 n p13 p14 plst ss)
  (command "ucs" "w")
  (setvar "cmdecho" 0)
  (princ "\n选择标注尺寸...")
  (setq ss (ssget '((0 . "DIMENSION"))))
  (setq n -1 plst '())
  (repeat (sslength ss)
     (setq dxf (entget (ssname ss (setq n (1+ n)))))
     (setq d13 (cdr (assoc 13 dxf))
           d14 (cdr (assoc 14 dxf)))
     (setq plst (cons d13 (cons d14 plst)))
  )
  (setq plst (vl-sort plst (function (lambda (e1 e2) (< (car e1) (car e2))))))
  (setq plst (vl-sort plst (function (lambda (e1 e2) (< (cadr e1) (cadr e2))))))   
  (setq p13 (car plst) p14 (last plst))
  (setq dxfn (subst (cons 13 p13) (assoc 13 dxf) dxf)
        dxfn (subst (cons 14 p14) (assoc 14 dxfn) dxfn))
  (entmake dxfn)
  (command ".erase" ss "")
  (command "ucs" "p")
  (princ)
)

vlisp2012

多谢谢分享！！！

胖大海

Timnis 发表于 2012-2-15 14:06
找到另一个了。
;;;标注断开
(defun c:12 (/ ent ent1 pt0 pt1 pt2 ppp);;

标注合并有点问题，不好用

e2002

标注合并这种，个人以为没什么意义啊？直接删除不需要的，extend一下或者大不了全删了重新创建一个都不费力的。

fangmin723

1. (defun c:dimjoin(/ ang d13 d14 dxf dxfn ent getdxf hlst n p13 p14 ss vlst)
   
2.         (defun getdxf (e n) (cdr (assoc n e)))
   
3.   (setvar "cmdecho" 0)
   
4.         (command "UNDO" "be")
   
5.   (princ "\n选择标注尺寸...")
   
6.   (setq ss (ssget '((0 . "DIMENSION"))))
   
7.   (setq n -1 hlst '() vlst '())
   
8.         (while (setq ent (ssname ss (setq n (1+ n))))
   
9.                 (setq dxf (entget ent) ang (getdxf dxf 50) d13 (getdxf dxf 13) d14 (getdxf dxf 14))
   
10.                 (if (or (equal ang 0 1.0e-005) (equal ang (* pi 2) 1.0e-005))
    
11.                         (setq hlst (cons d13 (cons d14 hlst)))
    
12.                 )
    
13.                 (if (or (equal ang (* pi 1.5) 1.0e-005) (equal ang (* pi 0.5) 1.0e-005))
    
14.                         (setq vlst (cons d13 (cons d14 vlst)))
    
15.                 )
    
16.         )
    
17.         (if (> (length hlst) (length vlst))
    
18.                 (setq
    
19.                         hlst (vl-sort hlst (function (lambda (e1 e2) (< (car e1) (car e2)))))
    
20.                         p13 (car hlst) p14 (last hlst)
    
21.                 )
    
22.         )
    
23.         (if (> (length vlst) (length hlst))
    
24.                 (setq
    
25.                         vlst (vl-sort vlst (function (lambda (e1 e2) (< (cadr e1) (cadr e2)))))
    
26.                         p13 (car vlst) p14 (last vlst)
    
27.                 )
    
28.         )
    
29.   (setq dxfn (subst (cons 13 p13) (assoc 13 dxf) dxf)
    
30.                 dxfn (subst (cons 14 p14) (assoc 14 dxfn) dxfn))
    
31.   (entmake dxfn)
    
32.   (command ".erase" ss "")
    
33.   (command "UNDO" "e")
    
34.   (prin1)
    
35. )

(defun c:dimjoin(/ ang d13 d14 dxf dxfn ent getdxf hlst n p13 p14 ss vlst)<br />         (defun getdxf (e n) (cdr (assoc n e)))<br />   (setvar "cmdecho" 0)<br />         (command "UNDO" "be")<br />   (princ "\n选择标注尺寸...")<br />   (setq ss (ssget '((0 . "DIMENSION"))))<br />   (setq n -1 hlst '() vlst '())<br />         (while (setq ent (ssname ss (setq n (1+ n))))<br />                 (setq dxf (entget ent) ang (getdxf dxf 50) d13 (getdxf dxf 13) d14 (getdxf dxf 14))<br />                 (if (or (equal ang 0 1.0e-005) (equal ang (* pi 2) 1.0e-005))<br />                         (setq hlst (cons d13 (cons d14 hlst)))<br />                 )<br />                 (if (or (equal ang (* pi 1.5) 1.0e-005) (equal ang (* pi 0.5) 1.0e-005))<br />                         (setq vlst (cons d13 (cons d14 vlst)))<br />                 )<br />         )<br />         (if (> (length hlst) (length vlst))<br />                 (setq<br />                         hlst (vl-sort hlst (function (lambda (e1 e2) (< (car e1) (car e2)))))<br />                         p13 (car hlst) p14 (last hlst)<br />                 )<br />         )<br />         (if (> (length vlst) (length hlst))<br />                 (setq<br />                         vlst (vl-sort vlst (function (lambda (e1 e2) (< (cadr e1) (cadr e2)))))<br />                         p13 (car vlst) p14 (last vlst)<br />                 )<br />         )<br />   (setq dxfn (subst (cons 13 p13) (assoc 13 dxf) dxf)<br />                 dxfn (subst (cons 14 p14) (assoc 14 dxfn) dxfn))<br />   (entmake dxfn)<br />   (command ".erase" ss "")<br />   (command "UNDO" "e")<br />   (prin1)<br /> )

vladimirputin

非常棒的程序代码，谢谢楼主分享啊