有请langjs兄弟及198526 兄弟及路过滴高手了再改自动编号标注代码

flytoday

想将原有程序增加个条件：
象上图中这种双条属等长平行线的（两条相差1mm也算等长行不）。。想有个设置，可以两边都标，也可以只标注一边
设置条件是：提示，平行线宽度（输入设置值），标注一边，其它平行线标注两边。
还有就是当出现重线时（因为有些会清除不干净），相重的多根线只要标长滴那根。。。




标注位置能不能调成这个样子的啊。。。就是双平行线。。。。

附上测试图：


附上langjs 兄弟的代码：

原贴位置：http://bbs.mjtd.com/thread-93257-1-1.html

麻烦各位了谢谢。。。。。。。。。。。。。。。。。。

198526

2. (defun c:aA (/  b chra color db dm dmm ent file_id file_idx h h1 i j la ll n name pt pt0 pt0x pt0y pt1 pt1x pt1y pt2 pt2x pt2y pt3
   
3.                ptslist r ss txt vtxlst x XDGC XDGC1 XDKD XDKD1)
   
4.   (defun dimtext (pt1 pt2)
   
5.     (setq pt1x (car pt1)  pt1y (cadr pt1)  pt2x (car pt2)  pt2y (cadr pt2)  pt0x (/ (+ pt1x pt2x) 2)
   
6.           pt0y (/ (+ pt1y pt2y) 2)  pt0 (list pt0x pt0y) )
   
7.     (setq txt (rtos (distance pt1 pt2))          r (angle pt1 pt2)  pt (polar pt0 (+ r (/ pi 2)) ll)  b (assoc color a)
   
8.           db (list (caadr b) (cons (LIST txt (LIST PT0 PT1)) (cadadr b)))  dm (strcat (car db) (itoa (length (cadr db)))))
   
9.     (IF
   
10. (NOT(APPLY 'OR   
    
11. (mapcar  '(lambda (N)
    
12.     (AND (EQUAL (READ TXT) (READ(CAR N)) XDGC)(NOT(inters pt0 pt1 (CAADR N) (CADADR N) NIL))(<= (distance pt0 (CAADR N)) XDKD))
    
13.             )
    
14.          (CADADR B); (CADADR B)遍历表内比较(TXT (PT1 PT2))是否一样
    
15.          )
    
16.         )
    
17.      )
    
18. (PROGN   
    
19.     (setq a (subst  (list color db)  b  a ) )
    
20.     (maketext (strcat txt "(" dm ")") pt h r color la)
    
21.    )
    
22. )
    
23. 
    
24.   )
    
