Copy Autocad Text to Excel using VBA

[Krishna]

Hi,

This is Krishna....can any one help me how to Copy Autocad Text to Excel using VBA

[fixo]

Hi,

This is Krishna....can any one help me how to Copy Autocad Text to Excel using VBA

This one will be copy selected text to existing Excel file



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
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'


~'J'~

[Krishna]

Thanks for the code

[vipulgos]

Dear all,
sorry to start with root level. The code you mentioned was copied in tools>macro>macros in ACAD 2004. But it stops at "dim xlbook as workbook"
with the error as with the error message as under:
Compile Error:
User-Defined Type not defined
What is going wrong.

Is the macro you mentioned is to be copied in excel vba?
i have tried that too, same result
I have the Microsoft excel library checked. in excel

[fixo]

Dear all,
sorry to start with root level. The code you mentioned was copied in tools>macro>macros in ACAD 2004. But it stops at "dim xlbook as workbook"
with the error as with the error message as under:
Compile Error:
User-Defined Type not defined
What is going wrong.

Is the macro you mentioned is to be copied in excel vba?
i have tried that too, same result
I have the Microsoft excel library checked. in excel
This is a typo

Use these lines instead

Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object

~'J'~

[vipulgos]

Now it stops at xlSheet.Columns.HorizontalAlignment = xlHAlignLeft
I also tried with xlSheet.Columns.HorizontalAlignment = xlLeft
Next I tried by removing that line as a whole. It worked.
it ran as under:
Command: _vbarun
Select objects: Specify opposite corner: 137 found
137 were filtered out.After that message appeared as Done.
But nothing found in Testfile.xlsWhat's going wrong on my side?

[vipulgos]

it in fact know only dtext command, i realised

[fixo]

Now it stops at xlSheet.Columns.HorizontalAlignment = xlHAlignLeft
I also tried with xlSheet.Columns.HorizontalAlignment = xlLeft
Next I tried by removing that line as a whole. It worked.
it ran as under:
Command: _vbarun
Select objects: Specify opposite corner: 137 found
137 were filtered out.After that message appeared as Done.
But nothing found in Testfile.xlsWhat's going wrong on my side?

Change all Excel constants on numeric values
1. Open any Excel file
2. Go to VBA editor with Alt+F11
3. Open Immediate window
4. Type there excel constant you need with question
mark at front of
i.e.:

?xlleft

then press Enter

-4131 <==you will get this numeric value

the same way for all xl-constants you used

HTH

~'J'~

[jmitch77]

Is there a way to get just the text of the Multiline text? I get all of the code that goes along with the text. Ex. Text. Text. Text.\P More Text. More Text. Also if the Text is Underlined etc it includes the code %%U. Can these be removed somehow?
Thanks!
jmitch

[fixo]

Is there a way to get just the text of the Multiline text? I get all of the code that goes along with the text. Ex. Text. Text. Text.\P More Text. More Text. Also if the Text is Underlined etc it includes the code %%U. Can these be removed somehow?
Thanks!
jmitch

Upload the sample drawing here (A2008 or earlier) in zipped form
Not clearly enough for me that you talking about formatted mtext

~'J'~