《CAD二次開發(fā)源碼》由會員分享，可在線閱讀，更多相關(guān)《CAD二次開發(fā)源碼（5頁珍藏版）》請在裝配圖網(wǎng)上搜索。
1、文檔供參考，可復制、編制，期待您的好評與關(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
2、(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+
3、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 (en
4、tget (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
5、 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.Selecti
6、onSets.Add("ss1") '新建一個選擇集
sset.SelectOnScreen '提示用戶選擇
For Each element In sset '在選擇集中進行循環(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
7、
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.Write
8、Line (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")
'
9、忽略大小寫
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))
10、
'刪除段落縮進格式
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 =
11、 "(\\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, "")
'刪除換行符格式(針
12、對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
5 / 5
CAD二次開發(fā)源碼
