Use Excel to Read Autocad's text and import it to execl

[klover]

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.



cheers

[fixo]

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]

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]

fixo Sir, Please update VBA, for export text with co-ordinates