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)