CAD二次開發(fā)源碼

文檔供參考，可復制、編制，期待您的好評與關(guān)注！ 有三個CAD二次開發(fā)源碼均能用：源碼1(lisp)程序: CAD文字提取到電子表格，（說明源碼1.把文字提取到1個單元格的而且用n隔開，）源碼2(lisp)程序: 提取標注到文本，源碼3(VBA).提取文字到文本請老師組合成一個lisp程序：要求把CAD的文字和標注都可以分別換行提取到excel中來或文本文檔中1.源碼1(lisp)程序 (defun c:Q2()(setq ffn (getfiled "寫出文件" "" "xls" 1)(princ "n選取文字.")(setq ss (ssget)(setq ff (open ffn "w")(setq i 0)(repeat (sslength ss)(setq ssn (ssname ss i)(setq ssdata (entget ssn)(setq sstyp (cdr (assoc 0 ssdata)(if (or (= sstyp "TEXT") (= sstyp "MTEXT")(progn(setq txt (cdr (assoc 1 ssdata)(princ txt ff)(princ "n" ff)(setq i (1+ i) ? ? ?)(close ff)(princ (strcat "n寫出文件: " ffn)(prin1)?源碼2.提取標注到文本 (defun c:txtout() (setq fln (getstring "n輸出文件名:") (setq fln (strcat fln ".txt") (setq f (open fln "w") (setq a (ssget) (setq n (sslength a) (setq index 0) (repeat n (setq el (entget (ssname a index) (setq index (+ index 1) (setq e (assoc 0 el) (if (= "DIMENSION" (cdr e) (progn (setq txt (cdr (assoc 42 el) (setq txt-1 (rtos txt) (write-line txt-1 f) ) )(close f)源碼3.提取文字到文本Sub mysel()Dim k, i As IntegerDim hjx() As StringDim sset As AcadSelectionSet '定義選擇集對象Dim element As AcadEntity '定義選擇集中的元素對象k = 0'If Not IsNull(ThisDrawing.SelectionSets.Item("ss1") Then'Set sset = ThisDrawing.SelectionSets.Item("ss1")'sset.Delete ' 如果選擇集已存在,則刪除'End IfSet sset = ThisDrawing.SelectionSets.Add("ss1") '新建一個選擇集sset.SelectOnScreen '提示用戶選擇For Each element In sset '在選擇集中進行循環(huán)k = k + 1ReDim Preserve hjx(k)hjx(k) = GetMTextUnformatString(element.TextString)'MsgBox GetMTextUnformatString(hjx(k)Nextsset.Delete'For i = UBound(hjx) To 0 Step -1'MsgBox hjx(i)'NextCall dke(hjx()'sset.Delete '刪除選擇集End SubSub dke(ku() As String) '提出文字輸出到c:123.txtDim i As IntegerSet fs = CreateObject("Scripting.FileSystemObject")'Set a = fs.createtextfile("c:123.txt", True)Set a = fs.OpenTextFile("c:123.txt", 8)For i = UBound(ku) To 0 Step -1a.WriteLine (ku(i)Nexta.CloseSet fs = NothingMsgBox "完成"End SubPublic Function GetMTextUnformatString(MTextString As String) As String Dim s As String Dim RE As Object ' 獲取Regular Expressions組件 Set RE = ThisDrawing.Application.GetInterfaceObject("Vbscript.RegExp") ' 忽略大小寫 RE.IgnoreCase = True ' 搜索整個字符串 RE.Global = True s = MTextString '替換字符 RE.Pattern = "" s = RE.Replace(s, Chr(1) '替換字符 RE.Pattern = "" s = RE.Replace(s, Chr(2) '替換字符 RE.Pattern = "" s = RE.Replace(s, Chr(3) '刪除段落縮進格式 RE.Pattern = "pi(.;*);" s = RE.Replace(s, "") '刪除制表符格式 RE.Pattern = "pt(.;*);" s = RE.Replace(s, "") '刪除堆迭格式 RE.Pattern = "S(.;*)(|#|)(.;*);" s = RE.Replace(s, "$1$3") '刪除字體、顏色、字高、字距、傾斜、字寬、對齊格式 RE.Pattern = "(F|C|H|T|Q|W|A)(.;*);" s = RE.Replace(s, "") '刪除下劃線、刪除線格式 RE.Pattern = "(L|O|l|o)" s = RE.Replace(s, "") '刪除不間斷空格格式 RE.Pattern = "" s = RE.Replace(s, " ") '刪除換行符格式 RE.Pattern = "P" s = RE.Replace(s, "") '刪除換行符格式(針對Shift+Enter格式) RE.Pattern = vbLf s = RE.Replace(s, "") '刪除 RE.Pattern = "(|)" s = RE.Replace(s, "") '替換回,字符 RE.Pattern = "x01" s = RE.Replace(s, "") RE.Pattern = "x02" s = RE.Replace(s, "") RE.Pattern = "x03" s = RE.Replace(s, "") Set RE = Nothing GetMTextUnformatString = sEnd Function5 / 5