Solved: Another AutoCad to Excel Question

Sorry guys I have tried a lot of scripts from all over the internet including here and always seem to catch errors or other problems. I need to get Parts Lists from AutoCad 2008 Drawings to Excel. I attached an example of how we make parts lists to this post. Everything should be in PaperSpace and in Mtext format.

My idea of how it should work would be.
1.) run the macro from autocad
2.) select the part list
3.) export the text to Excel
4.) save the excel file as the same name as the drawing file

Sorry for asking what seems to be answered all over the internet I just cant seem to get anything to work for me.

Where are you having problems? Could you post some code that seems to work and describe the problems?

I have written a bom editor (in model space) that "works", but I don't like the way it interfaces with excel, it is very slow and I don't have a slow machine :(

Quote:

---

Originally Posted by KennyJ

Sorry guys I have tried a lot of scripts from all over the internet including here and always seem to catch errors or other problems. I need to get Parts Lists from AutoCad 2008 Drawings to Excel. I attached an example of how we make parts lists to this post. Everything should be in PaperSpace and in Mtext format.

My idea of how it should work would be.
1.) run the macro from autocad
2.) select the part list
3.) export the text to Excel
4.) save the excel file as the same name as the drawing file

Sorry for asking what seems to be answered all over the internet I just cant seem to get anything to work for me.

---

This should get you started just add the part
to save Excel file as you want

Code:

---


Sub ExportBOMTable()
    Dim oSset As AcadSelectionSet
    Dim oEnt As AcadEntity
    Dim oText As AcadMText
    Dim eCnt As Integer
    Dim iCnt As Integer
    Dim rCnt As Integer
    Dim iNdx As Integer
    Dim jNdx As Integer
    Dim insPnt() As Double
    Dim fcode(0) As Integer
    Dim fData(0) As Variant
    Dim dxfcode, dxfdata
    Dim setName As String
    fcode(0) = 0
    fData(0) = "MTEXT"
    dxfcode = fcode
    dxfdata = fData
    setName = "$TEXT$"
    MsgBox "Select desired piece of table" & vbNewLine & _
    "by window selection w/o very lower row"
    rCnt = InputBox(vbNewLine & vbNewLine & "Enter number of columns" & vbNewLine & _
    "Press enter to set default: ", "Number Of Columns", "4")
    For i = 0 To ThisDrawing.SelectionSets.Count - 1
          If ThisDrawing.SelectionSets.Item(i).Name = setName Then
              ThisDrawing.SelectionSets.Item(i).Delete
              Exit For
          End If
    Next i
    Set oSset = ThisDrawing.SelectionSets.Add(setName)
    oSset.SelectOnScreen dxfcode, dxfdata
    iCnt = oSset.Count
    ReDim SelPnt(0 To iCnt - 1, 0 To 3) As Variant
    eCnt = 0
    For Each oEnt In oSset
          Set oText = oEnt
          insPnt = oText.InsertionPoint
          SelPnt(eCnt, 0) = insPnt(0)
          SelPnt(eCnt, 1) = insPnt(1)
          SelPnt(eCnt, 2) = insPnt(2)
          SelPnt(eCnt, 3) = oText.TextString
          eCnt = eCnt + 1
    Next oEnt
    Dim collPts As Collection
    Set collPts = New Collection
    ReDim sortpnt(0 To (iCnt - 1), 0 To 2) As Variant
    sortpnt = ColSort(SelPnt, 2) '<--sort by X
    ReDim tmpsort(0 To rCnt - 1, 0 To UBound(sortpnt, 2)) As Variant
    Dim itmArr As Variant
    eCnt = 0
    For iCnt = 0 To UBound(sortpnt, 1) Step rCnt
    iNdx = 0
    Do While iNdx < rCnt
    For jNdx = 0 To UBound(sortpnt, 2)
    tmpsort(iNdx, jNdx) = sortpnt(eCnt, jNdx)
    Next
    eCnt = eCnt + 1
    iNdx = iNdx + 1
    Loop
    itmArr = ColSort(tmpsort, 1)
    collPts.Add itmArr, "Row" & CStr(iCnt)
    Next
    Dim collTxt As Collection
    Set collTxt = New Collection
    icol = UBound(sortpnt, 2)
          For iNdx = 1 To collPts.Count
          For jNdx = 0 To UBound(tmpsort, 1)
          collTxt.Add collPts.Item(iNdx)(jNdx, icol)
          Next
          Next
    '===================== excel part ============'
 
    Dim xlApp As Excel.Application
    Dim xlBook As Workbook
    Dim xlSheet As Worksheet
    Dim strFilePath As String
    '//strFilePath = ThisDrawing.Path & "\Bom.xls"
    On Error Resume Next
    Err.Clear
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
          Err.Clear
          Set xlApp = CreateObject("Excel.Application")
          If Err <> 0 Then
              MsgBox "Cannot start Excel", vbExclamation
              End
          End If
    End If
    xlApp.Visible = True
    '//Set xlBook = xlApp.Workbooks.Open(strFilePath)
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    On Error GoTo Err_control
    Dim irow As Long
    irow = collTxt.Count \ rCnt
    jNdx = 1
    icol = UBound(sortpnt, 2)
    With xlSheet
          .Range("A:A").NumberFormat = "@"
          For iNdx = 1 To collTxt.Count Step rCnt
          jNdx = 1
              .Cells(irow, jNdx) = collTxt.Item(iNdx)
              .Cells(irow, jNdx + 1) = collTxt.Item(iNdx + 1)
              .Cells(irow, jNdx + 2) = collTxt.Item(iNdx + 2)
              .Cells(irow, jNdx + 3) = collTxt.Item(iNdx + 3)
              irow = irow - 1
          Next iNdx
 
