TheSwamp
Code Red => VB(A) => Topic started by: Guest on October 14, 2005, 01:59:04 PM
-
I'm trying to create a list based on block attribute information. I have a block right now with 4 attributes. I would like to be able to create a list (or lists, depending on the block attribute tags). Below is what I've got so far for code. I've also attached an image to help demonstrate what I'd like to eventually do. The 8 blocks on the left have the same name: TEMP. The attribute tags are ID, NUMBER, LOCATION, and COLOR. The 2 lists on the
left are ultimately what I'm looking to create, but in Excel.
What I need help with right now is obtaining the information and have it sorted.
Any help will be greatly appreciated!
Option Explicit
Public objKeys As Variant
Public objItems As Variant
Public objDict As Dictionary
Public Sub DPW()
Dim ent1 As AcadEntity
Dim ent2 As AcadEntity
Dim entXref As AcadExternalReference
Dim entBlock As AcadBlock
Dim entNestedBlock As AcadBlockReference
Dim varAtts() As AcadAttributeReference
Dim objBlock As AcadBlockReference
Dim ssSet As AcadSelectionSet
Dim FilterType(1) As Integer
Dim FilterData(1) As Variant
Dim obj As AcadEntity
Dim i, x As Integer
Set objDict = New Dictionary
Set ssSet = vbdPowerSet("TEMP")
FilterType(0) = 0
FilterData(0) = "Insert"
FilterType(1) = 2
FilterData(1) = "*TEMP*"
ssSet.Select acSelectionSetAll, , , FilterType, FilterData
x = 1
If ssSet.Count = 0 Then
MsgBox "No blocks were found in this drawing!", vbInformation + vbOKOnly, "Quick Report"
Exit Sub
Else
For Each obj In ssSet
Set objBlock = obj
If obj.HasAttributes Then
varAtts = obj.GetAttributes
For i = LBound(varAtts) To UBound(varAtts)
If UCase$(varAtts(i).TagString) = "ID" Then
If objDict.Exists(varAtts(i).TextString) = False Then
objDict.Add varAtts(i).TextString, 1
Else
objDict.Item(varAtts(i).TextString) = objDict.Item(varAtts(i).TextString) + 1
End If
End If
If UCase$(varAtts(i).TagString) = "NUMBER" Then
If objDict.Exists(varAtts(i).TextString) = False Then
objDict.Add varAtts(i).TextString, 1
Else
objDict.Item(varAtts(i).TextString) = objDict.Item(varAtts(i).TextString) + 1
End If
End If
If UCase$(varAtts(i).TagString) = "LOCATION" Then
If objDict.Exists(varAtts(i).TextString) = False Then
objDict.Add varAtts(i).TextString, 1
Else
objDict.Item(varAtts(i).TextString) = objDict.Item(varAtts(i).TextString) + 1
End If
End If
If UCase$(varAtts(i).TagString) = "COLOR" Then
If objDict.Exists(varAtts(i).TextString) = False Then
objDict.Add varAtts(i).TextString, 1
Else
objDict.Item(varAtts(i).TextString) = objDict.Item(varAtts(i).TextString) + 1
End If
End If
On Error GoTo 0
Next i
End If
Next obj
i = 0
objKeys = objDict.Keys
BubbleSort objKeys
objItems = objDict.Items
Dim filenum As Integer
Dim strLine1 As String
For x = 0 To UBound(objKeys)
Debug.Print objKeys(x) & vbTab & vbTab & objDict(objKeys(x))
i = i + objItems(x)
Next
End If
End Sub
Public Function vbdPowerSet(strName As String) As AcadSelectionSet
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = strName Then
objSelSet.Delete
Exit For
End If
Next
Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
Set vbdPowerSet = objSelSet
End Function
Sub BubbleSort(arr As Variant, Optional descending As Boolean, Optional numEls As Variant)
' Bubble Sort an array of any type
' Author: The VB2TheMax Team
' BubbleSort is especially convenient with small arrays (1,000
' items or fewer) or with arrays that are already almost sorted
'
' NUMELS is the index of the last item to be sorted, and is
' useful if the array is only partially filled.
'
' Works with any kind of array, except UDTs and fixed-length
' strings, and including objects if your are sorting on their
' default property. String are sorted in case-sensitive mode.
'
' You can write faster procedures if you modify the first two lines
' to account for a specific data type, eg.
' Sub BubbleSortS(arr() As Single, Optional descending As Boolean, Optional numEls As Variant)
' Dim value As Single
Dim Value As Variant
Dim Index As Long
Dim firstItem As Long
Dim indexLimit As Long, lastSwap As Long
' account for optional arguments
If IsMissing(numEls) Then numEls = UBound(arr)
firstItem = LBound(arr)
lastSwap = numEls
Do
indexLimit = lastSwap - 1
lastSwap = 0
For Index = firstItem To indexLimit
Value = arr(Index)
If (Value > arr(Index + 1)) Xor descending Then
' if the items are not in order, swap them
arr(Index) = arr(Index + 1)
arr(Index + 1) = Value
lastSwap = Index
End If
Next
Loop While lastSwap
End Sub
(http://www.theswamp.org/lilly_pond/yankee-hater/images/temp.GIF)
Matt W
"Being a Red Sox fan is like being a 120-pound man in a maximum security prison."
-
Okay... It looks like maybe I didn't post the image correctly or something. Sometimes I see, sometimes I don't.
Here's what the image looks like:
==========================================
TEST01 TEST01 TEST01 TEST01
01 02 03 01, LEFT, BLUE
LEFT LEFT RIGHT 02, LEFT, GREEN
BLUE GREEN BLUE 03, RIGHT, BLUE
==========================================
TEST02 TEST02 TEST02 TEST02
01 03 04 01, RIGHT, YELLOW
RIGHT CENTER RIGHT 03, CENTER, CYAN
YELLOW CYAN YELLOW 04, RIGHT, YELLOW
==========================================
The columns on the right are what I'm looking to create from the attribute information (three columns) on the left.
I'm not sure if I can do this with ONE dictionary or if I would need two or more?!?! If someone could point me in the right direction I would really appreciate it.
Thanks again!
Matt W
-
I'd like to help you out but I'm a Yankees fan. :evil:
Seriously though, if you can wait until this evening I'll take a closer look at it and see how what I have compares and post it if it applies. During the interim, I'm sure one of our many resident genius's can help you out better than I can.
-
Much like the ALCS, it looks like a long night for Yankees fans.