AutoCAD VBA程序---批量插入块源代码.doc

AutoCAD VBA程序-批量插入块源代码Option ExplicitPrivate Sub cmdClear_Click() Me.lstFile.ClearEnd SubPrivate Sub cmdDelete_Click() If lstFile.ListCount = 1 Then If lstFile.ListIndex = -1 Then MsgBox 请选择列表中的图形名称！, vbExclamation, Me.Caption Exit Sub End If lstFile.RemoveItem (lstFile.ListIndex) End IfEnd SubPrivate Sub cmdInsert_Click() Dim i As Integer Dim pntX(0 To 2) As Double With Me pntX(0) = 0#: pntX(1) = 0#: pntX(2) = 0# If .lstFile.ListCount = 0 Then Exit Sub .pbInsert.Value = 0 .pbInsert.Max = .lstFile.ListCount For i = 0 To .lstFile.ListCount - 1 .lstFile.ListIndex = i ThisDrawing.Application.ActiveDocument.ModelSpace.InsertBlock pntX, .lstFile.List(i), 1, 1, 1, 0 .pbInsert.Value = .pbInsert.Value + 1 Next i MsgBox 批量插入块完毕。, vbInformation, .Caption Unload Me End WithEnd SubPrivate Sub cmdOpen_Click() Dim i As Integer Dim Y As Integer Dim Z As Integer Dim fileNames() As String On Error GoTo errHandle With comDlg .CancelError = True .MaxFileSize = 32767 .Flags = cdlOFNHideReadOnly Or cdlOFNAllowMultiselect Or cdlOFNExplorer Or cdlOFNNoDereferenceLinks .DialogTitle = 选择图形文件 .filter = 图形文件(*.dwg)|*.dwg .FileName = .ShowOpen End With comDlg.FileName = comDlg.FileName & Chr(0) Z = 1 For i = 1 To Len(comDlg.FileName) i = InStr(Z, comDlg.FileName, Chr(0) If i = 0 Then Exit For ReDim Preserve fileNames(Y) fileNames(Y) = mID(comDlg.FileName, Z, i - Z) Z = i + 1 Y = Y + 1 Next i Dim count As Integer count = lstFile.ListCount If Y = 1 Then If Not HasItem(fileNames(Y - 1) Then lstFile.AddItem fileNames(Y - 1), count End If Else For i = 1 To Y - 1 If StrComp(Right$(fileNames(0), 1), ) = 0 Then fileNames(i) = fileNames(0) & fileNames(i) Else fileNames(i) = fileNames(0) & & fileNames(i) End If If Not HasItem(fileNames(i) Then lstFile.AddItem fileNames(i), i - 1 + count End If Next i End IferrHandle:End SubPrivate Sub lstFile_DblClick(ByVal Cancel As MSForms.ReturnBoolean) On Error Resume Next MsgBox lstFile.List(lstFile.ListIndex), vbInformation, Me.CaptionEnd SubPrivate Function HasItem(ByVal strDwgName As String) As Boolean HasItem = False Dim i As Integer For i = 0 To lstFile.ListCount - 1 If StrComp(lstFile.List(i), strDwgName, vbTextCompare) = 0 Then HasItem = True Exit Function End If Next iEnd Function计算图幅号源代码计算图幅号Option ExplicitType ArrayData Data() As String Count As IntegerEnd TypePublic Function getSheetNumber(strLat As String, strLon As String, ScaleID As String) As String Dim strLatErr As String, strLonErr As String Dim dblLatErr As String, dblLonErr As String Dim dblLat As Double, dblLon As Double Dim a As String, b As Integer, c As Integer, d As Integer Select Case ScaleID Case A 1:100W strLatErr = 40000: strLonErr = 60000 Case B 1:50W strLatErr = 20000: strLonErr = 30000 Case C 1:25W strLatErr = 10000: strLonErr = 13000 Case D 1:10W strLatErr = 002000: strLonErr = 003000 Case E 1:5W strLatErr = 001000: strLonErr = 001500 Case F 1:2.5W strLatErr = 000500: strLonErr = 000730 Case G 1:1W strLatErr = 000230: strLonErr = 000345 Case H 1:0.5W strLatErr = 000115: strLonErr = 000152.5 Case Else getSheetNumber = 比例尺代码错误 Exit Function End Select dblLatErr = changeToSecond(strLatErr): dblLonErr = changeToSecond(strLonErr) dblLat = changeToSecond(strLat): dblLon = changeToSecond(strLon) a = Chr(64 + Int(dblLat / changeToSecond(40000) + 1) b = Int(dblLon / changeToSecond(60000) + 31) If ScaleID A Then c = changeToSecond(40000) / dblLatErr - Int(mMod(dblLat, changeToSecond(40000) / dblLatErr) d = Int(mMod(dblLon, changeToSecond(60000) / dblLonErr) + 1 getSheetNumber = a & b & ScaleID & Format(c, 000) & Format(d, 000) Else getSheetNumber = a & b End IfEnd FunctionPrivate Function changeToSecond(strDeg As String) As Double Dim intD As Integer, intM As Integer, dblS As Double intD = Int(strOperate(strDeg, ).Data(0) dblS = CDbl(Left(strOperate(strDeg, ).Data(1), Len(strOperate(strDeg, ).Data(1) - 1) intM = Int(Left(strOperate(strDeg, ).Data(1), 2) changeToSecond = intD * 60 + intM + dblS / 60End FunctionPrivate Function strOperate(ByVal strX As String, ByVal strA As String) As ArrayData 分割字符串 Dim i As Integer, j As Integer, k As Integer Dim cnt As Integer, strTemp As String If Trim(strA) Then strX = Trim(strX) strA = Trim(strA) strX = strX & strA For i = 1 To Len(strX) If Mid(strX, i, Len(Trim(strA) = strA Then cnt = cnt + 1 i = i + Len(strA) - 1 End If Next i strOperate.Count = cnt ReDim strOperate.Data(cnt - 1) For j = 1 To Len(strX) If Mid(strX, j, Len(strA) = strA Then strOperate.Data(k) = Left(strX, j - 1) strX = Trim(Right(strX, Len(strX) - Len(strOperate.Data(k) - Len(strA) k = k + 1 j = 0 End If Next j Else strX = Trim(strX) strTemp = strX For i = 1 To Len(strTemp) If Mid(strTemp, i, 1) = Then cnt = cnt + 1 strTemp = Trim(Right(strTemp, Len(strTemp) - i + 1) i = 0 End If Next i strX = strX & strOperate.Count = cnt + 1 ReDim strOperate.Data(cnt) For i = 1 To Len(strX) If Mid(strX, i, 1) = Then strOperate.Data(j) = Left(strX, i - 1) strX = LTrim(Right(strX, Len(strX) - i + 1) j = j + 1 i = 0 End If Next i End IfEnd FunctionPrivate Function mMod(dblF As Double, dblS As Double) As Double Dim intM As Integer intM = Int(dblF / dblS) mMod = dblF - dblS * intMEnd Function Private Sub Form_Load() Text1 = getSheetNumber(392230, 1143345, A) Text1 = Text1 & vbCrLf & getSheetNumber(392230, 1143345, B) Text1 = Text1 & vbCrLf & getSheetNumber(392230, 1143345, C) Text1 = Text1 & vbCrLf & getSheetNumber(392230, 1143345, D) Text1 = Text1 & vbCrLf & getSheetNumber(392230, 1143345, E) Text1 = Text1 & vbCrLf & getSheetNumber(392230, 1143345, F) Text1 = Text1 & vbCrLf & getSheetNumber(392230, 1143345, G) Text1 = Text1 & vbCrLf & getSheetNumber(392230, 1143345, H)End Sub无须下载，将源代码粘贴到写字板里，后缀改为LSP： (defun c:bakk()(setvarcmdecho 0)(setvarosmode 0)(setq zg 0.5)(commandlayer m zdh color red )(setq file-new (getfiled选择数据文件 c: dat 8) (setq file (open file-new a)(princ end file)(princ n file)(close file)(setq file (open file-new r)(setq fb (read-line file)(while (/= end (setq ent-mun (read-line file)(read-line file)(setq ent-point (append (list (+ 100 (* (atof (read-line file) 2)(list (+ 100 (* (atof (read-line file) 2)(list (* (atof (read-line file)(commandtext ml (polar ent-point 0 0.2) zg 0 ent-mun)(command point ent-point)(close file)批量修改字体的LISP;-- 本文件中的 lisp 程序适用于SCS2000，用与其他程序需适当修改(setq a (ssget(0 . TEXT)(setq ns (getstring nEnter new text style:)(setq n (sslength a)(setq index 0)(repeat n (setq b1 (entget(ssname a index) (setq index (+ index 1) (setq e (assoc 7 b1) (setq f (cons (car e) ns) (setq b2 (subst f e b1) (entmod b2) ) ); This program change seleced texts style .2002.4.7计算总长度的程序lisp 软件语言：简体中文 软件类型：国产软件 / 软件源码 / lisp源码运行环境：WinXP, Win2000, NT, WinME, Win9X授权方式：免费软件软件大小：1 KB软件等级：整理时间：2008-5-6开 发 商：下载次数：本日：0本周：0本月：0总计：0软件简介：无须下载，将源代码粘贴到写字板里，后缀改为LSP：(defun C:cd (/ CURVE TLEN SS N SUMLEN) ;来自测绘信息网/(vl-load-com) (setq SUMLEN 0) (setq SS (ssget (0 . CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE,ARC) (setq N 0) (repeat (sslength SS) (setq CURVE (vlax-ename-vla-object (ssname SS N) (setq TLEN (vlax-curve-getdistatparam CURVE (vlax-curve-getendparam CURVE) ) ) (setq SUMLEN (+ SUMLEN TLEN) (setq N (1+ N) ) (print (strcat 总长度: (rtos SUMLEN 2 5) (princ) ) LISP自动建立图层的代码！ 将下列代码粘贴到TXT文件中，将图层换成你想建的，并把后缀改为LSP就可以使用：(defun c:jc()(command layer m t100 c 7 )(command layer m kzd c 6 )(command layer m t200 c 6 )(command layer m t300 c 6 )(command layer m t400 c 1 )(command layer m t500 c 5 )(command layer m t501 c 7 )(command layer m t600 c 4 )(command layer m t700 c 2 )(command layer m t800 c 5 )(command layer m t801 c 7 )(command layer m yzh c 3 )(command layer m gxyz c 5 )(command layer m zmd c 6 )(command layer m dlss c 30 )(command layer m jj c 2 )(command layer m sx c 4 )(command layer m dmtz c 1 )(command layer m gcd c 1 )(command layer m jqx c 1 )(command layer m zb c 3 ) (command layer m tk c 7 )绘工程图框(defun c:gctk( / ty h w dw e pt0 pt1 pt2 pt3 my fa p1 p2 p3 p0 zg fa_dx0 y0xn yn x y i j k x1 y1 wg p4 p5 p6 pt4 pt5 pt6 jdb jds xx chdw chrq chmj) (setq dcl_dtszh (load_dialog jzth.dcl) (if(not(new_dialog tk dcl_dtszh) (exit) (setq w 840 h 594 dw 0 blc 0.5 e 1 ty 0) (hk) (if (/= tfm ) (set_tile gcmc tfm) (mode_tile ds 1) (mode_tile fa 1) (action_tile bl_1 (setq blc 0.5) (action_tile bl_2 (setq blc 1.0) (action_tile bl_3 (setq blc 2.0) (action_tile th_1 (progn (setq h 594 w 840 dw 0) (hk) (action_tile th_2 (progn (setq h 420 w 594 dw 0) (hk) (action_tile th_3 (progn (setq h 297 w 420 dw 0) (hk) (action_tile jc (jch) (action_tile ds (progn (setq dw (atoi (get_tile ds) (hk) (action_tile accept (tk_ok) (action_tile cancel (progn (done_dialog) (setq e 0) (start_dialog) (unload_dialog dcl_dtszh) (setqw (+ w dw) (if (= e 1) (progn (command layer m 901 c 7 ) (setq my nil) (while (/= my Y)(setq pt0 (getpoint n请指定图廓左下角)(setq fa(getangle pt0 n请指定图框的方向)(setq pt1 (polar pt0 fa (* w blc)pt2 (polar pt1 (+ fa (/ pi 2) (* h blc)pt3 (polar pt0 (+ fa (/ pi 2) (* h blc)(command pline pt0 w 0 0 pt1 pt2 pt3 c)(setq my (strcase (getstring n 是否满意? 回车重来, 打 Y 确定)(if (/= my Y) (command erase l ) ) (setq zg (* blc 4) fa_d (/ (* fa 180) pi) (setq pt (polar pt0 fa (* blc 10.0) (setq p0 (polar pt (+ fa (/ pi 2) (* blc 10) p1 (polar p0 fa (* (- w 20) blc) p2 (polar p1 (+ fa (/ pi 2) (* (- h 20) blc) p3 (polar p0 (+ fa (/ pi 2) (* (- h 20) blc) ) (command pline p0 w 0 0 p1 p2 p3 c) (if (= ty 1) (command insert gctk p1 blc blc fa_d chmj chrq (strcat 1: (itoa (fix (+ (* blc 1000) 0.5) chdw tfm) (setq x0 (car p0) y0 (cadr p0) xn x0 yn y0) (setq x0 (min x0 (car p1) y0 (min y0 (cadr p1) (setq x0 (min x0 (car p2) y0 (min y0 (cadr p2) (setq x0 (min x0 (car p3) y0 (min y0 (cadr p3) (setq xn (max xn (car p1) yn (max yn (cadr p1) (setq xn (max xn (car p2) yn (max yn (cadr p2) (setq xn (max xn (car p3) yn (max yn (cadr p3) (setq p4 (polar p1 (+ pi fa) (* blc 100)p5 (polar p4 (+ fa (/ pi 2) (* blc 45)p6 (polar p5 fa (* blc 100) d (list p0 p4 p5 p6 p2 p3) ) (if ( x0 0)(setq fh 0)(setq fh 1) (setq wg (* blc 100)y (* (fi