[VBA]cad多行文字控制符去除源代码

chixun99

这是受之前的正则公式应用的启发，用vba把所有可能遇到的控制符进行了一个汇总，代码及操作基本能达到要求。需要的朋友们可以自己改为自己的一个函数

2. '***********************************************
   
3. '功能：vba对多行文字控制符进行去除，本函数采用vb标准的字符对比，非正则公式
   
4. '函数名：getMTextUnformatString
   
5. '作者：cx
   
6. '***********************************************
   
7. Public Function GetMTextUnformatString(MTextString As String) As String
   
8.     Dim s As String, st As String
   
9.     Dim s1() As String, s2() As String
   
10.     Dim i As Long, m As Long
    
11.     m = 27
    
12.     ReDim s1(0 To m) As String
    
13.     ReDim s2(0 To m) As String
    
14.     s1(0) = "\":               s2(0) = "\x01"
    
15.     s1(1) = "\{":               s2(1) = "\x02"
    
16.     s1(2) = "\}":               s2(2) = "\x03"
    
17.     s1(3) = "\f*;":             s2(3) = ""
    
18.     s1(4) = "\C*;":             s2(4) = ""
    
19.     s1(5) = "\H*;":             s2(5) = ""
    
20.     s1(6) = "\T*;":             s2(6) = ""
    
21.     s1(7) = "\Q*;":             s2(7) = ""
    
22.     s1(8) = "\W*;":             s2(8) = ""
    
23.     s1(9) = "\A*;":             s2(9) = ""
    
24.     s1(10) = "\p*;":            s2(10) = ""
    
25.     s1(11) = "\S^*;":           s2(11) = "$3$1"
    
26.     s1(12) = "\S*;":            s2(12) = "$2$1"
    
27.     s1(13) = "\S*^;":           s2(13) = "$2$2"
    
28.     s1(14) = "\P":              s2(14) = vbCrLf
    
29.     s1(15) = "\~":              s2(15) = ""
    
30.     s1(16) = "\L":              s2(16) = ""
    
31.     s1(17) = "\l":              s2(17) = ""
    
32.     s1(18) = "\O":              s2(18) = ""
    
33.     s1(19) = "\o":              s2(19) = ""
    
34.     s1(20) = "\K":              s2(20) = ""
    
35.     s1(21) = "\k":              s2(21) = ""
    
36.     s1(19) = "\o":              s2(19) = ""
    
37.     s1(20) = "\K":              s2(20) = ""
    
38.     s1(21) = "\k":              s2(21) = ""
    
39.     s1(22) = "{":               s2(22) = ""
    
40.     s1(23) = "^}":              s2(23) = ""
    
41.     s1(24) = "}":               s2(24) = ""
    
42.     s1(25) = "\x01":            s2(25) = ""
    
43.     s1(26) = "\x02":            s2(26) = "{"
    
44.     s1(27) = "\x03":            s2(27) = "}"
    
45.     'Dim RE As Object
    
46.     'Set RE = ThisDrawing.Application.GetInterfaceObject("VBscript.RegExp")
    
47.     'RE.IgnoreCase = True
    
48.     'RE.Globa = True
    
49.     Dim k As Long, k1 As Long
    
50.     Dim SE As Variant
    
51.     Dim st1 As String
    
52.     s = MTextString: k1 = Len(s)
    
53.     For i = 0 To m
    
54.         Do
    
55.             k = k1
    
56.             st = StrMatch(s, s1(i))
    
57.             If InStr(1, s2(i), "$") > 0 Then
    
58.                 SE = Split(s2(i), "$")
    
59.                 st1 = Mid(st, SE(1) + 1, Len(st) - SE(2) - SE(1))
    
60.             Else
    
61.                 st1 = s2(i)
    
62.             End If
    
63.             If InStr(1, s, st) > 0 Then s = Replace(s, st, st1)
    
64.             k1 = Len(s)
    
65.         Loop Until k1 = k
    
66.         'Debug.Print s
    
67.     Next i
    
68.     'Set RE = Nothing
    
69.     GetMTextUnformatString = s
    
70. End Function
    
71. 
    
72. Private Function StrMatch(Str As String, ss As String)
    
73. '查str字符串中，匹配ss通配符的子串并返回
    
74. Dim s As String, st As String
    
75.     s = "*?": st = ss
    
76. Dim i As Long, j As Long, k As Long
    
77. Dim aSt As Variant
    
78. 
    
79.     For i = 1 To Len(s)
    
80.         Select Case Mid(s, i, 1)
    
81.         Case "*"
    
82.             If InStr(1, ss, "*") > 0 Then
    
83.                 aSt = Split(ss, "*")
    
84.                 j = InStr(1, Str, aSt(0))
    
85.                 If j > 0 Then
    
86.                     st = Mid(Str, j, InStr(j, Str, aSt(1)) - j + 1)
    
87.                 End If
    
88.             End If
    
89.         Case "?"
    
90.             If InStr(1, ss, "?") > 0 Then
    
91.                 aSt = Split(ss, "?")
    
92.                 j = InStr(1, Str, aSt(0))
    
93.                 If j > 0 Then
    
94.                     st = Mid(Str, j, InStr(j, Str, aSt(1)) - j + 1)
    
95.                 End If
    
96.             End If
    
97.         Case Else
    
98. 
    
99.         End Select
    
100.     Next i
     
101.     StrMatch = st
     
102. End Function
     
103. 
     
104. Sub m2t()
     
105.     Dim mt As AcadEntity
     
