CAD提取文字VBA,有错误

linwanglian · 发表于 2020-7-22 14:48:10

借用别人的源码，但是运行老是提示“  Set objText = objEntity”类型不匹配，自己找不到原因。还请高手帮忙看下，怎么修改能够好用。

一下是源码

'函数名:CreateSSet
'描述:接收选择图元,实现过滤
'

Public Function CreateSSet(ByVal SSetName As String) As AcadSelectionSet
Dim SSet As AcadSelectionSet
Dim i As Integer
For i = 0 To ThisDrawing.SelectionSets.Count - 1
      Set SSet = ThisDrawing.SelectionSets.Item(i)
      If StrComp(SSet.Name, SSetName, vbTextCompare) = 0 Then
         SSet.Delete
         Exit For
      End If
Next i
Set CreateSSet = ThisDrawing.SelectionSets.Add(SSetName)
End Function

'函数名:GetTextInsertCoord
'描述:接收一组文本对象,返回一个数组,实现提取文本的字符串,插入点坐标及高程.
'

Public Function GetTextInsertCoord(ByVal ssget As Object)
Dim SSet As AcadSelectionSet
Set SSet = ssget
SSet.Select acSelectionSetAll
Dim lngCount As Long
Dim arrText() As String
Dim txtCount As Long

Dim objEntity As AcadEntity

txtCount = SSet.Count
ReDim arrText(1 To txtCount, 1 To 4)

Dim objText  As AcadText

   For Each objEntity In SSet
      lngCount = lngCount + 1
      Set objText = objEntity

      arrText(lngCount, 1) = objEntity.TextString    '文本字符串值

      With objText
         arrText(lngCount, 2) = Format(.InsertionPoint(0), "0.000000")  'Y值坐标'
         arrText(lngCount, 3) = Format(.InsertionPoint(1), "0.000000") 'X值坐标'
         arrText(lngCount, 4) = Format(.InsertionPoint(2), "0.00")    '高程'
      End With
   Next objEntity

   GetTextInsertCoord = arrText

   Set objEntity = Nothing
   Set objText = Nothing
   Set SSet = Nothing
End Function

'函数名:Initialize_Excel
'描述:接收一个数组,实现将文本的字符串,插入点坐标及高程导入当前打开的EXCEL.
'当没有安装EXCEL时,程序将会出错.

Public Sub Initialize_Excel(ByRef arrText() As String)
Dim xlsApp As Object
Dim wb As Object
Dim sht As Object

Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = True
Set wb = xlsApp.Workbooks.Add()
Set sht = wb.Sheets("Sheet1")
sht.Range("A1").Resize(UBound(arrText), 4) = arrText

sht.Range("B1:C" & UBound(arrText)).NumberFormatLocal = "0.000000"
sht.Range("D1:D" & UBound(arrText)).NumberFormatLocal = "0.00"
sht.Range("A:D").EntireColumn.AutoFit

wb.SaveAs ThisDrawing.Path & "\" & "提取文本坐标.xlsx"

xlsApp.Quit
Set sht = Nothing
Set wb = Nothing
Set xlsApp = Nothing

End Sub

Sub Main()
Dim SSet As AcadSelectionSet
Set SSet = CreateSSet("mySelectionSet")
Dim ArrTextCoordinate() As String

ArrTextCoordinate = GetTextInsertCoord(SSet)
Call Initialize_Excel(ArrTextCoordinate)

MsgBox "导入文本已经完成", , "提示"

Set SSet = Nothing
End Sub

sgwsssxm · 发表于 2020-7-22 19:17:36

SSet.Select acSelectionSetAll 这句是全选图形内所有图形对象，除非图里全是单行文本，否则肯定会出错，加个过滤应该就行了。

linwanglian · 发表于 2020-7-23 14:23:42

sgwsssxm 发表于 2020-7-22 19:17
SSet.Select acSelectionSetAll 这句是全选图形内所有图形对象，除非图里全是单行文本，否则肯定会出错，加 ...

是的，原来图里有线条，线条删除就好了。谢谢啊，我再研究研究

账号		自动登录	找回密码
密码			注册