CAD二次開發(fā)源碼.doc

《CAD二次開發(fā)源碼.doc》由會(huì)員分享，可在線閱讀，更多相關(guān)《CAD二次開發(fā)源碼.doc（5頁珍藏版）》請?jiān)谘b配圖網(wǎng)上搜索。

有三個(gè)CAD二次開發(fā)源碼均能用： 源碼1(lisp)程序: CAD文字提取到電子表格，（說明源碼1.把文字提取到1個(gè)單元格的而且用n隔開，） 源碼2(lisp)程序: 提取標(biāo)注到文本， 源碼3(VBA).提取文字到文本 請老師組合成一個(gè)lisp程序： 要求把CAD的文字和標(biāo)注都可以分別換行提取到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.提取標(biāo)注到文本 (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 Integer Dim hjx() As String Dim 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 If Set sset = ThisDrawing.SelectionSets.Add("ss1") 新建一個(gè)選擇集 sset.SelectOnScreen 提示用戶選擇 For Each element In sset 在選擇集中進(jìn)行循環(huán) k = k + 1 ReDim Preserve hjx(k) hjx(k) = GetMTextUnformatString(element.TextString) MsgBox GetMTextUnformatString(hjx(k)) Next sset.Delete For i = UBound(hjx) To 0 Step -1 MsgBox hjx(i) Next Call dke(hjx()) sset.Delete 刪除選擇集 End Sub Sub dke(ku() As String) 提出文字輸出到c:\123.txt Dim i As Integer Set 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 -1 a.WriteLine (ku(i)) Next a.Close Set fs = Nothing MsgBox "完成" End Sub Public 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 搜索整個(gè)字符串 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)) 刪除段落縮進(jìn)格式 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 = s End Function