1 (vl-load-com)
2
3 ;;;关闭选取外图层
4 ;;;完整命令：YX_LAY_OFFSELO
5 ;;;简化命令：LF
6 (defun c:yx_lay_offselo( / ename i lay layers laylst layname n obj ss str tmplaynamelst)
7 (Berni_Start)
8 (princ "\nKN工具箱--关闭选取以外的图层")
9 (princ "\n->请选取不要关闭图层的对象或 <退出>:")
10 (setq ss (ssget))
11 (if ss
12 (progn
13 (Setq Layers (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Layers))
14 (vlax-for Lay Layers
15 (Vlax-Put-Property Lay 'LayerOn 0);关闭
16 )
17
18 (setq n (sslength ss) i 0 LayLst nil)
19 (repeat n
20 (setq ename (ssname ss i))
21 (setq obj (Vlax-Ename->Vla-Object ename))
22 (Setq LayName (Vlax-Get obj 'Layer ))
23 (setq LayLst (cons LayName LayLst))
24 (setq i (1+ i))
25 )
26 (setq tmpLayNameLst (BF-list-item-num LayLst))
27 (setq LayLst (BF-AssocList-Keys tmpLayNameLst))
28 (setq LayLst (vl-sort LayLst '<))
29 (setq i 0)
30 (repeat (length LayLst)
31 (Setq LayName (nth i LayLst))
32 (setq obj (Vlax-Invoke-Method Layers 'Item LayName ))
33 (Vlax-Put-Property obj 'LayerOn -1)
34 (setq i (1+ i))
35 )
36 (Setq str (StrUnParse LayLst ","))
37 (setq str (strcat "\n->没有关闭的图层为: " str))
38 (princ str)
39 )
40 )
41 (Berni_End)
42 (princ)
43 )
44
45
46 ;;;打开全部图层
47 ;;;完整命令：YX_LAY_ALLON
48 ;;;简化命令：LL
49 (defun c:yx_lay_allon( / lay layers)
50 (Setq Layers (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Layers))
51 (vlax-for Lay Layers
52 (Vlax-Put-Property Lay 'LayerOn -1 )
53 )
54
55 (princ "\n-全部图层已打开!")
56 (princ)
57 )
58
59
60 ;;;锁定选取外图层
61 ;;;完整命令：YX_LAY_LOCKSELL
62 ;;;简化命令：LK
63 (defun c:yx_lay_locksell( / ename i lay layers laylst layname n obj ss str tmplaynamelst)
64 (Berni_Start)
65 (princ "\nKN工具箱--锁定选取以外的图层")
66 (princ "\n->请选取不要锁定图层的对象或 <退出>:")
67 (setq ss (ssget))
68 (if ss
69 (progn
70 (Setq Layers (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Layers))
71 (vlax-for Lay Layers
72 (Setq LayName (Vlax-Get Lay 'Name ))
73 (sk_layerLock LayName T);锁定
74 )
75
76 (setq n (sslength ss) i 0 LayLst nil)
77 (repeat n
78 (setq ename (ssname ss i))
79 (setq obj (Vlax-Ename->Vla-Object ename))
80 (Setq LayName (Vlax-Get obj 'Layer ))
81 (setq LayLst (cons LayName LayLst))
82 (setq i (1+ i))
83 )
84 (setq tmpLayNameLst (BF-list-item-num LayLst))
85 (setq LayLst (BF-AssocList-Keys tmpLayNameLst))
86 (setq LayLst (vl-sort LayLst '<))
87 (setq i 0)
88 (repeat (length LayLst)
89 (Setq LayName (nth i LayLst))
90 (sk_layerLock LayName nil);解锁
91 (setq i (1+ i))
92 )
93 (vla-regen (vla-get-activedocument (vlax-get-acad-object)) 1)
94 (Setq str (StrUnParse LayLst ","))
95 (setq str (strcat "\n->没有锁定的图层为: " str))
96 (princ str)
97 )
98 )
99 (Berni_End)
100 (princ)
101 )
102
103
104 ;;;解锁全部图层
105 ;;;完整命令：YX_LAY_ALLUNLOCK
106 ;;;简化命令：UK
107 (defun c:yx_lay_allunlock( / lay layers)
108 (Setq Layers (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Layers))
109 (vlax-for Lay Layers
110 (Setq LayName (Vlax-Get Lay 'Name ))
111 (sk_layerLock LayName nil);解锁
112 )
113 (vla-regen (vla-get-activedocument (vlax-get-acad-object)) 1)
114 (princ "\n->全部图层已解锁!")
115 (princ)
116 )
117
118
119 ;计算多线条的总长度
120 ;仅适用于直线、多段线、圆、圆弧、椭圆、样条曲线
121 ;完整命令：YX_LN
122 ;简化命令：LN
123 (defun c:yx_ln( / clip_bord curveobj flag htm i lenlst n sigmalen ss str sumlen tmplen)
124 (Berni_Start)
125
126 (princ "\nKN工具箱--计算多线条的总长度")
127 (princ "\n->请选取要计算长度的线条或 <退出>:")
128 (setq htm (vlax-create-object "htmlfile"))
129 (setq Clip_Bord (Vlax-Get-Property (Vlax-Get htm 'ParentWindow) 'ClipboardData))
130
131 (setq flag T LenLst nil)
132 (while flag
133 (setq ss (ssget '((0 . "LINE,*POLYLINE,CIRCLE,ARC,ELLIPSE,SPLINE"))))
134 (if ss
135 (progn
136 (setq n (sslength ss) i 0 sumLen 0)
137 (repeat n
138 (setq curveObj (vlax-ename->vla-object (ssname ss i)))
139 (setq tmpLen (vlax-curve-getdistatparam curveObj (vlax-curve-getendparam curveObj)))
140 (setq sumLen (+ sumLen tmpLen))
141 (setq i (1+ i))
142 )
143 (setq LenLst (cons sumLen LenLst))
144 (Vlax-Invoke Clip_Bord 'SetData "text" (rtos sumLen 2 4))
145 (setq str (strcat "\n->总共选取了 " (itoa n) " 个线条,总长度= " (rtos sumLen 2 4) " 长度已复制到了粘贴板！"))
146 (princ str)
147 )
148 (progn
149 (setq flag nil)
150 )
151 )
152 )
153
154 (setq sigmaLen 0)
155
156 (if LenLst
157 (progn
158 (setq i 0)
159 (repeat (length LenLst)
160 (setq sigmaLen (+ sigmaLen (nth i LenLst)))
161 (setq i (1+ i))
162 )
163 )
164 )
165
166 (Vlax-Invoke Clip_Bord 'SetData "text" (rtos sigmaLen 2 4))
167 (setq str (strcat "\n->本次命令一共测量长度: " (rtos sigmaLen 2 4) " 总长度已复制到了粘贴板！"))
168 (princ str)
169
170 (Berni_End)
171 (princ)
172 )
173
174
175 ;圆坐标列表
176 ;完整命令：YX_CTY
177 ;简化命令：YL
178 (defun c:yx_cty(/ ss i obj&radiuslst ename obj radius e2 e1 radiuslst radius&numlst tabbasept szprefixflag str x textstyofcurdimsty dimscaleofcurdimsty textheightofcurdimsty scalefactoroftextstyofcurdimsty k radius_i diameter_i radius_i_num szalphabeticprefix szdiameter_i txtename txtobjname j center_k anothercornerpt p1 p2 lineename midpt)
179 (Berni_Start)
180
181 (princ "\nKN工具箱--圆坐标列表")
182 (princ "\n->请选取要做列表的圆或 <退出>:")
183 (if (setq ss (ssget '((0 . "CIRCLE"))))
184 (progn
185 (setq i 0 obj&RadiusLst nil)
186 (repeat (sslength ss)
187 (setq eName (ssname ss i))
188 (setq obj (Vlax-Ename->Vla-Object eName))
189 (Setq radius (Vlax-Get obj 'Radius ))
190 (setq obj&RadiusLst (append obj&RadiusLst (list (list obj radius))))
191 (setq i (1+ i))
192 )
193 (setq obj&RadiusLst (vl-sort obj&RadiusLst
194 (function (lambda (e1 e2)
195 (< (cadr e1) (cadr e2)) ) ) ));按半径升序
196
197 (setq radiusLst (mapcar 'cadr obj&RadiusLst))
198 ;;;归并
199 (setq i 0)
200 (if (> (length radiusLst) 1)
201 (progn
202 (repeat (1- (length radiusLst))
203 (if (< (abs (- (nth i radiusLst) (nth (1+ i) radiusLst))) 1e-8)
204 (progn
205 (setq radiusLst (BF-List-ReplaceIndex radiusLst (1+ i) (nth i radiusLst)))
206 )
207 )
208 (setq i (1+ i))
209 )
210 )
211 )
212 (setq radius&NumLst (BF-list-item-num radiusLst))
213
214 (if (setq tabBasePt (getpoint "\n->请指定表基点或 <退出>:"))
215 (progn
216 ;;;字母的显示方式
217 (setq szPrefixFlag (vl-registry-read "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "PrefixFlag"))
218 (if szPrefixFlag
219 nil
220 (progn
221 (setq szPrefixFlag "1")
222 (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "PrefixFlag" "1")
223 )
224 )
225 (setq str (strcat "\n指定字母的显示方式 [A, B, C(1)/a, b, c(2)]: <" szPrefixFlag ">"))
226 (setq x (fy_GetABC str '("1" "2") szPrefixFlag))
227 (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "PrefixFlag" x)
228
229 (setq textStyOfCurDimSty (getvar "dimtxsty"));当前标注样式中设置的文字的文字样式
230 (setq dimScaleOfCurDimSty (getvar "dimscale"));当前标注样式中设置的全局比例
231 (setq textHeightOfCurDimSty (getvar "dimtxt"));当前标注样式中设置的文字的文字高度
232 (setq textHeightOfCurDimSty (* textHeightOfCurDimSty dimScaleOfCurDimSty));当前标注样式中设置的文字的文字高度*当前标注样式中设置的全局比例
233 (setq scaleFactorOfTextStyOfCurDimSty (cdr (assoc 41 (tblsearch "style" textStyOfCurDimSty))));当前标注样式中设置的文字的文字样式的宽度比例
234 (setq i 0 k 0)
235 (repeat (length radius&NumLst)
236 (setq radius_i (car (nth i radius&NumLst)))
237 (setq diameter_i (* radius_i 2.0))
238 (setq radius_i_Num (cadr (nth i radius&NumLst)))
239 ;;;字母前缀
240 (cond
241 ((= x "1")
242 (setq szAlphabeticPrefix (chr (+ i 65)))
243 )
244 ((= x "2")
245 (setq szAlphabeticPrefix (chr (+ i 97)))
246 )
247 )
248 ;;;直径
249 (setq szDiameter_i (rtos diameter_i 2 2))
250 (setq txtEname (entmakex (list '(0 . "TEXT") (cons 40 textHeightOfCurDimSty) (cons 1 szDiameter_i) (cons 41 scaleFactorOfTextStyOfCurDimSty) '(10 0 0 0))))
251 (setq txtObjName (Vlax-Ename->Vla-Object txtEname))
252 (Vlax-Put-Property txtObjName 'StyleName textStyOfCurDimSty)
253 (Vlax-Put-Property txtObjName 'Color 42 )
254 (Vlax-Put-Property txtObjName 'Alignment 4 );中间
255 (Vlax-Put-Property txtObjName 'TextAlignmentPoint (vlax-3D-point (+ (car tabBasePt) (* 12.5 textHeightOfCurDimSty)) (- (cadr tabBasePt) (* 0.75 textHeightOfCurDimSty) (* (1+ i) (* 1.5 textHeightOfCurDimSty)))) )
256 ;;;表格编号
257 (setq txtEname (entmakex (list '(0 . "TEXT") (cons 40 textHeightOfCurDimSty) (cons 1 szAlphabeticPrefix) (cons 41 scaleFactorOfTextStyOfCurDimSty) '(10 0 0 0))))
258 (setq txtObjName (Vlax-Ename->Vla-Object txtEname))
259 (Vlax-Put-Property txtObjName 'StyleName textStyOfCurDimSty)
260 (Vlax-Put-Property txtObjName 'Color 42 )
261 (Vlax-Put-Property txtObjName 'Alignment 4 )
262 (Vlax-Put-Property txtObjName 'TextAlignmentPoint (vlax-3D-point (+ (car tabBasePt) (* 6.5 textHeightOfCurDimSty)) (- (cadr tabBasePt) (* 0.75 textHeightOfCurDimSty) (* (1+ i) (* 1.5 textHeightOfCurDimSty)))) )
263
264 (setq j 0)
265 (repeat radius_i_Num
266 ;;;圆右上角的编号
267 (setq center_k (vlax-get (car (nth k obj&RadiusLst)) 'center))
268 (setq txtEname (entmakex (list '(0 . "TEXT") (cons 40 textHeightOfCurDimSty) (cons 1 szAlphabeticPrefix) (cons 41 scaleFactorOfTextStyOfCurDimSty) '(10 0 0 0))))
269 (setq txtObjName (Vlax-Ename->Vla-Object txtEname))
270 (Vlax-Put-Property txtObjName 'StyleName textStyOfCurDimSty)
271 (Vlax-Put-Property txtObjName 'Alignment 0 )
272 (Vlax-Put-Property txtObjName 'InsertionPoint (vlax-3D-point (polar center_k (/ pi 4) (+ radius_i (/ (SQRT 2.0) 2.0)))) )
273 (if (= x "1");大写字母
274 (Vlax-Put-Property txtObjName 'InsertionPoint (vlax-3D-point (polar center_k (/ pi 4) (+ radius_i (/ (SQRT 2.0) 2.0) (* 0.1 textHeightOfCurDimSty)))) )
275 )
276 (setq k (1+ k))
277 (setq j (1+ j))
278 )
279 (setq i (1+ i))
280 )
281
282 (setq anotherCornerPt (list (+ (car tabBasePt) (* 23 textHeightOfCurDimSty)) (- (cadr tabBasePt) (* (* 1.5 textHeightOfCurDimSty) (1+ (length radius&NumLst)))) 0))
283 ;;;表格外框
284 (command "RECTANGLE" tabBasePt anotherCornerPt)
285 (setq p1 (list (+ (car tabBasePt) (* 4 textHeightOfCurDimSty)) (cadr tabBasePt) 0))
286 (setq p2 (list (car p1) (cadr anotherCornerPt) 0))
287 ;;;表格内部竖线
288 (setq LineEname (fy_makeline p1 p2))
289 (setq LineEname (fy_makeline (setq p1 (list (+ (car p1) (* 5 textHeightOfCurDimSty)) (cadr p1) 0)) (setq p2 (list (car p1) (cadr anotherCornerPt) 0))))
290 (setq LineEname (fy_makeline (setq p1 (list (+ (car p1) (* 7 textHeightOfCurDimSty)) (cadr p1) 0)) (setq p2 (list (car p1) (cadr p2) 0))))
291
292 (setq i 0)
293 (repeat (length radius&NumLst)
294 (setq p1 (list (car tabBasePt) (- (cadr tabBasePt) (* (* 1.5 textHeightOfCurDimSty) (1+ i))) 0))
295 (setq p2 (list (car anotherCornerPt) (cadr p1) 0))
296 ;;;表格内部水平线
297 (setq LineEname (fy_makeline p1 p2))
298 (setq i (1+ i))
299 )
300 ;;;表头
301 (setq txtEname (entmakex (list '(0 . "TEXT") (cons 40 textHeightOfCurDimSty) '(1 . "序号") (cons 41 scaleFactorOfTextStyOfCurDimSty) '(10 0 0 0))))
302 (setq txtObjName (Vlax-Ename->Vla-Object txtEname))
303 (Vlax-Put-Property txtObjName 'StyleName textStyOfCurDimSty)
304 (Vlax-Put-Property txtObjName 'Color 4 )
305 (Vlax-Put-Property txtObjName 'Alignment 4 )
306 (Vlax-Put-Property txtObjName 'TextAlignmentPoint (vlax-3D-point (+ (car tabBasePt) (* 2 textHeightOfCurDimSty)) (- (cadr tabBasePt) (* 0.75 textHeightOfCurDimSty))) )
307
308 (setq txtEname (entmakex (list '(0 . "TEXT") (cons 40 textHeightOfCurDimSty) '(1 . "编号") (cons 41 scaleFactorOfTextStyOfCurDimSty) '(10 0 0 0))))
309 (setq txtObjName (Vlax-Ename->Vla-Object txtEname))
310 (Vlax-Put-Property txtObjName 'StyleName textStyOfCurDimSty)
311 (Vlax-Put-Property txtObjName 'Color 4 )
312 (Vlax-Put-Property txtObjName 'Alignment 4 )
313 (Vlax-Put-Property txtObjName 'TextAlignmentPoint (vlax-3D-point (+ (car tabBasePt) (* 6.5 textHeightOfCurDimSty)) (- (cadr tabBasePt) (* 0.75 textHeightOfCurDimSty))) )
314
315 (setq txtObjName (Vlax-Ename->Vla-Object (entmakex (list '(0 . "TEXT") (cons 40 textHeightOfCurDimSty) '(1 . "直径") (cons 41 scaleFactorOfTextStyOfCurDimSty) '(10 0 0 0)))))
316 (Vlax-Put-Property txtObjName 'StyleName textStyOfCurDimSty)
317 (Vlax-Put-Property txtObjName 'Color 4 )
318 (Vlax-Put-Property txtObjName 'Alignment 4 )
319 (Vlax-Put-Property txtObjName 'TextAlignmentPoint (vlax-3D-point (+ (car tabBasePt) (* 12.5 textHeightOfCurDimSty)) (- (cadr tabBasePt) (* 0.75 textHeightOfCurDimSty))) )
320
321 (setq txtObjName (Vlax-Ename->Vla-Object (entmakex (list '(0 . "TEXT") (cons 40 textHeightOfCurDimSty) '(1 . "数量") (cons 41 scaleFactorOfTextStyOfCurDimSty) '(10 0 0 0)))))
322 (Vlax-Put-Property txtObjName 'StyleName textStyOfCurDimSty)
323 (Vlax-Put-Property txtObjName 'Color 4 )
324 (Vlax-Put-Property txtObjName 'Alignment 4 )
325 (Vlax-Put-Property txtObjName 'TextAlignmentPoint (vlax-3D-point (+ (car tabBasePt) (* 19.5 textHeightOfCurDimSty)) (- (cadr tabBasePt) (* 0.75 textHeightOfCurDimSty))) )
326
327 (setq i 0)
328 (repeat (length radius&NumLst)
329 (setq p1 (list (car tabBasePt) (- (cadr tabBasePt) (* (* 1.5 textHeightOfCurDimSty) (1+ i))) 0))
330 (setq p2 (list (+ (car p1) (* 4 textHeightOfCurDimSty)) (- (cadr p1) (* 1.5 textHeightOfCurDimSty)) 0))
331 (setq midPt (fy_m2p p1 p2))
332 ;;;序号
333 (setq txtObjName (Vlax-Ename->Vla-Object (entmakex (list '(0 . "TEXT") (cons 40 textHeightOfCurDimSty) '(1 . "1") (cons 41 scaleFactorOfTextStyOfCurDimSty) '(10 0 0 0)))))
334 (Vlax-Put-Property txtObjName 'StyleName textStyOfCurDimSty)
335 (Vlax-Put-Property txtObjName 'TextString (itoa (1+ i)) )
336 (Vlax-Put-Property txtObjName 'Color 42 )
337 (Vlax-Put-Property txtObjName 'Alignment 4 )
338 (Vlax-Put-Property txtObjName 'TextAlignmentPoint (vlax-3D-point midPt) )
339 ;;;数量
340 (setq txtObjName (Vlax-Ename->Vla-Object (entmakex (list '(0 . "TEXT") (cons 40 textHeightOfCurDimSty) '(1 . "1") (cons 41 scaleFactorOfTextStyOfCurDimSty) '(10 0 0 0)))))
341 (Vlax-Put-Property txtObjName 'StyleName textStyOfCurDimSty)
342 (Vlax-Put-Property txtObjName 'TextString (itoa (cadr (nth i radius&NumLst))) )
343 (Vlax-Put-Property txtObjName 'Color 42 )
344 (Vlax-Put-Property txtObjName 'Alignment 4 )
345 (Vlax-Put-Property txtObjName 'TextAlignmentPoint (vlax-3D-point (+ (car tabBasePt) (* 19.5 textHeightOfCurDimSty)) (- (cadr tabBasePt) (* 0.75 textHeightOfCurDimSty) (* (1+ i) (* 1.5 textHeightOfCurDimSty)))) )
346
347 (setq i (1+ i))
348 )
349 )
350 )
351 )
352 )
353
354 (Berni_End)
355 (princ)
356 )
357
358
359 ;检查标注测量值是否被修改
360 ;完整命令：YX_CDE
361 ;简化命令：CD
362 ;功能：
363 ;当文字替代的值为空字符串""时，尺寸没有被修改
364 ;当文字替代的值是"<>"时，尺寸有可能被修改，洋红显示
365 ;为其他值时，尺寸被修改，红色显示
366 (defun c:yx_cde(/ ss n i k k1 ename oname txt str)
367 (Berni_Start)
368
369 (setq ss (ssget "X" '((0 . "DIMENSION"))))
370 (setq n (sslength ss) i 0 k 0 k1 0)
371
372 (repeat n
373 (setq ename (ssname ss i))
374 (setq oname (vlax-ename->vla-object ename))
375 (setq txt (vla-get-TextOverride oname))
376
377 (cond
378 ((= txt "");;尺寸没有被修改
379 )
380 ((= txt "<>");;尺寸有可能被修改
381 (vla-put-TextColor oname 6)
382 (setq k (1+ k))
383 )
384 (T;;尺寸被修改
385 (vla-put-TextColor oname 1)
386 (setq k1 (1+ k1))
387 )
388 )
389
390 (setq i (1+ i))
391 );end repeat
392
393 (princ "\nKN工具箱--检查标注测量值是否被修改")
394 (princ "\n->被修改测量值的标注其文字将被改成1号颜色(红色)!")
395 (princ "\n->可能被修改测量值的标注其文字将被改成6号颜色(洋红色)!")
396 (if (and (= k 0) (= k1 0))
397 (progn
398 (princ "\n->没有标注测量值被修改!")
399 )
400 (progn
401 (if (> k 0)
402 (progn
403 (setq str (strcat "\n->共有 " (itoa k) " 个标注可能被修改"))
404 (princ str)
405 )
406 )
407 (if (> k1 0)
408 (progn
409 (setq str (strcat "\n->共有 " (itoa k1) " 个标注被修改"))
410 (princ str)
411 )
412 )
413 )
414 )
415
416 (Berni_End)
417 (princ)
418 )
419
420
421 ;双边偏移
422 ;完整命令：YX_OU
423 ;简化命令：YU
424 ;此命令只适用于直线、多段线、圆弧、圆、椭圆、样条曲线
425 ;不适用于构造线
426 (defun c:yx_ou( / ename flag oname realoffsetbilateraldistance ss str striscenterline stroffsetbilateraldistance x)
427 (Berni_Start)
428 (princ "\nKN工具箱--双边偏移")
429
430 ;;;+++++++++++++++++++++++++++++++++++偏移双边距离+++++++++++++++++++++++++++++++++++++
431 (setq strOffsetBilateralDistance (vl-registry-read "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "OffDis"))
432 (if (= strOffsetBilateralDistance nil)
433 (progn
434 (setq strOffsetBilateralDistance "6")
435 (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "OffDis" "6")
436 )
437 )
438 (setq str (strcat "\n->请输入偏移双边距离 <" (rtos (read strOffsetBilateralDistance) 2 4) ">:"))
439 (princ str)
440 (setq realOffsetBilateralDistance (getreal))
441 (if (= realOffsetBilateralDistance nil)
442 (setq realOffsetBilateralDistance (atof strOffsetBilateralDistance))
443 (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "OffDis" (rtos realOffsetBilateralDistance 2 15))
444 )
445 ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
446
447
448 (setq flag T)
449 (while (and flag (princ "\n->请选取对象向双边偏移或 <退出>:"))
450 (setq ss (ssget "_:S:E" '((0 . "LINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE"))))
451 (if (= ss nil)
452 (setq flag nil)
453 (progn
454 (setq ename (ssname ss 0))
455 (setq oname (vlax-ename->vla-object ename))
456 (Vlax-Invoke-Method oname 'Offset (/ realOffsetBilateralDistance 2.0))
457 (Vlax-Invoke-Method oname 'Offset (/ realOffsetBilateralDistance -2.0))
458
459 ;;;***********************************是否将中间的线条的线型改为中心线*************************************
460 (setq strIsCenterLine (vl-registry-read "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "isCenterLine"))
461 (if (= strIsCenterLine nil)
462 (progn
463 (setq strIsCenterLine "N")
464 (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "isCenterLine" "N")
465 )
466 )
467
468 (setq str (strcat "\n->是否将中间的线条的线型改为中心线? [Bend(B)/Center(C)/No(N)] <" strIsCenterLine ">:"))
469 (initget "Bend Center No")
470 (setq x (getkword str))
471 (if (= x nil)
472 (progn
473 (if (= strIsCenterLine "B") (setq x "Bend"))
474 (if (= strIsCenterLine "C") (setq x "Center"))
475 (if (= strIsCenterLine "N") (setq x "No"))
476 )
477 )
478 (if (= x "Bend") (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "isCenterLine" "B"))
479 (if (= x "Center") (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "isCenterLine" "C"))
480 (if (= x "No") (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "isCenterLine" "N"))
481 ;;;******************************************************************************************************
482
483 (if (= x "Bend")
484 (progn
485 (yx_CreateLayer "bend" 1 "CENTER")
486 ;参数 图层名 颜色 线型
487 ;参数类型 字符串 0-256整数 字符串
488 (Vlax-Put-Property oname 'Layer x )
489 (Vlax-Put-Property oname 'Color 256 )
490 (Vlax-Put-Property oname 'Linetype "ByLayer" )
491 (Vlax-Put-Property oname 'Lineweight acLnWtByLayer )
492 (command "regen")
493 );end progn
494 );end if (= x "Bend")
495
496 (if (= x "Center")
497 (progn
498 (yx_createLayer "center" 1 "CENTER")
499 (Vlax-Put-Property oname 'Layer x )
500 (Vlax-Put-Property oname 'Color 256 )
501 (Vlax-Put-Property oname 'Linetype "ByLayer" )
502 (Vlax-Put-Property oname 'Lineweight acLnWtByLayer )
503 (command "regen")
504 );end progn
505 );end if (= x "Center")
506
507 );end progn
508 );end if (= ss nil)
509
510 );end while
511
512 (Berni_End)
513 (princ)
514 );end defun c:yx_ou
515
516
517 ;智能中心线
518 ;完整命令：YX_CEN
519 ;简化命令：YN
520 ;只适用于两条直线、圆
521 ;两条直线必须拾取
522 (defun c:yx_cen(/ ang1 ang2 ang3 ang4 centerlinelay centerofcircle circlenum d1 d2 d3 d4 degcenang ename ename0 ename1 enttype i linenum lineobj lst3 n oname oname0 oname1 p1 p2 p3 p4 p5 p55 p6 pt1 pt2 pt3 pt4 radcenang radiusofcircle selmode0 selmode1 ss ss1 ss2 ssnamexret0 ssnamexret1 ssnamexretlst str strcenterlinelay strcenterlinelayer strcenterlinelayer1 x)
523 (Berni_Start)
524 (princ "\nKN工具箱--智能中心线")
525 (princ "\n->请选取要画中心线的对象或 <退出>:")
526
527 (if (setq ss (ssget '((0 . "CIRCLE,LINE"))))
528 (progn;ss /= nil
529 (setq strCenterLineLayer "bend")
530 (setq strCenterLineLayer1 "center")
531
532 (setq n (sslength ss))
533 (setq ss1 (ssadd) ss2 (ssadd))
534
535 (setq i 0 ssnamexRetLst nil)
536 (repeat n
537 (setq ename (ssname ss i))
538 (setq entType (cdr (assoc 0 (entget ename))))
539
540 (cond
541 ((equal entType "LINE")
542 (setq ss1 (ssadd ename ss1))
543 (setq ssnamexRetLst (cons (ssnamex ss i) ssnamexRetLst))
544 )
545 ((equal entType "CIRCLE")
546 (setq ss2 (ssadd ename ss2))
547 )
548 )
549
550 (setq i (1+ i))
551 )
552 (setq ssnamexRetLst (reverse ssnamexRetLst))
553
554 (setq LineNum (sslength ss1));直线
555 (setq circleNum (sslength ss2));圆
556
557
558 ;;;////////////////////图层///////////////////////////
559 (if (> circleNum 0) (yx_CreateLayer strCenterLineLayer1 1 "CENTER"));center
560 ;;;///////////////////////////////////////////////////
561
562
563 (setq i 0)
564 (repeat circleNum
565 (setq ename (ssname ss2 i))
566 (setq oname (vlax-ename->vla-object ename))
567 (Setq CenterOfCircle (Vlax-Get oname 'Center ))
568 (Setq RadiusOfCircle (Vlax-Get oname 'Radius ))
569 (setq pt1 (list (car CenterOfCircle) (+ (cadr CenterOfCircle) (* RadiusOfCircle 1.1)) 0))
570 (setq pt2 (list (car CenterOfCircle) (- (cadr CenterOfCircle) (* RadiusOfCircle 1.1)) 0))
571 (setq pt3 (list (- (car CenterOfCircle) (* RadiusOfCircle 1.1)) (cadr CenterOfCircle) 0))
572 (setq pt4 (list (+ (car CenterOfCircle) (* RadiusOfCircle 1.1)) (cadr CenterOfCircle) 0))
573 (setq LineObj (fy_LineFormat (fy_makeline pt1 pt2) strCenterLineLayer1 256 "ByLayer"))
574 (Vlax-Put-Property LineObj 'LinetypeScale 1 )
575 (setq LineObj (fy_LineFormat (fy_makeline pt3 pt4) strCenterLineLayer1 256 "ByLayer"))
576 (Vlax-Put-Property LineObj 'LinetypeScale 1 )
577 (setq i (1+ i))
578 )
579 (setq str (strcat "\n->共有 " (itoa circleNum) " 个圆成功画圆心十字线!"))
580 (if (> circleNum 0) (princ str))
581
582 (if (= LineNum 0)
583 nil
584 (if (or (= LineNum 1) (> LineNum 2))
585 (princ "\n->选中直线对象的个数≠2!")
586 (progn;LineNum == 2
587 (setq ename0 (ssname ss1 0))
588 (setq ename1 (ssname ss1 1))
589 (setq oname0 (vlax-ename->vla-object ename0))
590 (setq oname1 (vlax-ename->vla-object ename1))
591 (setq ssnamexRet0 (car ssnamexRetLst))
592 (setq ssnamexRet1 (cadr ssnamexRetLst))
593 (setq selMode0 (caar ssnamexRet0))
594 (setq selMode1 (car (car ssnamexRet1)))
595
596 (if (and (= selMode0 1) (= selMode1 1))
597 (progn;两条直线逐一拾取
598
599 (setq strCenterLineLay (vl-registry-read "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "CenterLineLay"))
600 (if (= strCenterLineLay nil)
601 (progn
602 (setq strCenterLineLay "B")
603 (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "CenterLineLay" "B")
604 )
605 )
606
607
608 ;;;////////////////////图层///////////////////////////
609 (setq str (strcat "\n指定中心线的图层 [Bend(B)/Center(C)]: <" strCenterLineLay ">"))
610 (setq x (fy_GetABC str '("B" "C") strCenterLineLay))
611 (if (= x "B")
612 (progn
613 (setq centerLineLay strCenterLineLayer)
614 (yx_CreateLayer centerLineLay 1 "CENTER");bend
615 )
616 )
617 (if (= x "C")
618 (progn
619 (setq centerLineLay strCenterLineLayer1)
620 (yx_CreateLayer centerLineLay 1 "CENTER");center
621 )
622 )
623 (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "CenterLineLay" x)
624 ;;;///////////////////////////////////////////////////
625
626
627 (setq p1 (vlax-curve-getstartpoint oname0)
628 p2 (vlax-curve-getendpoint oname0)
629 p3 (vlax-curve-getstartpoint oname1)
630 p4 (vlax-curve-getendpoint oname1)
631 p5 (inters p1 p2 p3 p4 nil);交点，两条线被认为是无限长的
632 )
633
634 (if p5
635 (progn;不平行
636 (setq d1 (vlax-curve-getclosestpointto oname0 (cadr (nth 3 (car ssnamexRet0)))))
637 (setq d2 (vlax-curve-getclosestpointto oname1 (cadr (nth 3 (car ssnamexRet1)))))
638
639 (if (inters p1 p2 p3 p4 T)
640 (progn;相交
641 (if (equal (distance p1 p5) 0 1e-8)
642 (setq d3 p2)
643 (if (= (rtos (angle p5 d1) 2 8) (rtos (angle p5 p1) 2 8)) (setq d3 p1) (setq d3 p2))
644 )
645 (if (equal (distance p3 p5) 0 1e-8)
646 (setq d4 p4)
647 (if (= (rtos (angle p5 d2) 2 8) (rtos (angle p5 p3) 2 8)) (setq d4 p3) (setq d4 p4))
648 )
649
650 (setq ang1 (angle p5 d3));弧度制
651 (setq ang2 (angle p5 d4))
652
653 (setq p6 (polar p5 (- (max ang1 ang2) (/ (abs (- ang1 ang2)) 2)) (/ (+ (distance p5 d1) (distance p5 d2)) 2.0)))
654 (setq p6 (inters p5 p6 d3 d4 nil));相交，两条线被认为是无限长的
655 (fy_LineFormat (fy_makeline p5 (polar p5 (angle p5 p6) (+ (distance p5 p6) 1))) centerLineLay 256 "ByLayer")
656
657 (if (> (abs (- ang1 ang2)) pi)
658 (progn
659 (setq ang3 (- (max ang1 ang2) (* 2 pi)))
660 (setq ang4 (min ang1 ang2))
661 (setq radCenAng (- (max ang3 ang4) (/ (abs (- ang3 ang4)) 2)))
662 )
663 (setq radCenAng (- (max ang1 ang2) (/ (abs (- ang1 ang2)) 2)))
664 )
665 (setq degCenAng (/ (* radCenAng 180.0) pi))
666 (setq str (strcat "\n->两直线的中心线角度= " (rtos degCenAng 2 8)))
667 (princ str)
668 );相交
669 (progn;不相交
670 (setq p55 nil)
671 (or (setq p55 (vlax-invoke oname0 'intersectwith oname1 1));延伸基本对象，不延伸作为参数传递的对象
672 (setq p55 (vlax-invoke oname1 'intersectwith oname0 1))
673 )
674 (if p55
675 (progn;延长一条线有交点p55
676 (if (and (not (equal p1 p55 1e-8)) (not (equal p2 p55 1e-8)) (not (equal p3 p55 1e-8)) (not (equal p4 p55 1e-8)))
677 (progn;交点p55不与四点共点
678 (cond;排除一个无用点，并且按顺序排序三点
679 ((setq p55 (vlax-invoke oname0 'intersectwith oname1 1));延长oname0
680 (if (> (fy_perdis p1 p3 p4) (fy_perdis p2 p3 p4))
681 (setq lst3 (list p3 p1 p4));远端
682 (setq lst3 (list p3 p2 p4))
683 )
684 (setq d3 (nth 1 lst3))
685 (if (= (rtos (angle p5 d2) 2 8) (rtos (angle p5 p3) 2 8)) (setq d4 p3) (setq d4 p4))
686 (setq ang1 (angle p5 d3))
687 (setq ang2 (angle p5 d4))
688 )
689 ((setq p55 (vlax-invoke oname1 'intersectwith oname0 1));延长oname1
690 (if (> (fy_perdis p3 p1 p2) (fy_perdis p4 p1 p2))
691 (setq lst3 (list p1 p3 p2))
692 (setq lst3 (list p1 p4 p2))
693 )
694 (if (= (rtos (angle p5 d1) 2 8) (rtos (angle p5 p1) 2 8)) (setq d3 p1) (setq d3 p2))
695 (setq d4 (nth 1 lst3))
696 (setq ang1 (angle p5 d3))
697 (setq ang2 (angle p5 d4))
698 )
699 );end cond
700
701 (setq p6 (polar p5 (- (max ang1 ang2) (/ (abs (- ang1 ang2)) 2)) (/ (+ (distance p5 d1) (distance p5 d2)) 2.0)))
702 (setq p6 (inters p5 p6 d3 d4 nil));两条线被认为是无限长的
703 (fy_LineFormat (fy_makeline p5 (polar p5 (angle p5 p6) (+ (distance p5 p6) 1))) centerLineLay 256 "ByLayer")
704 (if (> (abs (- ang1 ang2)) pi)
705 (progn
706 (setq ang3 (- (max ang1 ang2) (* 2 pi)))
707 (setq ang4 (min ang1 ang2))
708 (setq radCenAng (- (max ang3 ang4) (/ (abs (- ang3 ang4)) 2)))
709 )
710 (setq radCenAng (- (max ang1 ang2) (/ (abs (- ang1 ang2)) 2)))
711 )
712 (setq degCenAng (/ (* radCenAng 180.0) pi))
713 (setq str (strcat "\n->两直线的中心线角度= " (rtos degCenAng 2 8)))
714 (princ str)
715 );end progn;交点p55不与四点共点
716 (progn;交点p55与四点之一共点
717 (cond;排除一个无用点，并且按顺序排序三点
718 ((setq p55 (vlax-invoke oname0 'intersectwith oname1 1));延长oname0
719 (if (> (fy_perdis p1 p3 p4) (fy_perdis p2 p3 p4))
720 (setq lst3 (list p3 p1 p4));远端
721 (setq lst3 (list p3 p2 p4))
722 )
723 (setq d3 (nth 1 lst3))
724 (if (equal (distance p3 p5) 0 1e-8)
725 (setq d4 p4)
726 (setq d4 p3)
727 )
728 (setq ang1 (angle p5 d3))
729 (setq ang2 (angle p5 d4))
730 )
731 ((setq p55 (vlax-invoke oname1 'intersectwith oname0 1));延长oname1
732 (if (> (fy_perdis p3 p1 p2) (fy_perdis p4 p1 p2))
733 (setq lst3 (list p1 p3 p2))
734 (setq lst3 (list p1 p4 p2))
735 )
736 (if (equal (distance p1 p5) 0 1e-8)
737 (setq d3 p2)
738 (setq d3 p1)
739 )
740 (setq d4 (nth 1 lst3))
741 (setq ang1 (angle p5 d3))
742 (setq ang2 (angle p5 d4))
743 )
744 );end cond
745
746 (setq p6 (polar p5 (- (max ang1 ang2) (/ (abs (- ang1 ang2)) 2)) (/ (+ (distance p5 d1) (distance p5 d2)) 2.0)))
747 (setq p6 (inters p5 p6 d3 d4 nil));两条线被认为是无限长的
748 (fy_LineFormat (fy_makeline p5 (polar p5 (angle p5 p6) (+ (distance p5 p6) 1))) centerLineLay 256 "ByLayer")
749
750 (if (> (abs (- ang1 ang2)) pi)
751 (progn
752 (setq ang3 (- (max ang1 ang2) (* 2 pi)))
753 (setq ang4 (min ang1 ang2))
754 (setq radCenAng (- (max ang3 ang4) (/ (abs (- ang3 ang4)) 2)))
755 )
756 (setq radCenAng (- (max ang1 ang2) (/ (abs (- ang1 ang2)) 2)))
757 )
758 (setq degCenAng (/ (* radCenAng 180.0) pi))
759 (setq str (strcat "\n->两直线的中心线角度= " (rtos degCenAng 2 8)))
760 (princ str)
761 )
762 );end if
763 );延长一条线有交点p55
764 (progn;只有延长两条线才有交点
765 (if (= (rtos (angle p5 d1) 2 8) (rtos (angle p5 p1) 2 8)) (setq d3 p1) (setq d3 p2))
766 (if (= (rtos (angle p5 d2) 2 8) (rtos (angle p5 p3) 2 8)) (setq d4 p3) (setq d4 p4))
767 (setq ang1 (angle p5 d3))
768 (setq ang2 (angle p5 d4))
769 (setq p6 (polar p5 (- (max ang1 ang2) (/ (abs (- ang1 ang2)) 2)) (/ (+ (distance p5 d1) (distance p5 d2)) 2.0)))
770 (if (inters p1 p3 p2 p4 T)
771 (setq p5 (inters p1 p4 p5 p6 nil)
772 p6 (inters p2 p3 p5 p6 nil)
773 )
774 (setq p5 (inters p1 p3 p5 p6 nil)
775 p6 (inters p2 p4 p5 p6 nil)
776 )
777 )
778 (fy_LineFormat (fy_makeline (polar p6 (angle p6 p5) (+ (distance p5 p6) 1)) (polar p5 (angle p5 p6) (+ (distance p5 p6) 1))) centerLineLay 256 "ByLayer")
779
780 (if (> (abs (- ang1 ang2)) pi)
781 (progn
782 (setq ang3 (- (max ang1 ang2) (* 2 pi)))
783 (setq ang4 (min ang1 ang2))
784 (setq radCenAng (- (max ang3 ang4) (/ (abs (- ang3 ang4)) 2)))
785 )
786 (setq radCenAng (- (max ang1 ang2) (/ (abs (- ang1 ang2)) 2)))
787 )
788 (setq degCenAng (/ (* radCenAng 180.0) pi))
789 (setq str (strcat "\n->两直线的中心线角度= " (rtos degCenAng 2 8)))
790 (princ str)
791 );只有延长两条线才有交点
792 )
793 );不相交
794 )
795 );不平行
796 (progn;平行
797 (setq p5 (fy_m2p p1 (fy_PerToLine p1 p3 p4)))
798 (setq p6 (fy_m2p p2 (fy_PerToLine p2 p3 p4)))
799 (if (inters p1 p3 p2 p4)
800 (progn
801 (setq p5 (inters p5 p6 p1 p4 nil))
802 (setq p6 (inters p5 p6 p2 p3 nil))
803 )
804 (progn
805 (setq p5 (inters p5 p6 p1 p3 nil))
806 (setq p6 (inters p5 p6 p2 p4 nil))
807 )
808 )
809 (fy_LineFormat (fy_makeline (polar p6 (angle p6 p5) (+ (distance p5 p6) 1)) (polar p5 (angle p5 p6) (+ (distance p5 p6) 1))) centerLineLay 256 "ByLayer")
810
811 (setq radCenAng (angle p5 p6))
812 (if (> radCenAng pi)
813 (setq radCenAng (- radCenAng pi))
814 )
815 (setq degCenAng (/ (* radCenAng 180.0) pi))
816 (setq str (strcat "\n->两直线的中心线角度= " (rtos degCenAng 2 8)))
817 (princ str)
818 );平行
819 );end if p5
820 );end progn 两条直线逐一拾取
821 (princ "\n->两条直线的选择方式，只能逐一拾取，不能框选！")
822 );end if (and (= selMode0 1) (= selMode1 1))
823 );end progn LineNum == 2
824 );if (or (= LineNum 1) (> LineNum 2))
825 );if (= LineNum 0)
826 );end progn ss /= nil
827 );end if ss
828
829 (Berni_End)
830 (princ)
831 );end defun c:yx_cen
832
833
834 (defun fy_makeline(pt1 pt2);生成一条line
835 ;;参数：pt1:起点，pt2:终点,均为三维点,即(x y z)
836 ;;返回值：图元名
837 (entmakex (list '(0 . "line") (cons 10 pt1) (cons 11 pt2)))
838 )
839
840 (defun fy_LineFormat(obj lay col lt);线的格式
841 ;图元名/obj对象 图层 颜色 线型
842 ; 字符串 整数 字符串
843 ; "bend" 256 "ByLayer"
844 (if lay
845 (progn
846 (if (= (type obj) 'ENAME) (setq obj (vlax-ename->vla-object obj)))
847 (vla-put-layer obj lay)
848 (vla-put-Color obj col)
849 (vla-put-Linetype obj lt)
850 (vla-put-LinetypeScale obj 1)
851 (vla-update obj)
852 )
853 )
854 obj
855 )
856
857 (defun fy_m2p(p1 p2);得到两点的中点坐标
858 (mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2)
859 )
860
861 (defun fy_PerToLine(cp p1 p2 / norm);计算cp到p1 p2的垂足点
862 (setq norm (mapcar '- p2 p1)
863 p1 (trans p1 0 norm)
864 cp (trans cp 0 norm)
865 )
866 (trans (list (car p1) (cadr p1) (caddr cp)) norm 0)
867 )
868
869 (defun fy_perdis(pt ps pe);返回点pt到直线（起点ps，终点pe）的距离
870 (distance pt (fy_PerToLine pt ps pe))
871 )
872
873 (defun yx_createLayer(strLayName intColor strLtype / yx_file file str)
874 (if (tblsearch "Ltype" "Center")
875 nil
876 (progn
877 (setq yx_File (vl-filename-mktemp nil nil ".lin"))
878 (setq file (open yx_File "w"))
879 (foreach str '(
880 "*CENTER,Center ____ _ ____ _ ____ _ ____ _ ____ _ ____"
881 "A,1.25,-.25,.25,-.25"
882 )
883 (write-line str file)
884 )
885 (close file)
886 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Load "CENTER" yx_File)
887 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Add "CENTER")
888 (vl-file-delete yx_File)
889 )
890 )
891
892 (if (tblsearch "Ltype" "CENTER2")
893 nil
894 (progn
895 (setq yx_File (vl-filename-mktemp nil nil ".lin"))
896 (setq file (open yx_File "w"))
897 (foreach str '(
898 "*CENTER2,Center (.5x) ___ _ ___ _ ___ _ ___ _ ___ _ ___"
899 "A,.75,-.125,.125,-.125"
900 )
901 (write-line str file)
902 )
903 (close file)
904 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Load "CENTER2" yx_File)
905 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Add "CENTER2")
906 (vl-file-delete yx_File)
907 )
908 )
909
910 (if (tblsearch "Ltype" "CENTERX2")
911 nil
912 (progn
913 (setq yx_File (vl-filename-mktemp nil nil ".lin"))
914 (setq file (open yx_File "w"))
915 (foreach str '(
916 "*CENTERX2,Center (2x) ________ __ ________ __ _____"
917 "A,2.5,-.5,.5,-.5"
918 )
919 (write-line str file)
920 )
921 (close file)
922 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Load "CENTERX2" yx_File)
923 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Add "CENTERX2")
924 (vl-file-delete yx_File)
925 )
926 )
927
928 (if (tblsearch "Ltype" "PHANTOM")
929 nil
930 (progn
931 (setq yx_File (vl-filename-mktemp nil nil ".lin"))
932 (setq file (open yx_File "w"))
933 (foreach str '(
934 "*PHANTOM,Phantom ______ __ __ ______ __ __ ______"
935 "A,1.25,-.25,.25,-.25,.25,-.25"
936 )
937 (write-line str file)
938 )
939 (close file)
940 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Load "PHANTOM" yx_File)
941 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Add "PHANTOM")
942 (vl-file-delete yx_File)
943 )
944 )
945
946 (if (tblsearch "Ltype" "PHANTOM2")
947 nil
948 (progn
949 (setq yx_File (vl-filename-mktemp nil nil ".lin"))
950 (setq file (open yx_File "w"))
951 (foreach str '(
952 "*PHANTOM2,Phantom (.5x) ___ _ _ ___ _ _ ___ _ _ ___ _ _"
953 "A,.625,-.125,.125,-.125,.125,-.125"
954 )
955 (write-line str file)
956 )
957 (close file)
958 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Load "PHANTOM2" yx_File)
959 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Add "PHANTOM2")
960 (vl-file-delete yx_File)
961 )
962 )
963
964 (if (tblsearch "Ltype" "PHANTOMX2")
965 nil
966 (progn
967 (setq yx_File (vl-filename-mktemp nil nil ".lin"))
968 (setq file (open yx_File "w"))
969 (foreach str '(
970 "*PHANTOMX2,Phantom (2x) ____________ ____ ____ _"
971 "A,2.5,-.5,.5,-.5,.5,-.5"
972 )
973 (write-line str file)
974 )
975 (close file)
976 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Load "PHANTOMX2" yx_File)
977 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Add "PHANTOMX2")
978 (vl-file-delete yx_File)
979 )
980 )
981
982 (if (tblsearch "Ltype" strLtype)
983 nil
984 (progn
985 (setq yx_File (findfile "acadiso.lin"))
986 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Load strLtype yx_File)
987 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Add strLtype)
988 )
989 );end if
990
991 (if (tblsearch "Layer" strLayName)
992 nil
993 (progn
994 (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") (cons 6 strLtype) (cons 62 intColor) '(370 . -3) '(70 . 0) '(290 . 1) (cons 2 strLayName)));;组码6【线型】,62【颜色】,370【线宽】,70【可见】,290【打印】，2【图层名称】
995 )
996 );end if
997 );end defun create
998
999 ;;;名称:BF-List-ReplaceIndex
1000 ;;;说明:按索引替换列表
1001 ;;;参数:oldlst:被替换的列表
1002 ;;;参数:index:索引，从0开始
1003 ;;;参数:item:值
1004 ;;;返回:替换后的列表
1005 ;;;示例:(BF-List-ReplaceIndex '(0 1 2 3) 1 5)
1006 (defun BF-List-ReplaceIndex(oldlst index item)
1007 (if (zerop index)
1008 (append (list item) (cdr oldlst))
1009 (cons (car oldlst)
1010 (BF-list-replaceindex (cdr oldlst) (1- index) item)
1011 )
1012 )
1013 )
1014
1015 ;;;name:BF-list-item-num
1016 ;;;desc:表中元素及数量
1017 ;;;arg:lst:列表
1018 ;;;return:元素及数量组成的表
1019 ;;;example:(BF-list-item-num '(1 2 2 3 4 2 4 5 2 6 7))->((7 1) (6 1) (5 1) (4 2) (3 1) (2 4) (1 1))
1020 (defun BF-list-item-num(lst / l2 tmp tmp1)
1021 (while
1022 (setq l2
1023 (cons
1024 (list
1025 (setq tmp1 (car lst))
1026 (- (length lst) (length (setq tmp (vl-remove tmp1 lst)))))
1027 l2)
1028 lst tmp
1029 )
1030 )
1031 (reverse l2)
1032 )
1033
1034 (defun fy_GetABC(pro lst def / kw val);一触即发选项(返回大写)
1035 ;一触即发的选项[pro-提示 lst-关键字列表 def-缺省关键字]
1036 ;例1：(fy_GetABC "\n输入选项[A 直线/B 圆弧/ C圆]：" '("A" "B" "C") "a")
1037 ;例2：(fy_GetABC "\n输入选项[A 直线/B 圆弧/ C圆]：<退出>" '("a" "b" "c") "X")
1038 (setq lst (apply 'append (mapcar '(lambda(e)
1039 (list (ascii (strcase e)) (ascii (strcase e T)))) lst)) def (ascii def))
1040 (prompt pro)
1041 (while (not (and (setq kw (grread nil 8) val (car kw) kw (cadr kw))
1042 (member val '(2 11 25))
1043 (if (or (= val 25) (and (= val 11) (= kw 0)) (member kw '(13 32)))
1044 (setq kw def)
1045 (member kw lst)
1046 )
1047 )
1048 )
1049 )
1050 (strcase (vl-list->string (list kw)))
1051 )
1052
1053 ;;;反解析表为字符串
1054 ;;;(StrUnParse Lst ";")
1055 ;;;---------------------------------------------------------------------------------
1056 (defun StrUnParse (Lst Delimiter / return)
1057 (setq return "")
1058 (foreach str Lst
1059 (setq return (strcat return Delimiter str))
1060 );_end of foreach
1061 (substr return 2)
1062 );_end of defun
1063
1064 ;;;函数名称:BF-AssocList-Keys
1065 ;;;函数说明:返回关联表的key值表
1066 ;;;参 数:lst:关联表
1067 ;;;返 回 值:key值表
1068 ;;;示 例:(BF-AssocList-Keys lst)
1069 (defun BF-AssocList-Keys(lst)
1070 (mapcar 'car lst)
1071 )
1072
1073 ;;;name:sk_layerLock
1074 ;;;desc:LayerLock图层锁定
1075 ;;;arg:layername 图层名 flag 锁定标志[T锁定或nil解锁]
1076 ;;;return:none 无
1077 ;;;example:(sk_layerLock "0" T)
1078 (defun sk_layerLock(layername flag / obj en)
1079 (if (setq en (tblobjname "layer" layername))
1080 (progn
1081 (setq obj (vlax-ename->vla-object en))
1082 (if flag
1083 (vla-put-lock obj :vlax-true)
1084 (vla-put-lock obj :vlax-false)
1085 )
1086 (vla-put-layeron obj (vla-get-layeron obj))
1087 (vlax-release-object obj)
1088 )
1089 )
1090 )
1091
1092 (defun yx_LtypeInit( / file str yx_file)
1093 (if (tblsearch "Ltype" "Center")
1094 nil
1095 (progn
1096 (setq yx_File (vl-filename-mktemp nil nil ".lin"))
1097 (setq file (open yx_File "w"))
1098 (foreach str '(
1099 "*CENTER,Center ____ _ ____ _ ____ _ ____ _ ____ _ ____"
1100 "A,1.25,-.25,.25,-.25"
1101 "*CENTER2,Center (.5x) ___ _ ___ _ ___ _ ___ _ ___ _ ___"
1102 "A,.75,-.125,.125,-.125"
1103 "*CENTERX2,Center (2x) ________ __ ________ __ _____"
1104 "A,2.5,-.5,.5,-.5"
1105 "*PHANTOM,Phantom ______ __ __ ______ __ __ ______"
1106 "A,1.25,-.25,.25,-.25,.25,-.25"
1107 "*PHANTOM2,Phantom (.5x) ___ _ _ ___ _ _ ___ _ _ ___ _ _"
1108 "A,.625,-.125,.125,-.125,.125,-.125"
1109 "*PHANTOMX2,Phantom (2x) ____________ ____ ____ _"
1110 "A,2.5,-.5,.5,-.5,.5,-.5"
1111 )
1112 (write-line str file)
1113 )
1114 (close file)
1115 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Load "CENTER" yx_File)
1116 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Add "CENTER")
1117 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Load "CENTER2" yx_File)
1118 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Add "CENTER2")
1119 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Load "CENTERX2" yx_File)
1120 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Add "CENTERX2")
1121 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Load "PHANTOM2" yx_File)
1122 (Vlax-Invoke-Method (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'Linetypes) 'Add "PHANTOM2")
1123 )
1124 )
1125 );end defun init
1126
1127 ;;;初始化，读取系统变量
1128 (defun Berni_Start()
1129 (setq Berni_S_Lst (List (getvar "osmode");0
1130 (getvar "cmdecho");1
1131 (getvar "clayer");2
1132 (getvar "textstyle");3
1133 (getvar "cecolor");4
1134 (getvar "dimstyle");5
1135 (getvar "plinewid");6
1136 (getvar "attdia");7
1137 (getvar "PICKSTYLE");8
1138 (getvar "PEDITACCEPT");9
1139 (getvar "dynmode");10
1140 );end list
1141 );end setq
1142 (command "undo" "be")
1143 (setq old_error *error*)
1144 (setq *error* *error*_zrw)
1145 (setvar "cmdecho" 0)
1146 (setvar "osmode" 0)
1147 (setvar "attdia" 0)
1148 (setvar "PICKSTYLE" 0)
1149 (setvar "PEDITACCEPT" 1)
1150 (setvar "dynmode" 0)
1151 (yx_LtypeInit)
1152 (princ)
1153 )
1154
1155 ;;;结束时，恢复系统变量
1156 (defun Berni_End()
1157 (setvar "osmode" (nth 0 Berni_s_Lst))
1158 (setvar "cmdecho" (nth 1 Berni_s_Lst))
1159 (setvar "clayer" (nth 2 Berni_s_Lst))
1160 (setvar "textstyle" (nth 3 Berni_s_Lst))
1161 (setvar "cecolor" (nth 4 Berni_s_Lst))
1162 (command "dimstyle" "r" (nth 5 Berni_s_Lst))
1163 (setvar "plinewid" (nth 6 Berni_s_Lst))
1164 (setvar "attdia" (nth 7 Berni_s_Lst))
1165 (setvar "PICKSTYLE" (nth 8 Berni_s_Lst))
1166 (setvar "PEDITACCEPT" (nth 9 Berni_s_Lst))
1167 (setvar "dynmode" (nth 10 Berni_s_Lst))
1168 (setq *error* old_error)
1169 (command "undo" "e")
1170 (princ)
1171 )
1172
1173 ;自定义错误处理函数
1174 (defun *error*_zrw(msg)
1175 (princ "\n出错: ")
1176 (princ msg)
1177 (princ ", 程序退出! ")
1178 (Berni_End)
1179 )
1180
1181 ;简化命令可以自己设置
1182 (defun c:YL()
1183 (c:yx_cty)
1184 )
1185 (defun c:CD()
1186 (c:yx_cde)
1187 )
1188 (defun c:YU()
1189 (c:yx_ou)
1190 )
1191 (defun c:YN()
1192 (c:yx_cen)
1193 )
1194 (defun c:LN()
1195 (c:yx_ln)
1196 )
1197 (defun c:LF()
1198 (c:yx_lay_offselo)
1199 )
1200 (defun c:LL()
1201 (c:yx_lay_allon)
1202 )
1203 (defun c:LK()
1204 (c:yx_lay_locksell)
1205 )
1206 (defun c:UK()
1207 (c:yx_lay_allunlock)
1208 )
1209
1210 (princ "\n圆坐标列表程序加载完成，完整命令YX_CTY，简化命令YL")
1211 (princ "\n检查标注测量值是否被修改程序加载完成，完整命令YX_CDE，简化命令CD")
1212 (princ "\n双边偏移程序加载完成，完整命令YX_OU，简化命令YU")
1213 (princ "\n智能中心线程序加载完成，完整命令YX_CEN，简化命令YN")
1214 (princ "\n计算多线条的总长度程序加载完成，完整命令YX_LN，简化命令LN")
1215 (princ "\n关闭选取外图层程序加载完成，完整命令YX_LAY_OFFSELO，简化命令LF")
1216 (princ "\n打开全部图层程序加载完成，完整命令YX_LAY_ALLON，简化命令LL")
1217 (princ "\n锁定选取外图层程序加载完成，完整命令YX_LAY_LOCKSELL，简化命令LK")
1218 (princ "\n解锁全部图层程序加载完成，完整命令YX_LAY_ALLUNLOCK，简化命令UK")
1219
1220 (vl-registry-delete "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw")
1221 (princ)
浙公网安备 33010602011771号