CAD二次开发源码.doc

有三个CAD二次开发源码均能用：源码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 = 0If Not IsNull(ThisDrawing.SelectionSets.Item(ss1) ThenSet sset = ThisDrawing.SelectionSets.Item(ss1)sset.Delete 如果选择集已存在,则删除End IfSet sset = ThisDrawing.SelectionSets.Add(ss1) 新建一个选择集sset.SelectOnScreen 提示用户选择For Each element In sset 在选择集中进行循环k = k + 1ReDim Preserve hjx(k)hjx(k) = GetMTextUnformatString(element.TextString)MsgBox GetMTextUnformatString(hjx(k)Nextsset.DeleteFor i = UBound(hjx) To 0 Step -1MsgBox 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.