Consulting

Results 1 to 4 of 4

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

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1

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

    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

  2. #2
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    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'~

  3. #3
    Quote Originally Posted by Fatty
    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.

  4. #4
    VBAX Newbie
    Joined
    Feb 2020
    Location
    Mumbai
    Posts
    3
    Location
    fixo Sir, Please update VBA, for export text with co-ordinates

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •