CAD提取文字VBA,有错误
借用别人的源码，但是运行老是提示“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 objTextAs 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
SSet.Select acSelectionSetAll 这句是全选图形内所有图形对象，除非图里全是单行文本，否则肯定会出错，加个过滤应该就行了。 sgwsssxm 发表于 2020-7-22 19:17
SSet.Select acSelectionSetAll 这句是全选图形内所有图形对象，除非图里全是单行文本，否则肯定会出错，加 ...
是的，原来图里有线条，线条删除就好了。谢谢啊，我再研究研究
页:
[1]