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