路基水泥搅拌桩（CLRCLE）坐标导出并编号 ，73哥函数

树櫴希德

路基水泥搅拌桩（CLRCLE）坐标导出并编号 ，73哥函数

2. (defun makepl(argments);;argments==>(list pts 闭合标志 全局宽度 线宽 图层 颜色 厚度 线型)pts以后可省略
   
3.   (entmakex(append(mapcar'cons'(0 100 100 43 370 8 62 39 6)(append'("LWPOLYLINE""AcDbEntity""AcDbPolyline")(cddr argments)))
   
4.       (cons(cons 90(length(car argments)))
   
5.            (cons(cons 70(if(cadr argments)(cadr argments)0))(mapcar'(lambda(x)(cons 10 x))(car argments)))))))
   
6. (defun poinpl(p pt);;:点是否在指定点表内
   
7.   (equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8))
   
8. (defun plinexy(e)
   
9.   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))
   
10.   )
    
11. (defun SsgetW(arg / a);;选择指定矩形区域内(不限屏幕范围)
    
12.   (ssget"X"(apply'append(list'((-4 . "<and")(-4 . ">=,>="))
    
13.            (setq a(list(car arg)(cadr arg))
    
14.            a(mapcar'(lambda(x)(mapcar x a))'(car cadr))
    
15.            a(mapcar'(lambda(y)(cons 10(mapcar'(lambda(x)(apply y x))a)))'(min max))
    
16.            a(list(car a)'(-4 . "<=,<=")(cadr a)))
    
17.            (cddr arg)
    
18.            '((-4 . "and>")))))
    
19.   )
    
20. (defun SsgetCP(arg / a i pt s b);;根据多线段图元名或者其坐标点表进行(ssget"CP"...)但不限屏幕范围
    
21.   (if(listp(setq a(car arg)))
    
22.     (setq pt a a(vlax-ename->vla-object(makepl(list pt))))
    
23.     (setq pt(plinexy a)a(vlax-ename->vla-object a)))
    
24.   (if(setq i -1
    
25.      s(SsgetW(append(mapcar'(lambda(x)(mapcar'(lambda(y)(apply x y))
    
26.           (mapcar'(lambda(x)(mapcar x pt))'(car cadr))))'(min max))(cdr arg)))
    
27.      s(if(SSMEMB(vlax-vla-object->ename a)s)(ssdel(vlax-vla-object->ename a)s)s))
    
28.     (repeat(sslength s)
    
29.       (setq i(1+ i)e(ssname s i))
    
30.       (if(not(or(>(vlax-safearray-get-u-bound(vlax-variant-value(vla-intersectwith(vlax-ename->vla-object e)a 0))1)1)
    
31.     (poinpl(cdr(assoc 10(entget e)))pt)))
    
32.   (setq b(cons e b)))))
    
33.   (if(listp(car arg))(vla-Delete a))
    
34.   (foreach a b(setq s(ssdel a s)))s)
    
35. (defun SsgetWP(arg / a i pt s b);;根据多线段图元名或者其坐标点表进行(ssget"WP"...)但不限屏幕范围
    
36.   (if(listp(setq a(car arg)))
    
37.     (setq pt a a(vlax-ename->vla-object(makepl(list pt))))
    
38.     (setq pt(plinexy a)a(vlax-ename->vla-object a)))
    
39.   (if(setq i -1
    
40.      s(SsgetW(append(mapcar'(lambda(x)(mapcar'(lambda(y)(apply x y))
    
41.           (mapcar'(lambda(x)(mapcar x pt))'(car cadr))))'(min max))(cdr arg)))
    
42.      s(if(SSMEMB(vlax-vla-object->ename a)s)(ssdel(vlax-vla-object->ename a)s)s))
    
43.     (repeat(sslength s)
    
44.       (setq i(1+ i)e(ssname s i))
    
45.       (if(or(>(vlax-safearray-get-u-bound(vlax-variant-value(vla-intersectwith(vlax-ename->vla-object e)a 0))1)1)
    
46.      (not(poinpl(cdr(assoc 10(entget e)))pt)))
    
47.   (setq b(cons e b)))))
    
48.   (if(listp(car arg))(vla-Delete a))
    
49.   (foreach a b(setq s(ssdel a s)))s)
    
50. 
    
51. 
    
52. 
    
53. ;;;
    
54. (defun maketext (zb gd /  cld )
    
55.   (setq cld (polar zb (* 0.25 pi) (* 2 gd) ))
    
56. (entmake (list
    
57. '(0 . "LINE")
    
58. '(67 . 0)
    
59. '(8 . "0")
    
60. (list 10 (car zb) (cadr zb) 0)
    
61. (cons 11 cld )
    
62. '(210 0.0 0.0 1.0)
    
63. )
    
64. )
    
65. ;;;
    
66. (entmake (list
    
67. '(0 . "LINE")
    
68. '(67 . 0)
    
69. '(8 . "0")
    
70. (cons 10 cld)
    
71. (cons 11 ( polar cld 0 (* 10 gd)) )
    
72. '(210 0.0 0.0 1.0)
    
73. )
    
74. )
    
75. ;;;;
    
76. (entmake (list
    
77. '(0 . "text")
    
78. (list 10 (+ (car cld) gd) (car(cdr cld)) )
    
79. (cons 40 gd)
    
80. (cons 1 ( strcat "X=" (rtos (cadr zb) 2 3)))
    
81. '(50 . 0)
    
82. )
    
83. )
    
84. (entmake (list
    
85. '(0 . "text")
    
86. (list 10 (+ (car cld) gd)
    
87. (- (car(cdr cld)) (+ gd (/ gd 3)) )
    
88. )
    
89. (cons 40 gd)
    
90. (cons 1 (strcat "Y="(rtos (car zb) 2 3)))
    
91. '(50 . 0)
    
92. )
    
93. )
    
94. (princ)
    
95. )
    
96. ;
    
97. (defun maketext1 (zb gd /  cld )
    
98.   (setq cld (polar zb (* 0.25 pi) (* 2 gd) ))
    
99. (entmake (list
    
100. '(0 . "LINE")
     
101. '(67 . 0)
     
102. '(8 . "0")
     
103. (list 10 (car zb) (cadr zb) 0)
     
104. (cons 11 cld )
     
105. '(210 0.0 0.0 1.0)
     
106. )
     
107. )
     
108. ;;;
     
109. (entmake (list
     
110. '(0 . "LINE")
     
111. '(67 . 0)
     
112. '(8 . "0")
     
113. (cons 10 cld)
     
114. (cons 11 ( polar cld 0 (* 10 gd)) )
     
115. '(210 0.0 0.0 1.0)
     
116. )
     
117. )
     
118. ;;;;
     
119. (entmake (list
     
120. '(0 . "text")
     
121. (list 10 (+ (car cld) gd) (car(cdr cld)) )
     
122. (cons 40 gd)
     
123. (cons 1 ( strcat "X=" (rtos (/ (cadr zb) 1000) 2 3)))
     
124. '(50 . 0)
     
125. )
     
126. )
     
127. (entmake (list
     
128. '(0 . "text")
     
129. (list 10 (+ (car cld) gd)
     
130. (- (car(cdr cld)) (+ gd (/ gd 3)) )
     
131. )
     
132. (cons 40 gd)
     
133. (cons 1 (strcat "Y="(rtos (/ (car zb) 1000) 2 3)))
     
134. '(50 . 0)
     
135. )
     
136. )
     
137. (princ)
     
138. )
     
139. 
     
140. ;货物分两组（样品 库存）
     
141. (defun lst->2lst(lst / lst1 lst2)
     
142.   (setq lst1 '() lst2 '())
     
143. (foreach a lst
     
144.     (if (member a lst2)
     
145.       (setq lst1 (cons a lst1))
     
146.       (setq lst2 (cons a lst2))
     
147.     )
     
148.   )
     
149. (cons (reverse lst2) (reverse lst1))
     
150. )
     
151. 
     
152. 
     
153. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
154. (defun c:gczbh1 (/ p qianzhui blc zg ss i lstt e kkkk ptlst ff sjzb xx ee zhuobiao lst )
     
155. 
     
156. (setq blc (getint "\n请输入比例尺1:"))
     
157.   (setvar 'userr1 blc);设置比例尺
     
158. (setq zg(* 0.002 blc));字高
     
159. (setq ss (SsgetWP (list(car (entsel))'(0 . "circle") )) )
     
160.   (setq i 0)
     
161.   (setq lst '())
     
162.   
     
163.   
     
164. (repeat (sslength ss)
     
165.   (setq insert_name (ssname ss i))
     
166.   (setq sjzb (cdr (assoc 10(entget insert_name))))
     
167.   
     
168. ;(setq e(get_inpoint insert_name))
     
169.    
     
170.   (setq lst (append lst (list sjzb)))
     
171.   
     
172. (setq i (1+ i))
     
173. )
     
174. ;(setq ptlst (HH:ssPts:Sort lst "xyz" 0.0))
     
175. ;@树櫴希德 点表按照特定点逆时针排序~
     
176. (setq p (getpoint "\n指定排序方向"))
     
177. (setq qianzhui  (getstring "\n请输入前缀："))
     
178. ;(setq ptlst(mapcar 'cdr (vl-sort (mapcar 'cons (mapcar '(lambda(x) (angle x p)) lst) lst) '(lambda (x y) (< (car x) (car y))))))
     
179. 
     
180. 
     
181. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
182. (setq ptlst (vl-sort (car (lst->2lst (reverse lst)))
     
183.                    ;以下根据x坐标对表排序
     
184.    '(lambda (e1 e2)
     
185.             (< (car e1) (car e2) )
     
186.       (= (angle  e1 p))   )   )    )
     
187. ;;;;;;;;;;;;;;;;;-----------------------------------
     
188. 
     
189. 
     
190. (initget "1 2")
     
191.   (prompt "\n坐标是否缩小1000倍:")
     
192.   (setq kkkk (getkword "\n 1. 不用缩小1000倍　　\  2. 缩小1000倍：<1>"))
     
193.   (if (= kkkk nil) (setq kkkk "1"))
     
194.   (setq ii 1)
     
195.   (setq  ff (open (getfiled "请输入要保存的数据文件名" "" "dat" 1) "w"))
     
196. ( cond ((= kkkk "1")
     
197.    (progn
     
198. (foreach n ptlst
     
199. 
     
200.    (entmake (list '(0 . "text") (cons 10 n) '(7 . "HZ") (cons 40 (* 1 zg))(cons 1 (strcat qianzhui (rtos ii 2 0))   )))
     
201. (maketext n (* 1 zg))
     
202. (write-line (strcat qianzhui (vl-princ-to-string ii)"," ","(vl-princ-to-string (car n)) ","(vl-princ-to-string (cadr n))","(vl-princ-to-string (caddr n))
     
203. ) ff)
     
204.   
     
205. (setq ii (1+ ii))
     
206.     ) (close ff)  ))
     
207. ( (= kkkk "2")
     
208. (progn
     
209. (foreach n ptlst
     
210. 
     
211.    (entmake (list '(0 . "text") (cons 10 n) '(7 . "HZ") (cons 40 (* 1000 zg))(cons 1 (strcat qianzhui (rtos ii 2 0))   )))
     
212. (maketext1 n (* 1000 zg))
     
213. (write-line (strcat qianzhui (vl-princ-to-string ii)"," ","(vl-princ-to-string (/ (car n) 1000)) ","(vl-princ-to-string (/ (cadr
     
214. n) 1000))","(vl-princ-to-string (/ (caddr n) 1000))
     
215. ) ff)
     
216.   
     
217. (setq ii (1+ ii))
     
218.     )  (close ff)
     
219. )
     
220.   )
     
221. 
     
222.    
     
223. 
     
224. )
     
225.   
     
226.   
     
227. 
     
228. 
     
229. 
     
230. 
     
231. 
     
232. )

(defun makepl(argments);;argments==>(list pts 闭合标志 全局宽度 线宽 图层 颜色 厚度 线型)pts以后可省略<br />   (entmakex(append(mapcar'cons'(0 100 100 43 370 8 62 39 6)(append'("LWPOLYLINE""AcDbEntity""AcDbPolyline")(cddr argments)))<br />       (cons(cons 90(length(car argments)))<br />            (cons(cons 70(if(cadr argments)(cadr argments)0))(mapcar'(lambda(x)(cons 10 x))(car argments)))))))<br /> (defun poinpl(p pt);;:点是否在指定点表内<br />   (equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8))<br /> (defun plinexy(e)<br />   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))<br />   )<br /> (defun SsgetW(arg / a);;选择指定矩形区域内(不限屏幕范围)<br />   (ssget"X"(apply'append(list'((-4 . "<and")(-4 . ">=,>="))<br />            (setq a(list(car arg)(cadr arg))<br />            a(mapcar'(lambda(x)(mapcar x a))'(car cadr))<br />            a(mapcar'(lambda(y)(cons 10(mapcar'(lambda(x)(apply y x))a)))'(min max))<br />            a(list(car a)'(-4 . "<=,<=")(cadr a)))<br />            (cddr arg)<br />            '((-4 . "and>")))))<br />   )<br /> (defun SsgetCP(arg / a i pt s b);;根据多线段图元名或者其坐标点表进行(ssget"CP"...)但不限屏幕范围<br />   (if(listp(setq a(car arg)))<br />     (setq pt a a(vlax-ename->vla-object(makepl(list pt))))<br />     (setq pt(plinexy a)a(vlax-ename->vla-object a)))<br />   (if(setq i -1<br />      s(SsgetW(append(mapcar'(lambda(x)(mapcar'(lambda(y)(apply x y))<br />           (mapcar'(lambda(x)(mapcar x pt))'(car cadr))))'(min max))(cdr arg)))<br />      s(if(SSMEMB(vlax-vla-object->ename a)s)(ssdel(vlax-vla-object->ename a)s)s))<br />     (repeat(sslength s)<br />       (setq i(1+ i)e(ssname s i))<br />       (if(not(or(>(vlax-safearray-get-u-bound(vlax-variant-value(vla-intersectwith(vlax-ename->vla-object e)a 0))1)1)<br />     (poinpl(cdr(assoc 10(entget e)))pt)))<br />   (setq b(cons e b)))))<br />   (if(listp(car arg))(vla-Delete a))<br />   (foreach a b(setq s(ssdel a s)))s)<br /> (defun SsgetWP(arg / a i pt s b);;根据多线段图元名或者其坐标点表进行(ssget"WP"...)但不限屏幕范围<br />   (if(listp(setq a(car arg)))<br />     (setq pt a a(vlax-ename->vla-object(makepl(list pt))))<br />     (setq pt(plinexy a)a(vlax-ename->vla-object a)))<br />   (if(setq i -1<br />      s(SsgetW(append(mapcar'(lambda(x)(mapcar'(lambda(y)(apply x y))<br />           (mapcar'(lambda(x)(mapcar x pt))'(car cadr))))'(min max))(cdr arg)))<br />      s(if(SSMEMB(vlax-vla-object->ename a)s)(ssdel(vlax-vla-object->ename a)s)s))<br />     (repeat(sslength s)<br />       (setq i(1+ i)e(ssname s i))<br />       (if(or(>(vlax-safearray-get-u-bound(vlax-variant-value(vla-intersectwith(vlax-ename->vla-object e)a 0))1)1)<br />      (not(poinpl(cdr(assoc 10(entget e)))pt)))<br />   (setq b(cons e b)))))<br />   (if(listp(car arg))(vla-Delete a))<br />   (foreach a b(setq s(ssdel a s)))s)<br /> <br /> <br /> <br /> ;;;<br /> (defun maketext (zb gd /  cld )<br />   (setq cld (polar zb (* 0.25 pi) (* 2 gd) ))<br /> (entmake (list<br /> '(0 . "LINE")<br /> '(67 . 0)<br /> '(8 . "0") <br /> (list 10 (car zb) (cadr zb) 0)<br /> (cons 11 cld )<br /> '(210 0.0 0.0 1.0)<br /> )<br /> )<br /> ;;;<br /> (entmake (list<br /> '(0 . "LINE")<br /> '(67 . 0)<br /> '(8 . "0") <br /> (cons 10 cld)<br /> (cons 11 ( polar cld 0 (* 10 gd)) )<br /> '(210 0.0 0.0 1.0)<br /> )<br /> )<br /> ;;;; <br /> (entmake (list<br /> '(0 . "text")<br /> (list 10 (+ (car cld) gd) (car(cdr cld)) )<br /> (cons 40 gd)<br /> (cons 1 ( strcat "X=" (rtos (cadr zb) 2 3)))<br /> '(50 . 0)<br /> )<br /> )<br /> (entmake (list<br /> '(0 . "text")<br /> (list 10 (+ (car cld) gd)<br /> (- (car(cdr cld)) (+ gd (/ gd 3)) )<br /> )<br /> (cons 40 gd)<br /> (cons 1 (strcat "Y="(rtos (car zb) 2 3)))<br /> '(50 . 0)<br /> )<br /> )<br /> (princ)<br /> )<br /> ;<br /> (defun maketext1 (zb gd /  cld )<br />   (setq cld (polar zb (* 0.25 pi) (* 2 gd) ))<br /> (entmake (list<br /> '(0 . "LINE")<br /> '(67 . 0)<br /> '(8 . "0") <br /> (list 10 (car zb) (cadr zb) 0)<br /> (cons 11 cld )<br /> '(210 0.0 0.0 1.0)<br /> )<br /> )<br /> ;;;<br /> (entmake (list<br /> '(0 . "LINE")<br /> '(67 . 0)<br /> '(8 . "0") <br /> (cons 10 cld)<br /> (cons 11 ( polar cld 0 (* 10 gd)) )<br /> '(210 0.0 0.0 1.0)<br /> )<br /> )<br /> ;;;; <br /> (entmake (list<br /> '(0 . "text")<br /> (list 10 (+ (car cld) gd) (car(cdr cld)) )<br /> (cons 40 gd)<br /> (cons 1 ( strcat "X=" (rtos (/ (cadr zb) 1000) 2 3)))<br /> '(50 . 0)<br /> )<br /> )<br /> (entmake (list<br /> '(0 . "text")<br /> (list 10 (+ (car cld) gd)<br /> (- (car(cdr cld)) (+ gd (/ gd 3)) )<br /> )<br /> (cons 40 gd)<br /> (cons 1 (strcat "Y="(rtos (/ (car zb) 1000) 2 3)))<br /> '(50 . 0)<br /> )<br /> )<br /> (princ)<br /> )<br /> <br /> ;货物分两组（样品 库存）<br /> (defun lst->2lst(lst / lst1 lst2)<br />   (setq lst1 '() lst2 '())<br /> (foreach a lst<br />     (if (member a lst2)<br />       (setq lst1 (cons a lst1))<br />       (setq lst2 (cons a lst2))<br />     )<br />   )<br /> (cons (reverse lst2) (reverse lst1))<br /> )<br /> <br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (defun c:gczbh1 (/ p qianzhui blc zg ss i lstt e kkkk ptlst ff sjzb xx ee zhuobiao lst )<br /> <br /> (setq blc (getint "\n请输入比例尺1:"))<br />   (setvar 'userr1 blc);设置比例尺<br /> (setq zg(* 0.002 blc));字高<br /> (setq ss (SsgetWP (list(car (entsel))'(0 . "circle") )) )<br />   (setq i 0)<br />   (setq lst '())<br />   <br />   <br /> (repeat (sslength ss)<br />   (setq insert_name (ssname ss i))<br />   (setq sjzb (cdr (assoc 10(entget insert_name))))<br />   <br /> ;(setq e(get_inpoint insert_name))<br />     <br />   (setq lst (append lst (list sjzb)))<br />   <br /> (setq i (1+ i))<br /> )<br /> ;(setq ptlst (HH:ssPts:Sort lst "xyz" 0.0))<br /> ;@树櫴希德 点表按照特定点逆时针排序~<br /> (setq p (getpoint "\n指定排序方向"))<br /> (setq qianzhui  (getstring "\n请输入前缀："))<br /> ;(setq ptlst(mapcar 'cdr (vl-sort (mapcar 'cons (mapcar '(lambda(x) (angle x p)) lst) lst) '(lambda (x y) (< (car x) (car y))))))<br /> <br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (setq ptlst (vl-sort (car (lst->2lst (reverse lst)))<br />                    ;以下根据x坐标对表排序<br />    '(lambda (e1 e2)<br />             (< (car e1) (car e2) )<br />       (= (angle  e1 p))   )   )    )<br /> ;;;;;;;;;;;;;;;;;-----------------------------------<br /> <br /> <br /> (initget "1 2")<br />   (prompt "\n坐标是否缩小1000倍:")<br />   (setq kkkk (getkword "\n 1. 不用缩小1000倍　　\  2. 缩小1000倍：<1>"))<br />   (if (= kkkk nil) (setq kkkk "1"))<br />   (setq ii 1)<br />   (setq  ff (open (getfiled "请输入要保存的数据文件名" "" "dat" 1) "w"))<br /> ( cond ((= kkkk "1")<br />    (progn<br /> (foreach n ptlst<br /> <br />    (entmake (list '(0 . "text") (cons 10 n) '(7 . "HZ") (cons 40 (* 1 zg))(cons 1 (strcat qianzhui (rtos ii 2 0))   )))<br /> (maketext n (* 1 zg))<br /> (write-line (strcat qianzhui (vl-princ-to-string ii)"," ","(vl-princ-to-string (car n)) ","(vl-princ-to-string (cadr n))","(vl-princ-to-string (caddr n))<br /> ) ff)<br />   <br /> (setq ii (1+ ii))<br />     ) (close ff)  ))<br /> ( (= kkkk "2")<br /> (progn<br /> (foreach n ptlst<br /> <br />    (entmake (list '(0 . "text") (cons 10 n) '(7 . "HZ") (cons 40 (* 1000 zg))(cons 1 (strcat qianzhui (rtos ii 2 0))   )))<br /> (maketext1 n (* 1000 zg))<br /> (write-line (strcat qianzhui (vl-princ-to-string ii)"," ","(vl-princ-to-string (/ (car n) 1000)) ","(vl-princ-to-string (/ (cadr <br /> n) 1000))","(vl-princ-to-string (/ (caddr n) 1000))<br /> ) ff)<br />   <br /> (setq ii (1+ ii))<br />     )  (close ff)<br /> )<br />   )<br /> <br />    <br /> <br /> )<br />   <br />   <br /> <br /> <br /> <br /> <br /> <br /> )

quester

测绘版楼主出了好多实用的程序！

VBALISPER

出成果了.赞一个

tigcat

楼主出了几个桩基编号的程序，感觉都很棒。刚学lisp的人可能会有点摸不着头脑
简要说明：1、楼主示范gif是桩以m为单位展示的，比如桩直径0.4m，字高比例为0.002*你输入的1:X的X，如果你的图时mm为单位，X输10000以上可能才看的见字高。
2、前缀字符。如果图纸名称无“HZ”字体样式，则前缀字符在图纸中无法生成，但输出dat表中有
展望：这个程序由于具有选取多段线给多段线里面桩编号功能，可拓展为以承台为个体，按承台位置的上下左右排序，再以每个承台里面的桩上下左右编号。
总之，是个很棒的程序。开始使用时由于字体原因没摸着头脑，看到相关的代码后就顺畅了。楼主程序扩展性很强！

zst1978

非常谢谢大侠分享