标注断开 和标注合并都 可以用,只是不能先选择再执行,请教明经ER帮忙一下,万分感谢

hooboxu

;;========================================
;; 标注断开+连续标注程序
;; by  明经通道  QQ: 9034598 2009年8月15日
;;========================================
(vl-load-com)
(defun c:ddr (/ n x ent entL p2 p3 px1 px2 py1 py2 ptdd xl sa pt0 ppt ptdd)
(setvar "cmdecho" 0)
(command "undo" "be")
(setq entL '())
(if (setq ent (centsel "\n选择标注 或 <退出>:" "DIMENSION"))
   (progn
     (setq x (entget ent)
        entL (cons ent entL)
          p2 (dxf 13 x)
          p3 (dxf 14 x)
          px1 (list (car p2) (/ (+ (cadr p2)(cadr p3)) 2.0))
          px2 (list (car p3) (/ (+ (cadr p2)(cadr p3)) 2.0))
          py1 (list (/ (+ (car p2)(car p3)) 2.0) (cadr p2))
          py2 (list (/ (+ (car p2)(car p3)) 2.0) (cadr p3))
          ptdd (list p2 p3)
          XL (entget (dxf -2 (tblsearch "block" (dxf 2 x))))
          SA (abs (sin (angle (dxf 10 xl) (dxf 11 xl)))))
   (while (setq pt0 (getpoint "\n取点 或 <退出>:"))
       (command ".copy" ent "" "0,0" "@")
       (setq entL (cons (entlast) entL))
    (cond
      ((equal SA 1 1e-6) ;;水平
         (setq ptdd (cons (ptper pt0 px1 px2) ptdd)
                 ppt (Lsort ptdd 0))
        )
      ((equal SA 0 1e-6) ;;垂直
         (setq ptdd (cons (ptper pt0 py1 py2) ptdd)
                ppt (Lsort ptdd 1))
       )
       (t (setq ptdd (cons (ptper pt0 p2 p3) ptdd)
            ppt (Lsort ptdd 2)))
      )
       (setq ppL (mapcar 'list ppt (cdr ppt))
              n 0)
         (repeat (length ppL)
           (setq xf (entget (nth n entL))
                nxf (subst (cons 13 (car  (nth n ppL)))(assoc 13 xf) xf)
                wxf (subst (cons 14 (cadr (nth n ppL)))(assoc 14 nxf) nxf)
                n (1+ n))
           (entmod wxf)
         )
     ))
  (princ "\n退出")
)
  (command "undo" "e") (setvar "cmdecho" 1)
  (princ)
)

(defun centsel (msg f)
(while (if (setq el (car (entsel msg))) (if (= (cdr (assoc 0 (entget el))) f) nil t) nil)) el
)
;;取值dxf
(defun dxf (x e)(cdr (assoc x e)))
;;求垂足
(defun ptper (pt0 pt1 pt2)
(inters pt0 (polar pt0 (+ (angle pt1 pt2) (/ pi 2)) 1.0) pt1 pt2 nil)
)
;;排序 0 水平 1 垂直 2 倾斜
(defun Lsort (LT i)
(cond
((or (= i 0)(= i 2))(setq Lt (vl-sort LT (function (lambda (e1 e2)(< (car e1) (car e2)))))))
((or (= i 1)(= i 2))(setq Lt (vl-sort LT (function (lambda (e1 e2)(< (cadr e1) (cadr e2)))))))
))

(princ)



;;标注合并
(defun c:ddc( / 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)
)



标注断开 和标注合并都 可以用,只是不能先选择再执行,请教明经ER帮忙一下,万分感谢

vectra

主要修改了centsel函数，可以先选择了

1. (vl-load-com)
   
2. (defun c:ddr (/ n x ent entl p2 p3 px1 px2 py1 py2 ptdd xl sa pt0 ppt ptdd)
   
3.   (setvar "cmdecho" 0)
   
4.   (if (setq ent (centsel "\n选择标注 或 <退出>:" "DIMENSION"))
   
5.     (progn
   
6.       (setq x         (entget ent)
   
7.             entl (cons ent entl)
   
8.             p2         (dxf 13 x)
   
9.             p3         (dxf 14 x)
   
10.             px1         (list (car p2) (/ (+ (cadr p2) (cadr p3)) 2.0))
    
11.             px2         (list (car p3) (/ (+ (cadr p2) (cadr p3)) 2.0))
    
12.             py1         (list (/ (+ (car p2) (car p3)) 2.0) (cadr p2))
    
13.             py2         (list (/ (+ (car p2) (car p3)) 2.0) (cadr p3))
    
14.             ptdd (list p2 p3)
    
15.             xl         (entget (dxf -2 (tblsearch "block" (dxf 2 x))))
    
16.             sa         (abs (sin (angle (dxf 10 xl) (dxf 11 xl))))
    
17.       )
    
18.       (while (setq pt0 (getpoint "\n取点 或 <退出>:"))
    
19.         (command "undo" "be")
    
20. 
    
21.         (command ".copy" ent "" "0,0" "@")
    
22.         (setq entl (cons (entlast) entl))
    
23.         (cond
    
24.           ((equal sa 1 1e-6)
    
25.            ;;水平
    
26.            (setq ptdd (cons (ptper pt0 px1 px2) ptdd)
    
27.                  ppt  (lsort ptdd 0)
    
28.            )
    
29.           )
    
30.           ((equal sa 0 1e-6)
    
31.            ;;垂直
    
32.            (setq ptdd (cons (ptper pt0 py1 py2) ptdd)
    
33.                  ppt  (lsort ptdd 1)
    
34.            )
    
35.           )
    
36.           (t
    
37.            (setq ptdd (cons (ptper pt0 p2 p3) ptdd)
    
38.                  ppt  (lsort ptdd 2)
    
39.            )
    
40.           )
    
41.         )
    
42.         (setq ppl (mapcar 'list ppt (cdr ppt))
    
43.               n          0
    
44.         )
    
45.         (repeat        (length ppl)
    
46.           (setq        xf  (entget (nth n entl))
    
47.                 nxf (subst (cons 13 (car (nth n ppl))) (assoc 13 xf) xf)
    
48.                 wxf (subst (cons 14 (cadr (nth n ppl))) (assoc 14 nxf) nxf)
    
49.                 n   (1+ n)
    
50.           )
    
51.           (entmod wxf)
    
52.         )
    
53. 
    
54.         (command "undo" "e")
    
55.       )
    
56.     )
    
57.     (princ "\n退出")
    
58.   )
    
59. 
    
60.   (setvar "cmdecho" 1)
    
61.   (princ)
    
62. )
    
63. 
    
64. (defun centsel (msg f / ent ss)
    
65.   (princ msg)
    
66.   (while (null ent)
    
67.     (setq ss (ssget  (list (cons 0 f))))
    
68.     (if        ss
    
69.       (setq ent (ssname ss 0))
    
70.     )
    
71.   )
    
72.   (redraw ent 3)
    
73.   ent
    
74. )
    
75. ;;取值dxf
    
76. (defun dxf (x e) (cdr (assoc x e)))
    
77. ;;求垂足
    
78. (defun ptper (pt0 pt1 pt2)
    
79.   (inters pt0 (polar pt0 (+ (angle pt1 pt2) (/ pi 2)) 1.0) pt1 pt2 nil)
    
80. )
    
81. ;;排序 0 水平 1 垂直 2 倾斜
    
82. (defun lsort (lt i)
    
83.   (cond
    
84.     ((or (= i 0) (= i 2)) (setq lt (vl-sort lt (function (lambda (e1 e2) (< (car e1) (car e2)))))))
    
85.     ((or (= i 1) (= i 2))
    
86.      (setq lt (vl-sort lt (function (lambda (e1 e2) (< (cadr e1) (cadr e2))))))
    
87.     )
    
88.   )
    
89. )
    
90. 
    
91. (princ)

(vl-load-com)<br /> (defun c:ddr (/ n x ent entl p2 p3 px1 px2 py1 py2 ptdd xl sa pt0 ppt ptdd)<br />   (setvar "cmdecho" 0)<br />   (if (setq ent (centsel "\n选择标注 或 <退出>:" "DIMENSION"))<br />     (progn<br />       (setq x         (entget ent)<br />             entl (cons ent entl)<br />             p2         (dxf 13 x)<br />             p3         (dxf 14 x)<br />             px1         (list (car p2) (/ (+ (cadr p2) (cadr p3)) 2.0))<br />             px2         (list (car p3) (/ (+ (cadr p2) (cadr p3)) 2.0))<br />             py1         (list (/ (+ (car p2) (car p3)) 2.0) (cadr p2))<br />             py2         (list (/ (+ (car p2) (car p3)) 2.0) (cadr p3))<br />             ptdd (list p2 p3)<br />             xl         (entget (dxf -2 (tblsearch "block" (dxf 2 x))))<br />             sa         (abs (sin (angle (dxf 10 xl) (dxf 11 xl))))<br />       )<br />       (while (setq pt0 (getpoint "\n取点 或 <退出>:"))<br />         (command "undo" "be")<br /> <br />         (command ".copy" ent "" "0,0" "@")<br />         (setq entl (cons (entlast) entl))<br />         (cond<br />           ((equal sa 1 1e-6)<br />            ;;水平<br />            (setq ptdd (cons (ptper pt0 px1 px2) ptdd)<br />                  ppt  (lsort ptdd 0)<br />            )<br />           )<br />           ((equal sa 0 1e-6)<br />            ;;垂直<br />            (setq ptdd (cons (ptper pt0 py1 py2) ptdd)<br />                  ppt  (lsort ptdd 1)<br />            )<br />           )<br />           (t<br />            (setq ptdd (cons (ptper pt0 p2 p3) ptdd)<br />                  ppt  (lsort ptdd 2)<br />            )<br />           )<br />         )<br />         (setq ppl (mapcar 'list ppt (cdr ppt))<br />               n          0<br />         )<br />         (repeat        (length ppl)<br />           (setq        xf  (entget (nth n entl))<br />                 nxf (subst (cons 13 (car (nth n ppl))) (assoc 13 xf) xf)<br />                 wxf (subst (cons 14 (cadr (nth n ppl))) (assoc 14 nxf) nxf)<br />                 n   (1+ n)<br />           )<br />           (entmod wxf)<br />         )<br /> <br />         (command "undo" "e")<br />       )<br />     )<br />     (princ "\n退出")<br />   )<br /> <br />   (setvar "cmdecho" 1)<br />   (princ)<br /> )<br /> <br /> (defun centsel (msg f / ent ss)<br />   (princ msg)<br />   (while (null ent)<br />     (setq ss (ssget  (list (cons 0 f))))<br />     (if        ss<br />       (setq ent (ssname ss 0))<br />     )<br />   )<br />   (redraw ent 3)<br />   ent<br /> )<br /> ;;取值dxf<br /> (defun dxf (x e) (cdr (assoc x e)))<br /> ;;求垂足<br /> (defun ptper (pt0 pt1 pt2)<br />   (inters pt0 (polar pt0 (+ (angle pt1 pt2) (/ pi 2)) 1.0) pt1 pt2 nil)<br /> )<br /> ;;排序 0 水平 1 垂直 2 倾斜<br /> (defun lsort (lt i)<br />   (cond<br />     ((or (= i 0) (= i 2)) (setq lt (vl-sort lt (function (lambda (e1 e2) (< (car e1) (car e2)))))))<br />     ((or (= i 1) (= i 2))<br />      (setq lt (vl-sort lt (function (lambda (e1 e2) (< (cadr e1) (cadr e2))))))<br />     )<br />   )<br /> )<br /> <br /> (princ)

vectra

合并只要把ucs的那行去掉就可以了，断开因为是使用entsel的，也没法改先选后执行。

1. (defun c:ddc (/ d13 d14 dxf dxfn e1 e2 n p13 p14 plst ss)
   
2.   (setvar "cmdecho" 0)
   
3.   (princ "\n选择标注尺寸...")
   
4.   (setq ss (ssget '((0 . "DIMENSION"))))
   
5.   (setq n -1)
   
6.   (repeat (sslength ss)
   
7.     (setq dxf (entget (ssname ss (setq n (1+ n)))))
   
8.     (setq d13 (cdr (assoc 13 dxf))
   
9.           d14 (cdr (assoc 14 dxf))
   
10.     )
    
11.     (setq plst (cons d13 (cons d14 plst)))
    
12.   )
    
13.   (setq        plst (vl-sort plst
    
14.                       (function (lambda (e1 e2) (< (car e1) (car e2))))
    
15.              )
    
16.         plst (vl-sort plst
    
17.                       (function (lambda (e1 e2) (< (cadr e1) (cadr e2))))
    
18.              )
    
19. 
    
20.         p13  (car plst)
    
21.         p14  (last plst)
    
22. 
    
23.         dxfn (subst (cons 13 p13) (assoc 13 dxf) dxf)
    
24.         dxfn (subst (cons 14 p14) (assoc 14 dxfn) dxfn)
    
25.   )
    
26.   
    
27.   (command "undo" "be")
    
28.   
    
29.   (entmake dxfn)
    
30.   (command ".erase" ss "")
    
31.   
    
32.   (command "undo" "e")
    
33.   (setvar "cmdecho" 1)
    
34.   (princ)
    
35. )
    

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

hooboxu

谢谢楼上的,本人一点也不懂LSP,所以...
还有个一断开有大神帮忙解决一下么?

hooboxu

这分不足以表示我对你的感谢,对你的热心鼓掌10分钟,真心感谢~

hadessna

谢谢分享
~~~~

趣意人生

谢谢分享!!!

qazxswk

vectra 发表于 2014-10-25 11:12
主要修改了centsel函数，可以先选择了

不错不错，这是我想要的效果。

13763815647

高手，受教了