PDA

View Full Version : Use Excel to Read Autocad's text and import it to execl



klover
06-12-2008, 10:30 PM
Hi all,

I'm new to autocad vba programming. i was just wondering how do you import autocad's text in the drawings to excel using excel VBA.
Preferably the text that is normally in a table format. :help



cheers :beerchug:

fixo
06-15-2008, 05:15 AM
Hi klover and welcome on board
Try this one, add this code into Excel



Option Explicit
' Request reference to AutoCAD 2XXX Object Library
' (your current Acad version library)
Sub TableToExcel()
Dim rCnt As Long
Dim iNdx As Long
Dim lngRow As Long
Dim lngCol As Long
Dim oent As AcadEntity
Dim tbl As AcadTable
Dim pt As Variant
Dim row As Long
Dim col As Long
Dim collTxt As New Collection
Set collTxt = New Collection

'===================== AutoCAD part follows here============'
' uses the early binding
Dim acApp As AcadApplication
Dim adoc As AcadDocument
Dim xlSheet As Worksheet
Dim strFilePath As String
Set xlSheet = Worksheets("Table") '<-- change Excel sheet name to your suit
' Ken Puls's technic
On Error Resume Next
Err.Clear
Set acApp = GetObject(, "AutoCAD.Application")
If Err <> 0 Then
Err.Clear
Set acApp = CreateObject("AutoCAD.Application")
If Err <> 0 Then
MsgBox "Cannot start AutoCAD", vbExclamation
End
End If
End If
On Error GoTo 0
On Error GoTo Err_Control
acApp.Visible = True
strFilePath = "C:\TABLES.DWG" '<-- change the full path to your drawing here
Set adoc = acApp.Documents.Open(strFilePath, True)
DoEvents

adoc.Utility.GetEntity oent, pt, vbCrLf & "Select table:"
If TypeOf oent Is AcadTable Then
Set tbl = oent
End If
With tbl
For row = 0 To .Rows - 1
ReDim tmp(0 To .Columns - 1)
For col = 0 To .Columns - 1
tmp(col) = .GetText(row, col)
Next col
collTxt.Add tmp
Next
End With

On Error GoTo Err_Control
rCnt = UBound(collTxt.Item(1))
iNdx = 1
'===================== Excel part follows here============'
With xlSheet
.Range("A:A").NumberFormat = "@"
For lngRow = 1 To collTxt.Count
For lngCol = 1 To rCnt + 1
.Cells(lngRow, lngCol) = collTxt.Item(lngRow)(lngCol - 1)
iNdx = iNdx + 1
Next
Next
End With

adoc.Close , False
acApp.Quit
Set adoc = Nothing
Set acApp = Nothing
DoEvents
xlSheet.Activate
MsgBox "Merge cells manually"
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub


~'J'~

klover
06-15-2008, 05:04 PM
Hi klover and welcome on board
Try this one, add this code into Excel



Option Explicit
' Request reference to AutoCAD 2XXX Object Library
' (your current Acad version library)
Sub TableToExcel()
Dim rCnt As Long
Dim iNdx As Long
Dim lngRow As Long
Dim lngCol As Long
Dim oent As AcadEntity
Dim tbl As AcadTable
Dim pt As Variant
Dim row As Long
Dim col As Long
Dim collTxt As New Collection
Set collTxt = New Collection

'===================== AutoCAD part follows here============'
' uses the early binding
Dim acApp As AcadApplication
Dim adoc As AcadDocument
Dim xlSheet As Worksheet
Dim strFilePath As String
Set xlSheet = Worksheets("Table") '<-- change Excel sheet name to your suit
' Ken Puls's technic
On Error Resume Next
Err.Clear
Set acApp = GetObject(, "AutoCAD.Application")
If Err <> 0 Then
Err.Clear
Set acApp = CreateObject("AutoCAD.Application")
If Err <> 0 Then
MsgBox "Cannot start AutoCAD", vbExclamation
End
End If
End If
On Error GoTo 0
On Error GoTo Err_Control
acApp.Visible = True
strFilePath = "C:\TABLES.DWG" '<-- change the full path to your drawing here
Set adoc = acApp.Documents.Open(strFilePath, True)
DoEvents

adoc.Utility.GetEntity oent, pt, vbCrLf & "Select table:"
If TypeOf oent Is AcadTable Then
Set tbl = oent
End If
With tbl
For row = 0 To .Rows - 1
ReDim tmp(0 To .Columns - 1)
For col = 0 To .Columns - 1
tmp(col) = .GetText(row, col)
Next col
collTxt.Add tmp
Next
End With

On Error GoTo Err_Control
rCnt = UBound(collTxt.Item(1))
iNdx = 1
'===================== Excel part follows here============'
With xlSheet
.Range("A:A").NumberFormat = "@"
For lngRow = 1 To collTxt.Count
For lngCol = 1 To rCnt + 1
.Cells(lngRow, lngCol) = collTxt.Item(lngRow)(lngCol - 1)
iNdx = iNdx + 1
Next
Next
End With

adoc.Close , False
acApp.Quit
Set adoc = Nothing
Set acApp = Nothing
DoEvents
xlSheet.Activate
MsgBox "Merge cells manually"
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub

~'J'~


Thanks for the reply..ill give it a try and let you know the out come. thanks again.

rajatds31
02-21-2020, 03:15 AM
fixo Sir, Please update VBA, for export text with co-ordinates