Hope this will get you started
'// SpecialSort.vb
Imports System
Imports System.Collections
Imports System.Diagnostics
Public Class SpecialSort
Public Delegate Function SpecialCompareCallback(ByVal astring _
As String, ByVal bstring As String) As Boolean
Public Shared Sub MySort(ByVal alist As List(Of String()), _
ByVal MyCompare As SpecialCompareCallback)
Dim i, j As Integer
Dim temp As String
Dim bottom As Integer = 0
Dim top As Integer = alist.Count - 1
For i = bottom To (top - bottom)
For j = i + 1 To top
If MyCompare(alist.Item(j)(0), alist.Item(i)(0)) Then
temp = alist.Item(i)(0)
alist.Item(i)(0) = alist.Item(j)(0)
alist.Item(j)(0) = temp
End If
Next j
Next i
End Sub
End Class
Public Class MyCustomCompare
Public Shared Function TheBasicCompare(ByVal astring As String, _
ByVal bstring As String) As Boolean
Return (astring <= bstring)
End Function
End Class
'// CountBlocks.vb
Imports System
Imports System.Collections
Imports System.Diagnostics
Imports Microsoft.Office
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.ApplicationServices.Application
Namespace BlockCommands
Public Class CountBlocks
<CommandMethod("HUH")> _
Public Shared Sub SelectBlocks()
Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
Dim atinfo As List(Of String()) = New List(Of String())
Using db As Database = HostApplicationServices.WorkingDatabase
Using tr As Transaction = db.TransactionManager.StartTransaction
Try
Dim psr As PromptSelectionResult
Dim sset As SelectionSet
Dim oids As ObjectIdCollection
Dim ent As Entity
Dim oid As ObjectId
Dim br As BlockReference
Dim filter(1) As TypedValue
filter(0) = New TypedValue(DxfCode.Start, "INSERT")
filter(1) = New TypedValue(66, 1)
Dim sf As New SelectionFilter(filter)
'Dim opts As PromptSelectionOptions = New PromptSelectionOptions()
'opts.MessageForAdding = ControlChars.CrLf & "Select block instances: "
'psr = ed.GetSelection(opts, sf)
psr = ed.SelectAll(sf)
sset = psr.Value
If sset.Count > 0 Then
ed.WriteMessage(vbCr & "Selected " & sset.Count & " attributed blocks")
oids = New ObjectIdCollection(sset.GetObjectIds)
For Each oid In oids
ent = oid.GetObject(OpenMode.ForRead)
br = CType(ent, BlockReference)
Dim bn As String = br.Name
Dim aids As AttributeCollection = br.AttributeCollection
Dim c As Integer = 0
Dim atlst(aids.Count) As String
atlst(c) = bn
c += 1
For Each aid As ObjectId In aids
Dim atr As AttributeReference = CType(tr.GetObject(aid, OpenMode.ForRead),
AttributeReference)
atlst(c) = atr.TextString
c += 1
Next
atinfo.Add(atlst)
Next
End If
'atinfo.Sort(New ListComparer(SortOrder.Ascending))
SortArray(atinfo)
Dim fn As String = Replace(db.Filename, ".dwg", "-AttExt.xls")
WriteToExcel(atinfo, fn)
'MsgBox("Excel file created: " & fn)
Catch ex As System.Exception
MsgBox(ex.ToString)
End Try
End Using
End Using
End Sub
Public Shared Sub SortArray(ByVal ar As List(Of String()))
Dim MyCallBack As SpecialSort.SpecialCompareCallback
MyCallBack = AddressOf MyCustomCompare.TheBasicCompare
SpecialSort.MySort(ar, MyCallBack)
End Sub
Public Shared Sub WriteToExcel(ByVal atinfo As List(Of String()), ByVal fname As String)
Dim xlApp As Microsoft.Office.Interop.Excel.Application = New
Microsoft.Office.Interop.Excel.ApplicationClass()
xlApp.Visible = True
Try
Dim templObj As [Object] = CType(Microsoft.Office.Interop.Excel.XlWBATemplate.xlWBATWorksheet,
Object)
Dim xlBook As Microsoft.Office.Interop.Excel.Workbook = xlApp.Workbooks.Add(templObj)
xlBook.Activate()
Dim xlSheets As Microsoft.Office.Interop.Excel.Sheets = xlBook.Worksheets
Dim xlSheet As Microsoft.Office.Interop.Excel.Worksheet = CType(xlSheets.Item(1),
Microsoft.Office.Interop.Excel.Worksheet)
xlSheet.Name = "Attributes"
Dim xlRange As Microsoft.Office.Interop.Excel.Range
xlRange = xlSheet.Cells(1, 1)
xlRange.Select()
xlRange.Value2 = "Block Name"
For n As Long = 1 To atinfo(0).Length
xlRange = xlSheet.Cells(1, n + 1)
xlRange.Select()
xlRange.Value2 = "Tag#" & CStr(n)
Next
For r As Long = 0 To atinfo.Count - 1
For c As Long = 0 To atinfo(r).Length - 1
xlRange = xlSheet.Cells(r + 2, c + 1)
xlRange.Select()
xlRange.Value2 = atinfo(r).GetValue(c).ToString
Next
Next
xlSheet.Columns.AutoFit()
xlBook.SaveAs(fname)
xlBook.Close()
xlApp.Quit()
xlSheet = Nothing
xlBook = Nothing
xlApp = Nothing
Catch ex As System.Exception
MsgBox(ex.Source & ex.StackTrace)
End Try
End Sub
End Class
End Namespace
_____________________________________
C6309D9E0751D165D0934D0621DFF27919