.Columns.AutoFit
.UsedRange.Select
With Selection
.Font.color = vbBlue
.Interior.ColorIndex = 35
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlHAlignLeft
.Range("1:1").Font.Bold = True
.Range("1:1").Font.color = vbRed
End With
End With
Err_control:
MsgBox Err.Description
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' written by Fatty T.O.H. (c)2006 * all rights removed '
' SourceArr - two dimensional array                    '
' iPos - column number to sort (starting from 1)      '
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Function ColSort(SourceArr As Variant, iPos As Integer) As Variant
    Dim Check As Boolean
    ReDim tmpArr(UBound(SourceArr, 2)) As Variant
    Dim iCount As Integer
    Dim jCount As Integer
    Dim nCount As Integer
    iPos = iPos - 1
    Check = False
    Do Until Check
          Check = True
          For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
              If SourceArr(iCount, iPos) > SourceArr(iCount + 1, iPos) Then
                    For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
                        tmpArr(jCount) = SourceArr(iCount, jCount)
                        SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
                        SourceArr(iCount + 1, jCount) = tmpArr(jCount)
                        Check = False
                    Next
              End If
          Next
    Loop
    ColSort = SourceArr
End Function

---

~'J'~

I get an error. Is there any setting up i need to do? I think I might have tried this macro before and did'nt understand how to get it to run.:doh:

'===================== excel part ============'

Dim xlApp As Excel.Application

Error:

"User-defined type not defined"

Quote:

---

Originally Posted by KennyJ

I get an error. Is there any setting up i need to do? I think I might have tried this macro before and did'nt understand how to get it to run.:doh:

'===================== excel part ============'

Dim xlApp As Excel.Application

Error:

"User-defined type not defined"

---

Code:

---


Request reference to Microsoft Excel XX.0 Object Library
nothing else

---

~'J'~

Well, it ran for me so I'm going to guess that your VBAIDE options are set
to Break On All Errors.
Change it to Break on Unhandled Errors and see what happens.

~'J'~

It ran fine for me after I added the reference to excel.

Quote:

---

Originally Posted by Fatty

Code:

---


Request reference to Microsoft Excel XX.0 Object Library
nothing else

---

~'J'~

---

This shows up red in my VBA editor and doesn't compile. And I am set to Break on Unhandled Errors.

What the line of code is shows up in red?

~'J'~

Yes. Am I supposed to copy and paste the line you put above into my editor? or is there more to it than that?

thank you and sorry for the rookie questions but my job has me on mission impossible trying to extract 1000s of these Boms and I dont want to do it all manually.

Can you upload your working drawing with table here?
Just remove from all unused stuffs for this programm
I mean blocks, title blocks, company information etc.
I'll try to write the complete project on weekends

~'J'~

I attached an example of our Bom to my original post. That is everything minus the drawing and block.

Hi KennyJ,
In the VBAIDE (where the code is LOL) pick Tolls->References then in the dialog box the pops up scroll down until you find "Microsoft Excel 11.0 Object Library" and select the checkbox beside it. This will allow the code that Fatty has posted to run without error. The attached file has the references selected for this project, in case you are not sure how to do what I have described. If you need futher help let us know.

Quote:

---

Originally Posted by KennyJ

Yes. Am I supposed to copy and paste the line you put above into my editor? or is there more to it than that?

thank you and sorry for the rookie questions but my job has me on mission impossible trying to extract 1000s of these Boms and I dont want to do it all manually.

---

Better yet to add all references and
then compile all things into one project
(create DVB file)
After you close drawing just click Ok when
the messagebox will appears and then create project
with desired name, say ExportBOM or so
Sorry for my poor english, I never learned them :)

~'J'~

Quote:

---

Originally Posted by Tommy

Hi KennyJ,
In the VBAIDE (where the code is LOL) pick Tolls->References then in the dialog box the pops up scroll down until you find "Microsoft Excel 11.0 Object Library" and select the checkbox beside it. This will allow the code that Fatty has posted to run without error. The attached file has the references selected for this project, in case you are not sure how to do what I have described. If you need futher help let us know.

---

This worked perfect! :thumb

Thank all of you for helping me now I can get to work...:doh:

kenny j can u send me also that code? or any sample of your autocad file which can be imported to excel? thanks in advance...

Quote:

---

Originally Posted by KennyJ

I get an error. Is there any setting up i need to do? I think I might have tried this macro before and did'nt understand how to get it to run.:doh:

'===================== excel part ============'

Dim xlApp As Excel.Application

Error:

"User-defined type not defined"

---