lisp123出品标注工具箱_VisualLisp高仿某工具箱的几个命令

1 (vl-load-com)2

3 ;;;关闭选取外图层4 ;;;完整命令：YX_LAY_OFFSELO5 ;;;简化命令：LF6 (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 (ifss12 (progn13 (Setq Layers (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument)'Layers))14 (vlax-forLay Layers15 (Vlax-Put-Property Lay 'LayerOn 0);关闭

16 )17

18 (setq n (sslength ss) i 0LayLst nil)19 (repeat n20 (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_ALLON48 ;;;简化命令：LL49 (defun c:yx_lay_allon( /lay layers)50 (Setq Layers (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument)'Layers))51 (vlax-forLay Layers52 (Vlax-Put-Property Lay 'LayerOn -1 )

53 )54

55 (princ "\n-全部图层已打开!")56 (princ)57 )58

59

60 ;;;锁定选取外图层61 ;;;完整命令：YX_LAY_LOCKSELL62 ;;;简化命令：LK63 (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 (ifss69 (progn70 (Setq Layers (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument)'Layers))71 (vlax-forLay Layers72 (Setq LayName (Vlax-Get Lay 'Name ))

73 (sk_layerLock LayName T);锁定74 )75

76 (setq n (sslength ss) i 0LayLst nil)77 (repeat n78 (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_ALLUNLOCK106 ;;;简化命令：UK107 (defun c:yx_lay_allunlock( /lay layers)108 (Setq Layers (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument)'Layers))109 (vlax-forLay Layers110 (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_LN122 ;简化命令：LN123 (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 (whileflag133 (setq ss (ssget '((0 . "LINE,*POLYLINE,CIRCLE,ARC,ELLIPSE,SPLINE"))))

134 (ifss135 (progn136 (setq n (sslength ss) i 0 sumLen 0)137 (repeat n138 (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 (progn149 (setq flag nil)150 )151 )152 )153

154 (setq sigmaLen 0)155

156 (ifLenLst157 (progn158 (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_CTY177 ;简化命令：YL178 (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 (progn185 (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&RadiusLst194 (function (lambda (e1 e2)195 (

197 (setq radiusLst (mapcar 'cadr obj&RadiusLst))

198 ;;;归并199 (setq i 0)200 (if (> (length radiusLst) 1)201 (progn202 (repeat (1-(length radiusLst))203 (if (< (abs (- (nth i radiusLst) (nth (1+ i) radiusLst))) 1e-8)204 (progn205 (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 (progn216 ;;;字母的显示方式217 (setq szPrefixFlag (vl-registry-read "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "PrefixFlag"))218 (ifszPrefixFlag219 nil220 (progn221 (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)]: "))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 (cond241 ((= 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_Num266 ;;;圆右上角的编号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_CDE361 ;简化命令：CD362 ;功能：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 n373 (setq ename (ssname ss i))374 (setq oname (vlax-ename->vla-objectename))375 (setq txt (vla-get-TextOverride oname))376

377 (cond378 ((= 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 repeat392

393 (princ "\nKN工具箱--检查标注测量值是否被修改")394 (princ "\n->被修改测量值的标注其文字将被改成1号颜色(红色)!")395 (princ "\n->可能被修改测量值的标注其文字将被改成6号颜色(洋红色)!")396 (if (and (= k 0) (= k1 0))397 (progn398 (princ "\n->没有标注测量值被修改!")399 )400 (progn401 (if (> k 0)402 (progn403 (setq str (strcat "\n->共有" (itoa k) "个标注可能被修改"))404 (princ str)405 )406 )407 (if (> k1 0)408 (progn409 (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_OU423 ;简化命令：YU424 ;此命令只适用于直线、多段线、圆弧、圆、椭圆、样条曲线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 (progn434 (setq strOffsetBilateralDistance "6")435 (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "OffDis" "6")436 )437 )438 (setq str (strcat "\n->请输入偏移双边距离 :"))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 (progn454 (setq ename (ssname ss 0))455 (setq oname (vlax-ename->vla-objectename))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 (progn463 (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)] :"))469 (initget "Bend Center No")470 (setq x (getkword str))471 (if (=x nil)472 (progn473 (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 (progn485 (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 progn494 );end if (= x "Bend")495

496 (if (= x "Center")497 (progn498 (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 progn505 );end if (= x "Center")506

507 );end progn508 );end if (=ss nil)509

510 );end while

511

512 (Berni_End)513 (princ)514 );end defun c:yx_ou515

516

517 ;智能中心线518 ;完整命令：YX_CEN519 ;简化命令：YN520 ;只适用于两条直线、圆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 /=nil529 (setq strCenterLineLayer "bend")530 (setq strCenterLineLayer1 "center")531

532 (setq n (sslength ss))533 (setq ss1 (ssadd) ss2 (ssadd))534

535 (setq i 0ssnamexRetLst nil)536 (repeat n537 (setq ename (ssname ss i))538 (setq entType (cdr (assoc 0(entget ename))))539

540 (cond541 ((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"));center560 ;;;///////////////////////////////////////////////////561

562

563 (setq i 0)564 (repeat circleNum565 (setq ename (ssname ss2 i))566 (setq oname (vlax-ename->vla-objectename))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 nil584 (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-objectename0))590 (setq oname1 (vlax-ename->vla-objectename1))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 (progn602 (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)]: "))610 (setq x (fy_GetABC str '("B" "C") strCenterLineLay))

611 (if (= x "B")612 (progn613 (setq centerLineLay strCenterLineLayer)614 (yx_CreateLayer centerLineLay 1 "CENTER");bend615 )616 )617 (if (= x "C")618 (progn619 (setq centerLineLay strCenterLineLayer1)620 (yx_CreateLayer centerLineLay 1 "CENTER");center621 )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 (ifp5635 (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 (progn659 (setq ang3 (- (max ang1 ang2) (* 2pi)))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 (ifp55675 (progn;延长一条线有交点p55676 (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 1lst3))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 1lst3))696 (setq ang1 (angle p5 d3))697 (setq ang2 (angle p5 d4))698 )699 );end cond700

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 (progn706 (setq ang3 (- (max ang1 ang2) (* 2pi)))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 1lst3))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 1lst3))741 (setq ang1 (angle p5 d3))742 (setq ang2 (angle p5 d4))743 )744 );end cond745

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 (progn752 (setq ang3 (- (max ang1 ang2) (* 2pi)))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 );延长一条线有交点p55764 (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 (progn782 (setq ang3 (- (max ang1 ang2) (* 2pi)))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 (progn801 (setq p5 (inters p5 p6 p1 p4 nil))802 (setq p6 (inters p5 p6 p2 p3 nil))803 )804 (progn805 (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 ifp5820 );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 /=nil827 );end ifss828

829 (Berni_End)830 (princ)831 );end defun c:yx_cen832

833

834 (defun fy_makeline(pt1 pt2);生成一条line835 ;;参数：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 (iflay845 (progn846 (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 obj855 )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 0norm)864 cp (trans cp 0norm)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 nil876 (progn877 (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 nil894 (progn895 (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 nil912 (progn913 (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 nil930 (progn931 (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 nil948 (progn949 (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 nil966 (progn967 (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 nil984 (progn985 (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 nil993 (progn994 (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 create998

999 ;;;名称:BF-List-ReplaceIndex1000 ;;;说明:按索引替换列表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-num1016 ;;;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 l21023 (cons1024 (list1025 (setq tmp1 (car lst))1026 (- (length lst) (length (setq tmp (vl-remove tmp1 lst)))))1027 l2)1028 lst tmp1029 )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 (foreachstr Lst1059 (setq return (strcat returnDelimiter str))1060 );_end of foreach

1061 (substr return 2)1062 );_end of defun1063

1064 ;;;函数名称:BF-AssocList-Keys1065 ;;;函数说明:返回关联表的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_layerLock1074 ;;;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 (progn1081 (setq obj (vlax-ename->vla-objecten))1082 (ifflag1083 (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-objectobj)1088 )1089 )1090 )1091

1092 (defun yx_LtypeInit( /file str yx_file)1093 (if (tblsearch "Ltype" "Center")1094 nil1095 (progn1096 (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 init1126

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 list1141 );end setq1142 (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 0Berni_s_Lst))1158 (setvar "cmdecho" (nth 1Berni_s_Lst))1159 (setvar "clayer" (nth 2Berni_s_Lst))1160 (setvar "textstyle" (nth 3Berni_s_Lst))1161 (setvar "cecolor" (nth 4Berni_s_Lst))1162 (command "dimstyle" "r" (nth 5Berni_s_Lst))1163 (setvar "plinewid" (nth 6Berni_s_Lst))1164 (setvar "attdia" (nth 7Berni_s_Lst))1165 (setvar "PICKSTYLE" (nth 8Berni_s_Lst))1166 (setvar "PEDITACCEPT" (nth 9Berni_s_Lst))1167 (setvar "dynmode" (nth 10Berni_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)