高仿某工具箱的几个命令

   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)

 

上一篇:【2019-2020春学期】数据库作业15:第六章: 关系数据理论


下一篇:洛谷 P2195 HXY造公园 题解