[编程交流] 将Autocad文本复制到Excel usi

Option Explicit
' Requires:
' Microsoft Excel Object Library
' go to Tools->Options->General Tab and check 'Break on Unhandled Errors'
Const xlFileName As String = "C:\TestFile.xls" '<--change existing file name here
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Sub ExportText()
Dim oSset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim oText As AcadText
Dim i As Long
Dim ftype(0) As Integer
Dim fdata(0) As Variant
ftype(0) = 0: fdata(0) = "TEXT"
Dim dxftype As Variant
Dim dxfdata As Variant
dxftype = ftype
dxfdata = fdata
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Dim xlApp As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim lngRow As Long, lngCol As Long
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set xlApp = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Impossible to run Excel.", vbExclamation
End
End If
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
On Error GoTo Err_Control
         With ThisDrawing.SelectionSets
              While .Count > 0
                   .Item(0).Delete
              Wend
         Set oSset = .Add("$Texts$")
         End With
oSset.SelectOnScreen dxftype, dxfdata
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Open(xlFileName)
Set xlSheet = xlBook.Sheets(1)
xlApp.ScreenUpdating = False
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
lngRow = 1: lngCol = 1
For Each oEnt In oSset
Set oText = oEnt
xlSheet.Cells(lngRow, lngCol).Value = oText.TextString
lngRow = lngRow + 1
Next oEnt
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
xlSheet.Columns.HorizontalAlignment = xlHAlignLeft
xlSheet.Columns.AutoFit
xlApp.ScreenUpdating = True
xlBook.Save
xlBook.Close
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
xlApp.Application.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
MsgBox "Done"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'