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

1 (vl-load-com)2

3 ;;;关闭选取外图层4 ;;;完整命令：YX_LAY_OFFSELO5 ;;;简化命令：LF6 (defun c:yx_lay_offselo( /ename i lay layers laylst layname n obj ss str tmplaynamelst)7 (Berni_Start)8 (princ "\nKN工具箱--关闭选取以外的图层")9 (princ "\n->请选取不要关闭图层的对象或 :")10 (setq ss (ssget))11 (ifss12 (progn13 (Setq Layers (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument)'Layers))14 (vlax-forLay Layers15 (Vlax-Put-Property Lay 'LayerOn 0);关闭

16 )17

18 (setq n (sslength ss) i 0LayLst nil)19 (repeat n20 (setq ename (ssname ss i))21 (setq obj (Vlax-Ename->Vla-Object ename))22 (Setq LayName (Vlax-Get obj 'Layer ))

23 (setq LayLst (cons LayName LayLst))24 (setq i (1+i))25 )26 (setq tmpLayNameLst (BF-list-item-num LayLst))27 (setq LayLst (BF-AssocList-Keys tmpLayNameLst))28 (setq LayLst (vl-sort LayLst '

29 (setq i 0)30 (repeat (length LayLst)31 (Setq LayName (nth i LayLst))32 (setq obj (Vlax-Invoke-Method Layers 'Item LayName ))

33 (Vlax-Put-Property obj 'LayerOn -1)

34 (setq i (1+i))35 )36 (Setq str (StrUnParse LayLst ","))37 (setq str (strcat "\n->没有关闭的图层为:"str))38 (princ str)39 )40 )41 (Berni_End)42 (princ)43 )44

45

46 ;;;打开全部图层47 ;;;完整命令：YX_LAY_ALLON48 ;;;简化命令：LL49 (defun c:yx_lay_allon( /lay layers)50 (Setq Layers (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument)'Layers))51 (vlax-forLay Layers52 (Vlax-Put-Property Lay 'LayerOn -1 )

53 )54

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

59

60 ;;;锁定选取外图层61 ;;;完整命令：YX_LAY_LOCKSELL62 ;;;简化命令：LK63 (defun c:yx_lay_locksell( /ename i lay layers laylst layname n obj ss str tmplaynamelst)64 (Berni_Start)65 (princ "\nKN工具箱--锁定选取以外的图层")66 (princ "\n->请选取不要锁定图层的对象或 :")67 (setq ss (ssget))68 (ifss69 (progn70 (Setq Layers (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument)'Layers))71 (vlax-forLay Layers72 (Setq LayName (Vlax-Get Lay 'Name ))

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

76 (setq n (sslength ss) i 0LayLst nil)77 (repeat n78 (setq ename (ssname ss i))79 (setq obj (Vlax-Ename->Vla-Object ename))80 (Setq LayName (Vlax-Get obj 'Layer ))

81 (setq LayLst (cons LayName LayLst))82 (setq i (1+i))83 )84 (setq tmpLayNameLst (BF-list-item-num LayLst))85 (setq LayLst (BF-AssocList-Keys tmpLayNameLst))86 (setq LayLst (vl-sort LayLst '

87 (setq i 0)88 (repeat (length LayLst)89 (Setq LayName (nth i LayLst))90 (sk_layerLock LayName nil);解锁91 (setq i (1+i))92 )93 (vla-regen (vla-get-activedocument (vlax-get-acad-object)) 1)94 (Setq str (StrUnParse LayLst ","))95 (setq str (strcat "\n->没有锁定的图层为:"str))96 (princ str)97 )98 )99 (Berni_End)100 (princ)101 )102

103

104 ;;;解锁全部图层105 ;;;完整命令：YX_LAY_ALLUNLOCK106 ;;;简化命令：UK107 (defun c:yx_lay_allunlock( /lay layers)108 (Setq Layers (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument)'Layers))109 (vlax-forLay Layers110 (Setq LayName (Vlax-Get Lay 'Name ))

111 (sk_layerLock LayName nil);解锁112 )113 (vla-regen (vla-get-activedocument (vlax-get-acad-object)) 1)114 (princ "\n->全部图层已解锁!")115 (princ)116 )117

118

119 ;计算多线条的总长度120 ;仅适用于直线、多段线、圆、圆弧、椭圆、样条曲线121 ;完整命令：YX_LN122 ;简化命令：LN123 (defun c:yx_ln( /clip_bord curveobj flag htm i lenlst n sigmalen ss str sumlen tmplen)124 (Berni_Start)125

126 (princ "\nKN工具箱--计算多线条的总长度")127 (princ "\n->请选取要计算长度的线条或 :")128 (setq htm (vlax-create-object "htmlfile"))129 (setq Clip_Bord (Vlax-Get-Property (Vlax-Get htm 'ParentWindow)'ClipboardData))130

131 (setq flag T LenLst nil)132 (whileflag133 (setq ss (ssget '((0 . "LINE,*POLYLINE,CIRCLE,ARC,ELLIPSE,SPLINE"))))

134 (ifss135 (progn136 (setq n (sslength ss) i 0 sumLen 0)137 (repeat n138 (setq curveObj (vlax-ename->vla-object(ssname ss i)))139 (setq tmpLen (vlax-curve-getdistatparam curveObj (vlax-curve-getendparam curveObj)))140 (setq sumLen (+sumLen tmpLen))141 (setq i (1+i))142 )143 (setq LenLst (cons sumLen LenLst))144 (Vlax-Invoke Clip_Bord 'SetData "text" (rtos sumLen 2 4))

145 (setq str (strcat "\n->总共选取了" (itoa n) "个线条,总长度=" (rtos sumLen 2 4) "长度已复制到了粘贴板！"))146 (princ str)147 )148 (progn149 (setq flag nil)150 )151 )152 )153

154 (setq sigmaLen 0)155

156 (ifLenLst157 (progn158 (setq i 0)159 (repeat (length LenLst)160 (setq sigmaLen (+sigmaLen (nth i LenLst)))161 (setq i (1+i))162 )163 )164 )165

166 (Vlax-Invoke Clip_Bord 'SetData "text" (rtos sigmaLen 2 4))

167 (setq str (strcat "\n->本次命令一共测量长度:" (rtos sigmaLen 2 4) "总长度已复制到了粘贴板！"))168 (princ str)169

170 (Berni_End)171 (princ)172 )173

174

175 ;圆坐标列表176 ;完整命令：YX_CTY177 ;简化命令：YL178 (defun c:yx_cty(/ ss i obj&radiuslst ename obj radius e2 e1 radiuslst radius&numlst tabbasept szprefixflag str x textstyofcurdimsty dimscaleofcurdimsty textheightofcurdimsty scalefactoroftextstyofcurdimsty k radius_i diameter_i radius_i_num szalphabeticprefix szdiameter_i txtename txtobjname j center_k anothercornerpt p1 p2 lineename midpt)179 (Berni_Start)180

181 (princ "\nKN工具箱--圆坐标列表")182 (princ "\n->请选取要做列表的圆或 :")183 (if (setq ss (ssget '((0 . "CIRCLE"))))

184 (progn185 (setq i 0 obj&RadiusLst nil)186 (repeat (sslength ss)187 (setq eName (ssname ss i))188 (setq obj (Vlax-Ename->Vla-Object eName))189 (Setq radius (Vlax-Get obj 'Radius ))

190 (setq obj&RadiusLst (append obj&RadiusLst (list (list obj radius))))191 (setq i (1+i))192 )193 (setq obj&RadiusLst (vl-sort obj&RadiusLst194 (function (lambda (e1 e2)195 (

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

198 ;;;归并199 (setq i 0)200 (if (> (length radiusLst) 1)201 (progn202 (repeat (1-(length radiusLst))203 (if (< (abs (- (nth i radiusLst) (nth (1+ i) radiusLst))) 1e-8)204 (progn205 (setq radiusLst (BF-List-ReplaceIndex radiusLst (1+i) (nth i radiusLst)))206 )207 )208 (setq i (1+i))209 )210 )211 )212 (setq radius&NumLst (BF-list-item-num radiusLst))213

214 (if (setq tabBasePt (getpoint "\n->请指定表基点或 :"))215 (progn216 ;;;字母的显示方式217 (setq szPrefixFlag (vl-registry-read "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "PrefixFlag"))218 (ifszPrefixFlag219 nil220 (progn221 (setq szPrefixFlag "1")222 (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "PrefixFlag" "1")223 )224 )225 (setq str (strcat "\n指定字母的显示方式 [A, B, C(1)/a, b, c(2)]: "))226 (setq x (fy_GetABC str '("1" "2") szPrefixFlag))

227 (vl-registry-write "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD\\Yx_Zrw" "PrefixFlag"x)228

229 (setq textStyOfCurDimSty (getvar "dimtxsty"));当前标注样式中设置的文字的文字样式230 (setq dimScaleOfCurDimSty (getvar "dimscale"));当前标注样式中设置的全局比例231 (setq textHeightOfCurDimSty (getvar "dimtxt"));当前标注样式中设置的文字的文字高度232 (setq textHeightOfCurDimSty (* textHeightOfCurDimSty dimScaleOfCurDimSty));当前标注样式中设置的文字的文字高度*当前标注样式中设置的全局比例233 (setq scaleFactorOfTextStyOfCurDimSty (cdr (assoc 41 (tblsearch "style"textStyOfCurDimSty))));当前标注样式中设置的文字的文字样式的宽度比例234 (setq i 0 k 0)235 (repeat (length radius&NumLst)236 (setq radius_i (car (nth i radius&NumLst)))237 (setq diameter_i (* radius_i 2.0))238 (setq radius_i_Num (cadr (nth i radius&NumLst)))239 ;;;字母前缀240 (cond241 ((= x "1")242 (setq szAlphabeticPrefix (chr (+ i 65)))243 )244 ((= x "2")245 (setq szAlphabeticPrefix (chr (+ i 97)))246 )247 )248 ;;;直径249 (setq szDiameter_i (rtos diameter_i 2 2))250 (setq txtEname (entmakex (list '(0 . "TEXT") (cons 40 textHeightOfCurDimSty) (cons 1 szDiameter_i) (cons 41 scaleFactorOfTextStyOfCurDimSty)'(10 0 0 0))))251 (setq txtObjName (Vlax-Ename->Vla-Object txtEname))252 (Vlax-Put-Property txtObjName 'StyleName textStyOfCurDimSty)

253 (Vlax-Put-Property txtObjName 'Color 42 )

254 (Vlax-Put-Property txtObjName 'Alignment 4 );中间

255 (Vlax-Put-Property txtObjName 'TextAlignmentPoint (vlax-3D-point (+ (car tabBasePt) (* 12.5 textHeightOfCurDimSty)) (- (cadr tabBasePt) (* 0.75 textHeightOfCurDimSty) (* (1+ i) (* 1.5 textHeightOfCurDimSty)))) )

256 ;;;表格编号257 (setq txtEname (entmakex (list '(0 . "TEXT") (cons 40 textHeightOfCurDimSty) (cons 1 szAlphabeticPrefix) (cons 41 scaleFactorOfTextStyOfCurDimSty)'(10 0 0 0))))258 (setq txtObjName (Vlax-Ename->Vla-Object txtEname))259 (Vlax-Put-Property txtObjName 'StyleName textStyOfCurDimSty)

260 (Vlax-Put-Property txtObjName 'Color 42 )

261 (Vlax-Put-Property txtObjName 'Alignment 4 )

262 (Vlax-Put-Property txtObjName 'TextAlignmentPoint (vlax-3D-point (+ (car tabBasePt) (* 6.5 textHeightOfCurDimSty)) (- (cadr tabBasePt) (* 0.75 textHeightOfCurDimSty) (* (1+ i) (* 1.5 textHeightOfCurDimSty)))) )

263

264 (setq j 0)265 (repeat radius_i_Num266 ;;;圆右上角的编号267 (setq center_k (vlax-get (car (nth k obj&RadiusLst)) 'center))

268 (setq txtEname (entmakex (list '(0 . "TEXT") (cons 40 textHeightOfCurD