106.     Dim pnt As Variant
     
107.     Dim Str As String
     
108.     ThisDrawing.Utility.GetEntity mt, pnt, "getMtext:"
     
109.     Str = mt.TextString
     
110.     'Debug.Print Str
     
111.     Str = GetMTextUnformatString(Str)
     
112.     MsgBox Str
     
113. End Sub
     

'***********************************************<br /> '功能：vba对多行文字控制符进行去除，本函数采用vb标准的字符对比，非正则公式<br /> '函数名：getMTextUnformatString<br /> '作者：cx<br /> '***********************************************<br /> Public Function GetMTextUnformatString(MTextString As String) As String<br />     Dim s As String, st As String<br />     Dim s1() As String, s2() As String<br />     Dim i As Long, m As Long<br />     m = 27<br />     ReDim s1(0 To m) As String<br />     ReDim s2(0 To m) As String<br />     s1(0) = "\":               s2(0) = "\x01"<br />     s1(1) = "\{":               s2(1) = "\x02"<br />     s1(2) = "\}":               s2(2) = "\x03"<br />     s1(3) = "\f*;":             s2(3) = ""<br />     s1(4) = "\C*;":             s2(4) = ""<br />     s1(5) = "\H*;":             s2(5) = ""<br />     s1(6) = "\T*;":             s2(6) = ""<br />     s1(7) = "\Q*;":             s2(7) = ""<br />     s1(8) = "\W*;":             s2(8) = ""<br />     s1(9) = "\A*;":             s2(9) = ""<br />     s1(10) = "\p*;":            s2(10) = ""<br />     s1(11) = "\S^*;":           s2(11) = "$3$1"<br />     s1(12) = "\S*;":            s2(12) = "$2$1"<br />     s1(13) = "\S*^;":           s2(13) = "$2$2"<br />     s1(14) = "\P":              s2(14) = vbCrLf<br />     s1(15) = "\~":              s2(15) = ""<br />     s1(16) = "\L":              s2(16) = ""<br />     s1(17) = "\l":              s2(17) = ""<br />     s1(18) = "\O":              s2(18) = ""<br />     s1(19) = "\o":              s2(19) = ""<br />     s1(20) = "\K":              s2(20) = ""<br />     s1(21) = "\k":              s2(21) = ""<br />     s1(19) = "\o":              s2(19) = ""<br />     s1(20) = "\K":              s2(20) = ""<br />     s1(21) = "\k":              s2(21) = ""<br />     s1(22) = "{":               s2(22) = ""<br />     s1(23) = "^}":              s2(23) = ""<br />     s1(24) = "}":               s2(24) = ""<br />     s1(25) = "\x01":            s2(25) = ""<br />     s1(26) = "\x02":            s2(26) = "{"<br />     s1(27) = "\x03":            s2(27) = "}"<br />     'Dim RE As Object<br />     'Set RE = ThisDrawing.Application.GetInterfaceObject("VBscript.RegExp")<br />     'RE.IgnoreCase = True<br />     'RE.Globa = True<br />     Dim k As Long, k1 As Long<br />     Dim SE As Variant<br />     Dim st1 As String<br />     s = MTextString: k1 = Len(s)<br />     For i = 0 To m<br />         Do<br />             k = k1<br />             st = StrMatch(s, s1(i))<br />             If InStr(1, s2(i), "$") > 0 Then<br />                 SE = Split(s2(i), "$")<br />                 st1 = Mid(st, SE(1) + 1, Len(st) - SE(2) - SE(1))<br />             Else<br />                 st1 = s2(i)<br />             End If<br />             If InStr(1, s, st) > 0 Then s = Replace(s, st, st1)<br />             k1 = Len(s)<br />         Loop Until k1 = k<br />         'Debug.Print s<br />     Next i<br />     'Set RE = Nothing<br />     GetMTextUnformatString = s<br /> End Function<br /> <br /> Private Function StrMatch(Str As String, ss As String)<br /> '查str字符串中，匹配ss通配符的子串并返回<br /> Dim s As String, st As String<br />     s = "*?": st = ss<br /> Dim i As Long, j As Long, k As Long<br /> Dim aSt As Variant<br /> <br />     For i = 1 To Len(s)<br />         Select Case Mid(s, i, 1)<br />         Case "*"<br />             If InStr(1, ss, "*") > 0 Then<br />                 aSt = Split(ss, "*")<br />                 j = InStr(1, Str, aSt(0))<br />                 If j > 0 Then<br />                     st = Mid(Str, j, InStr(j, Str, aSt(1)) - j + 1)<br />                 End If<br />             End If<br />         Case "?"<br />             If InStr(1, ss, "?") > 0 Then<br />                 aSt = Split(ss, "?")<br />                 j = InStr(1, Str, aSt(0))<br />                 If j > 0 Then<br />                     st = Mid(Str, j, InStr(j, Str, aSt(1)) - j + 1)<br />                 End If<br />             End If<br />         Case Else<br /> <br />         End Select<br />     Next i<br />     StrMatch = st<br /> End Function<br /> <br /> Sub m2t()<br />     Dim mt As AcadEntity<br />     Dim pnt As Variant<br />     Dim Str As String<br />     ThisDrawing.Utility.GetEntity mt, pnt, "getMtext:"<br />     Str = mt.TextString<br />     'Debug.Print Str<br />     Str = GetMTextUnformatString(Str)<br />     MsgBox Str<br /> End Sub<br />

鸽子

沙发先占上, 核心功能比较完善.

229096767

谢谢分享