Export layers of objects to excel

[Thomas.Long]

I have an issue where I have an assembly with the same basic geometry but virtually limitless orientations. There are an unknown number of parts within it, the overall dimension is unknown and the location of the parts within it are unknown because they are different every time the assembly is made.

The assembly is essentially being drawn in autocad the first time but is being created in inventor afterwards and I've written a program that exports the dimensions of the parts (which also lets me know how many of the parts are located within the assembly). However, all of these parts are of a very limited number of sizes, with only the length truly varying. They all have a basic name associated with them and individual inventor part names only vary with length after that as the geometry of the parts are mostly the same.

What I want to do is assign a layer based on the name of the part size. Then, when I go through and export the dimensions, in a second pass I can select the parts (preferably all at once, but one at a time will do) and export the layer names to the excel files in ascending order of their x dimension.

So I'd end up with something similar to this. 

Cell 1     Cell 2
13"        Part A

25"        Part B

38"        Part A

43"        Part C

62"        Part B

This way when I initialize the inventor assembly it will create the parameters for the locations and part sizes already set to what they were in autocad.

Thank you,

Thomas Long

Edit:

If it helps, this is the code currently being used to export the ordinate dimensions.

Option Explicit

Sub Export()

    On Error GoTo ErrorHandler

    If Not Dir("C:\Users\" & Environ$("Username") & "\Documents\RESUME.XLW") = "" Then Kill ("C:\Users\" & Environ$("Username") & "\Documents\RESUME.XLW")
    
    Dim oExcel As Object
    Dim oBook As Object
    Dim oSheet As Object

    'Start a new workbook in Excel
    Set oExcel = CreateObject("Excel.Application")
    Set oBook = oExcel.Workbooks.Add
    Set oSheet = oBook.Worksheets(1)
    
    If Not Dir("H:\Beam Locations.xlsx") = "" Then Kill ("H:\Beam Locations.xlsx")
    
    'Save the Workbook and Quit Excel
    oBook.SaveAs "H:\Beam Locations.xlsx"
    
    Call SortDims("H:\Beam Locations.xlsx", oExcel, oBook, oSheet)
    
    oExcel.Save
    oExcel.Quit
    
    Set oSheet = Nothing
    Set oBook = Nothing
    Set oExcel = Nothing
    
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
ErrorHandler:
    If Err.Number = -2147352567 Then
    
        oExcel.Save
        oExcel.Quit
    
        Set oSheet = Nothing
        Set oBook = Nothing
        Set oExcel = Nothing
    
        Exit Sub
    End If
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    
End Sub
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
Function SortDims(strFileName, xlApp, xlBook, xlSheet)

    On Error GoTo ErrorHandler

    Dim oSset As AcadSelectionSet
    Dim oEnt As AcadEntity
    Dim oDim As AcadDimension
    Dim oDimOrd As AcadDimOrdinate
    Dim eCnt As Integer
    Dim iCnt As Integer
    Dim rCnt As Integer
    Dim iNdx As Integer
    Dim insPnt() As Double
    Dim fcode(0) As Integer
    Dim fdata(0) As Variant
    Dim dxfCode, dxfdata

    fcode(0) = 0: fdata(0) = "DIMENSION"
    dxfCode = fcode
    dxfdata = fdata
    Set oSset = ThisDrawing.PickfirstSelectionSet
    oSset.Clear
    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 oDim = oEnt

        insPnt = oDim.TextPosition
        SelPnt(eCnt, 0) = insPnt(0)
        SelPnt(eCnt, 1) = insPnt(1)
        SelPnt(eCnt, 2) = insPnt(2)

        Set oDimOrd = oEnt
        SelPnt(eCnt, 3) = oDimOrd.Measurement
            
        eCnt = eCnt + 1
    Next oEnt

    ReDim sortPnt(0 To iCnt - 1, 0 To 3) As Variant
    sortPnt = ColSort(SelPnt, 1)

    Dim irow As Long
    irow = 1
    
    With xlSheet
        .Range("A:A").NumberFormat = "0.00#"
        For iNdx = 0 To UBound(sortPnt, 1)
            .Cells(irow, 1) = CStr(sortPnt(iNdx, 3))
            irow = irow + 1
        Next iNdx

    End With
    
    '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
ErrorHandler:
    If Err.Number = -2147352567 Then
    
        xlApp.Save
        xlApp.Quit
    
        Set xlSheet = Nothing
        Set xlBook = Nothing
        Set xlApp = Nothing
    
        Exit Function
    End If
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

End Function
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\


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