愿意花100明经币求写代码

flytoday

最好有对话框滴啊



参考自动标注插件功能

198526

2. (defun c:aa (/ color ent h i ll la layer layers name pt pt0 pt0x pt0y pt1 pt1x pt1y pt2 pt2x pt2y r ss txt  DM DB file_idX file_id dmm)
   
3.   (defun maketext (txt pt h r color la)
   
4.     (entmake (list '(0 . "TEXT") (cons 8 la) (cons 62 color) ; 颜色
   
5.      (cons 10 pt)        ; 坐标
   
6.      (cons 40 h)        ; 高度
   
7.      (cons 1 txt)        ; 内容
   
8.      (cons 50 r)        ; 旋转
   
9.      '(41 . 0.8) '(72 . 1) (cons 11 pt) ; 坐标
   
10.      '(73 . 0)
    
11.       )
    
12.     )
    
13.   )
    
14.   (setq h 100)          ; 字体高度
    
15.   (setq ll 50)          ; 距离直线
    
16.   (SETQ CHRA 65)
    
17.   (SETQ A '())  
    
18.   (setq ss (ssget '((0 . "LINE,POLYLINE"))));暂不支持PL线
    
19.   (repeat (setq i (sslength ss))
    
20.     (setq name (ssname ss (setq i (1- i))))
    
21.     (setq ent (entget name))
    
22.     (setq color (vla-get-color (vlax-ename->vla-object name)))
    
23.     (setq la (cdr (assoc 8 ent)))
    
24.     (IF (NOT(ASSOC COLOR A))
    
25.       (sETQ A (CONS (LIST COLOR (LIST (CHR (+ CHRA (LENGTH A))) NIL)) A )  )
    
26.       )
    
27.     (SETQ B (ASSOC COLOR A))
    
28.     (IF (= "LINE" (cdr (assoc 0 ent)))
    
29.       (PROGN
    
30.     (setq pt1 (cdr (assoc 10 ent)))
    
31.     (setq pt2 (cdr (assoc 11 ent)))
    
32.     (setq pt1x (car pt1))
    
33.     (setq pt1y (cadr pt1))
    
34.     (setq pt2x (car pt2))
    
35.     (setq pt2y (cadr pt2))
    
36.     (setq pt0x (/ (+ pt1x pt2x) 2))
    
37.     (setq pt0y (/ (+ pt1y pt2y) 2))
    
38.     (setq pt0 (list pt0x pt0y))
    
39.     (setq txt (rtos (distance pt1 pt2)))
    
40.     (setq r (angle pt1 pt2))
    
41.     (setq pt (polar pt0 (+ r (/ pi 2)) ll))
    
42.     (SETQ DB (LIST (CAADR B) (CONS TXT (CADADR B))))
    
43.     (SETQ DM (STRCAT (CAR DB) (ITOA (LENGTH (CADR DB)))))
    
44.     (sETQ A (SUBST
    
45.               (LIST COLOR DB)
    
46.               B
    
47.               A
    
48.               )
    
49.           )
    
50.     (maketext (STRCAT txt "(" DM ")") pt h r color la)
    
51.     )
    
52.       )
    
53.       
    
54.   )
    
55. 
    
56. 
    
57.   (setq  file_idX (getfiled "指定输出文件路径" "" "xls" 1)
    
58.          file_id (OPen file_idX "w")
    
59.          )
    
60.   (write-line "颜色号码\t对应代码\t长度" file_id)
    
61.   (foreach b (REVERSE A)
    
62.     (setq dmm (STRCAT (ITOA (CAR b)) "\t" (CAADR B))
    
63.           n 0)
    
64.     (foreach x (REVERSE (CADADR B))
    
65.                      (write-line (STRCAT dmm (ITOA (setq n (1+ n))) "\t"  x) file_id)  )
    
66.     )
    
67. ;根据langjs 大师的程序加了一些，更接近楼主想要了，不过PL线的还没写，楼主可以尝试自己写一下。
    
68. 
    
69.   (close file_id)
    
70.   
    
71.   (princ)
    
72. )

(defun c:aa (/ color ent h i ll la layer layers name pt pt0 pt0x pt0y pt1 pt1x pt1y pt2 pt2x pt2y r ss txt  DM DB file_idX file_id dmm)<br />   (defun maketext (txt pt h r color la)<br />     (entmake (list '(0 . "TEXT") (cons 8 la) (cons 62 color) ; 颜色<br />      (cons 10 pt)        ; 坐标<br />      (cons 40 h)        ; 高度<br />      (cons 1 txt)        ; 内容<br />      (cons 50 r)        ; 旋转<br />      '(41 . 0.8) '(72 . 1) (cons 11 pt) ; 坐标<br />      '(73 . 0)<br />       )<br />     )<br />   )<br />   (setq h 100)          ; 字体高度<br />   (setq ll 50)          ; 距离直线<br />   (SETQ CHRA 65)<br />   (SETQ A '())  <br />   (setq ss (ssget '((0 . "LINE,POLYLINE"))));暂不支持PL线<br />   (repeat (setq i (sslength ss))<br />     (setq name (ssname ss (setq i (1- i))))<br />     (setq ent (entget name))<br />     (setq color (vla-get-color (vlax-ename->vla-object name)))<br />     (setq la (cdr (assoc 8 ent)))<br />     (IF (NOT(ASSOC COLOR A))<br />       (sETQ A (CONS (LIST COLOR (LIST (CHR (+ CHRA (LENGTH A))) NIL)) A )  )<br />       )<br />     (SETQ B (ASSOC COLOR A))<br />     (IF (= "LINE" (cdr (assoc 0 ent)))<br />       (PROGN<br />     (setq pt1 (cdr (assoc 10 ent)))<br />     (setq pt2 (cdr (assoc 11 ent)))<br />     (setq pt1x (car pt1))<br />     (setq pt1y (cadr pt1))<br />     (setq pt2x (car pt2))<br />     (setq pt2y (cadr pt2))<br />     (setq pt0x (/ (+ pt1x pt2x) 2))<br />     (setq pt0y (/ (+ pt1y pt2y) 2))<br />     (setq pt0 (list pt0x pt0y))<br />     (setq txt (rtos (distance pt1 pt2)))<br />     (setq r (angle pt1 pt2))<br />     (setq pt (polar pt0 (+ r (/ pi 2)) ll))<br />     (SETQ DB (LIST (CAADR B) (CONS TXT (CADADR B))))<br />     (SETQ DM (STRCAT (CAR DB) (ITOA (LENGTH (CADR DB)))))<br />     (sETQ A (SUBST<br />               (LIST COLOR DB)<br />               B<br />               A<br />               )<br />           )<br />     (maketext (STRCAT txt "(" DM ")") pt h r color la)<br />     )<br />       )<br />       <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))<br />           n 0)<br />     (foreach x (REVERSE (CADADR B))<br />                      (write-line (STRCAT dmm (ITOA (setq n (1+ n))) "\t"  x) file_id)  )<br />     )<br /> ;根据langjs 大师的程序加了一些，更接近楼主想要了，不过PL线的还没写，楼主可以尝试自己写一下。<br /> <br />   (close file_id)<br />   <br />   (princ)<br /> )

wwwbxd

楼主在线吗

flytoday

在啊

tm20038175

100币只是传说，愿者上钩！…

flytoday

弄好我会付了。。郁闷。。。。

flytoday

对话框不懂要长成啥样子滴。。。

但是最终效果是。。能不同颜色的线实现自动标注。。。并进行编号。。最后生成EXL。。这个线可以是PL线。L线。。。。标注能设置字高

flytoday

谁帮我弄下啊。。啊。。。

flytoday

沉滴这么快

dz-2011

要多支持明经交易版块!