子过程求函数未定义GerTextUnformatString不知哪里出问题了

17721201944

Sub 读取到excel文字A()
Dim a As String
Dim objMText As AcadMText
Dim objTEXT As AcadText
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim h As Integer
Dim hi As Integer
Dim ptPick As Variant
On Error Resume Next
ThisDrawing.Utility.GetEntity objMText, ptPick
a = GetTextUnformatString(objMText.TextString)
If Err.Number = "13" Then GoTo BB
BB:
ThisDrawing.Utility.GetEntity objTEXT, ptPick
a = GetTextUnformatString(objMText.TextString)
MsgBox GerTextUnformatString(objTEXT.TextSing)
objTEXT.Delete
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
     MsgBox "Excel应用程序没有运行!"
     Exit Sub
End If
Set xlSheet = xlApp.ActiveSheet
xlSheet.Cells(1, 5) = "=SUM(R[1]C:R[599]C,1)"
  MsgBox GetMTextUnformatString(objMText.TextString)
objMText.Delete
aa:
   h = xlSheet.Cells(1, 5).Value
hi = h + 1
  xlSheet.Cells(hi, 2).Value = a
xlApp.Active
End Sub
Public Function GetMTextUnformatString(MTextString As String) As String
Dim s As String
Dim RE As Object
Set RE = ThisDrawing.Application.GetInterfaceObject("Vbscript.RegExp")
RE.IgnoreCase = True
RE.Global = True
s = MTextString
RE.Pattem = "\\\\"
s = RE.Replace(s, Chr(1))
RE.Pattem = "\\{"
s = RE.Replace(s, Chr(2))
RE.Pattem = "\\}"
s = RE.Replace(s, Chr(3))
RE.Pattem = "\\pi(.[^;]*);"
s = RE.Replace(s, "")
RE.Pattem = "\\pt(.[^;]*);"
s = RE.Replace(s, "")
RE.Pattem = "\\S(.[^;]*)(\^|#|\\)(.[^;]*);"
s = RE.Replace(s, "$1$3")
RE.Pattem = "(\\F|\\C|\\H|\\T|\\Q|\\W|\\A)(.[^;]*);"
s = RE.Replace(s, "")
RE.Pattem = "(\\L|\\O|\\l|\\o)"
s = RE.Replace(s, "")
RE.Pattem = "\\～"
s = RE.Replace(s, "")
RE.Pattem = "\\P"
s = RE.Replace(s, "")
RE.Pattem = vbLf
s = RE.Replace(s, "")
RE.Pattem = "({})"
s = RE.Replace(s, "")
RE.Pattem = "\x01"
s = RE.Replace(s, "\")
RE.Pattem = "\x02"
s = RE.Replace(s, "{")
RE.Pattem = "\x03"
s = RE.Replace(s, "}")
Set RE = Nothing
GetMTextUnformatString = s
End Function
Public Function GetTextUnformatString(TextString As String) As String
Dim s As String
Dim RE As Object
Set RE = ThisDrawing.Application.GetInterfaceObject("Vbscript.RegExp")
RE.IgnoreCase = True
RE.Global = True
s = TextString
RE.Pattem = "\\\\"
s = RE.Replace(s, Chr(1))
RE.Pattem = "\\{"
s = RE.Replace(s, Chr(2))
RE.Pattem = "\\}"
s = RE.Replace(s, Chr(3))
RE.Pattem = "\\pi(.[^;]*);"
s = RE.Replace(s, "")
RE.Pattem = "\\pt(.[^;]*);"
s = RE.Replace(s, "")
RE.Pattem = "\\S(.[^;]*)(\^|#|\\)(.[^;]*);"
s = RE.Replace(s, "$1$3")
RE.Pattem = "(\\F|\\C|\\H|\\T|\\Q|\\W|\\A)(.[^;]*);"
s = RE.Replace(s, "")
RE.Pattem = "(\\L|\\O|\\l|\\o)"
s = RE.Replace(s, "")
RE.Pattem = "\\～"
s = RE.Replace(s, "")
RE.Pattem = "\\P"
s = RE.Replace(s, "")
RE.Pattem = vbLf
s = RE.Replace(s, "")
RE.Pattem = "({})"
s = RE.Replace(s, "")
RE.Pattem = "\x01"
s = RE.Replace(s, "\")
RE.Pattem = "\x02"
s = RE.Replace(s, "{")
RE.Pattem = "\x03"
s = RE.Replace(s, "}")
Set RE = Nothing
GetTextUnformatString = s
End Function

mikewolf2k

1. 代码关键字打错了。
2. 结果并不精确，应付不了复杂的格式。
3. 我这里有一段代码，比你的精确些，供参考：
Public Function GetMTextUnformatString(MTextString As String) As String
   Dim s As String
      Dim RE As RegExp
       Set RE = New RegExp
       RE.IgnoreCase = True
       RE.Global = True
       s = MTextString

       '替换\\字符

       RE.Pattern = "[url=]\\\\[/url]"

       s = RE.Replace(s, Chr(1))

       '删除堆迭格式

       RE.Pattern = "[url=file://\\S(.[^;]*)(\^|#|\\]\\S(.[^;]*)(\^|#|\\[/url])(.[^;]*);"

       s = RE.Replace(s, "$1$3")
       '删除字体、颜色、字高、字距、倾斜、字宽、对齐格式
       RE.Pattern = "(\\F|\\C|\\H|\\T|\\Q|\\W|\\A)(.[^;]*);"
       s = RE.Replace(s, "")
       '删除下划线、删除线格式
       RE.Pattern = "(\\L|\\O)"
       s = RE.Replace(s, "")
       '删除不间断空格格式
       RE.Pattern = "\\~"

       s = RE.Replace(s, " ")
       '删除换行符格式
       'RE.Pattern = "\\P"
       's = RE.Replace(s, "")
       '删除{}
       RE.Pattern = "({|})"
       s = RE.Replace(s, "")
       '替换回\\字符
       RE.Pattern = "\x01"
       s = RE.Replace(s, "\\")
       Set RE = Nothing
       GetMTextUnformatString = s
End Function

tzfcn

学习了，觉得可以深入研究一下。