25.   (defun maketext (txt pt h r color la)
    
26.     (entmake (list '(0 . "TEXT") (cons 8 la) (cons 62 color) (cons 10 pt) (cons 40 h) (cons 1 txt) (cons 50 r) '(41 . 0.8) '
    
27.                    (72 . 1) (cons 11 pt) '(73 . 0) ) )
    
28.   )
    
29.   (setvar "cmdecho" 0)
    
30.   (vl-load-com)
    
31.   (if (setq h1 (getint "\n输入字高:<100>")) (setq h h1) (setq h 100) )
    
32.   (if (setq XDGC1 (getREAL "\n输入等长公差值:<1.>")) (setq XDGC XDGC1) (setq XDGC 1.) )
    
33.   (if (setq XDKD1 (getREAL "\n输入等长跨度值:<200.>")) (setq XDKD XDKD1) (setq XDKD 200.) )
    
34.   
    
35.   
    
36.   (setq ll (/ h 2) chra 65 a '())
    
37.   (setq ss (ssget '((0 . "LINE,LWPOLYLINE,POLYLINE"))))
    
38.   (repeat (setq i (sslength ss))
    
39.     (setq name (ssname ss (setq i (1- i)))  ent (entget name)  la (cdr (assoc 8 ent)))
    
40.    
    
41.     (if (not (assoc 62 ent))
    
42.       (setq color (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 ent)))))) ;获得随层的颜色
    
43.       (setq color (cdr (assoc 62 ent)))
    
44.     )
    
45.     (if (not (assoc color a)) (setq a (cons (list color (list (chr (+ chra (length a))) nil)) a)) )
    
46.     (if (= "LINE" (cdr (assoc 0 ent)))
    
47.       (progn(setq pt1 (cdr (assoc 10 ent)) pt2 (cdr (assoc 11 ent)))(dimtext pt1 pt2))
    
48.       (progn
    
49.         (if (= "LWPOLYLINE" (cdr (assoc 0 ent))) (setq n 2) (setq n 3))
    
50.         (setq vtxlst (vlax-safearray->list (vlax-variant-value (vlax-get-property (vlax-ename->vla-object name) 'coordinates))))
    
51.         (setq j 0   ptslist nil        )
    
52.         (repeat (/ (length vtxlst) n)
    
53.           (setq ptslist (append          ptslist
    
54.                           (list (list (nth j vtxlst) (nth (1+ j) vtxlst) (if (= n 3) (nth (+ 2 j) vtxlst)  0.0 )) )
    
55.                         ))
    
56.           (setq j (+ j n))
    
57.         )
    
58.         (setq pt1 nil  pt2 nil)
    
59.         (foreach x ptslist            ;遍历相邻两个点坐标
    
60.           (if (null pt1)(setq pt1 x pt3 x ) (setq pt2 x))
    
61.           (if pt2 (progn (dimtext pt1 pt2) (setq pt1 pt2)))
    
62.         )
    
63.         (if (= 1 (cdr (assoc 70 ent)))(dimtext pt2 pt3))
    
64.       )
    
65.     )
    
66.   )
    
67.   (setq file_idx (getfiled "指定输出文件路径" "" "xls" 1)
    
68.         file_id (open file_idx "w")
    
69.   )
    
70.   (write-line "颜色号码\t对应代码\t长度" file_id)
    
71.   (foreach b (reverse a)
    
72.     (setq dmm (strcat (itoa (car b)) "\t" (caadr b)) n 0 )
    
73.     (foreach x (reverse (cadadr b))
    
74.       (write-line (strcat dmm (itoa (setq n (1+ n))) "\t" (CAR x)) file_id)
    
75.     )
    
76.   )                                      
    
77.   (close file_id)
    
78.   (princ)
    
79. )

(defun c:aA (/  b chra color db dm dmm ent file_id file_idx h h1 i j la ll n name pt pt0 pt0x pt0y pt1 pt1x pt1y pt2 pt2x pt2y pt3<br />                ptslist r ss txt vtxlst x XDGC XDGC1 XDKD XDKD1)<br />   (defun dimtext (pt1 pt2)<br />     (setq pt1x (car pt1)  pt1y (cadr pt1)  pt2x (car pt2)  pt2y (cadr pt2)  pt0x (/ (+ pt1x pt2x) 2)<br />           pt0y (/ (+ pt1y pt2y) 2)  pt0 (list pt0x pt0y) )<br />     (setq txt (rtos (distance pt1 pt2))          r (angle pt1 pt2)  pt (polar pt0 (+ r (/ pi 2)) ll)  b (assoc color a)<br />           db (list (caadr b) (cons (LIST txt (LIST PT0 PT1)) (cadadr b)))  dm (strcat (car db) (itoa (length (cadr db)))))<br />     (IF<br /> (NOT(APPLY 'OR   <br /> (mapcar  '(lambda (N)<br />     (AND (EQUAL (READ TXT) (READ(CAR N)) XDGC)(NOT(inters pt0 pt1 (CAADR N) (CADADR N) NIL))(<= (distance pt0 (CAADR N)) XDKD))<br />             )<br />          (CADADR B); (CADADR B)遍历表内比较(TXT (PT1 PT2))是否一样<br />          )<br />         )<br />      )<br /> (PROGN   <br />     (setq a (subst  (list color db)  b  a ) )<br />     (maketext (strcat txt "(" dm ")") pt h r color la)<br />    )<br /> )<br /> <br />   )<br />   (defun maketext (txt pt h r color la)<br />     (entmake (list '(0 . "TEXT") (cons 8 la) (cons 62 color) (cons 10 pt) (cons 40 h) (cons 1 txt) (cons 50 r) '(41 . 0.8) '<br />                    (72 . 1) (cons 11 pt) '(73 . 0) ) )<br />   )<br />   (setvar "cmdecho" 0)<br />   (vl-load-com)<br />   (if (setq h1 (getint "\n输入字高:<100>")) (setq h h1) (setq h 100) )<br />   (if (setq XDGC1 (getREAL "\n输入等长公差值:<1.>")) (setq XDGC XDGC1) (setq XDGC 1.) )<br />   (if (setq XDKD1 (getREAL "\n输入等长跨度值:<200.>")) (setq XDKD XDKD1) (setq XDKD 200.) )<br />   <br />   <br />   (setq ll (/ h 2) chra 65 a '())<br />   (setq ss (ssget '((0 . "LINE,LWPOLYLINE,POLYLINE"))))<br />   (repeat (setq i (sslength ss))<br />     (setq name (ssname ss (setq i (1- i)))  ent (entget name)  la (cdr (assoc 8 ent)))<br />     <br />     (if (not (assoc 62 ent))<br />       (setq color (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 ent)))))) ;获得随层的颜色<br />       (setq color (cdr (assoc 62 ent)))<br />     )<br />     (if (not (assoc color a)) (setq a (cons (list color (list (chr (+ chra (length a))) nil)) a)) )<br />     (if (= "LINE" (cdr (assoc 0 ent)))<br />       (progn(setq pt1 (cdr (assoc 10 ent)) pt2 (cdr (assoc 11 ent)))(dimtext pt1 pt2))<br />       (progn<br />         (if (= "LWPOLYLINE" (cdr (assoc 0 ent))) (setq n 2) (setq n 3))<br />         (setq vtxlst (vlax-safearray->list (vlax-variant-value (vlax-get-property (vlax-ename->vla-object name) 'coordinates))))<br />         (setq j 0   ptslist nil        )<br />         (repeat (/ (length vtxlst) n)<br />           (setq ptslist (append          ptslist<br />                           (list (list (nth j vtxlst) (nth (1+ j) vtxlst) (if (= n 3) (nth (+ 2 j) vtxlst)  0.0 )) )<br />                         ))<br />           (setq j (+ j n))<br />         )<br />         (setq pt1 nil  pt2 nil)<br />         (foreach x ptslist            ;遍历相邻两个点坐标<br />           (if (null pt1)(setq pt1 x pt3 x ) (setq pt2 x))<br />           (if pt2 (progn (dimtext pt1 pt2) (setq pt1 pt2)))<br />         )<br />         (if (= 1 (cdr (assoc 70 ent)))(dimtext pt2 pt3))<br />       )<br />     )<br />   )<br />   (setq file_idx (getfiled "指定输出文件路径" "" "xls" 1)<br />         file_id (open file_idx "w")<br />   )<br />   (write-line "颜色号码\t对应代码\t长度" file_id)<br />   (foreach b (reverse a)<br />     (setq dmm (strcat (itoa (car b)) "\t" (caadr b)) n 0 )<br />     (foreach x (reverse (cadadr b))<br />       (write-line (strcat dmm (itoa (setq n (1+ n))) "\t" (CAR x)) file_id)<br />     )<br />   )                                      <br />   (close file_id)<br />   (princ)<br /> )

看看这个满意了没？

flytoday

相信这个修改完美后的源码做为明经出书的源码是非常适用滴
这个可用于建筑造价工程预结算使用：
1、用于建筑水电工程管道长度标注计算（特别适用于要求要有计算式的要求）
2、适用于建筑工程预结算核对梁长，内墙装饰长度等。。。。
希望。。。哪位高手帮帮忙，。，也算为明经出书做贡献
谢谢啦。///

langjs

受不了你了，
你又来了？
怕了你了！

198526 兄弟对表研究的很透，多复杂的表都能搞定，恭喜你找对人了，我闪……

flytoday

哈哈谢谢你

flytoday

求滴代码都是完美滴哈..都能入明经出书源码哈

xyp1964

flytoday

哇院长好早……院长啥时候提供一两个真源啊……院长这种做到选择时只选到平行线中一条很强大…不知道是不是…能做到设置平行线距离大小，来判断要选中一条还是两条

flytoday

xyp1964 发表于 2012-4-27 06:37

院长你这个不同的线咋编号是相同的啊

flytoday

flytoday 发表于 2012-4-27 09:02
院长你这个不同的线咋编号是相同的啊

哦这个不是我想要的。。。我想依据线进行编号。只是说等长的平行线只要标注一根而已。。

还有我不想要穿内裤滴码呵呵。。我想改源码哈