社区 › VB › 脚本字典帮助

4288 发表于 2005-10-14 13:59:04

脚本字典帮助

我正在尝试根据块属性信息创建一个列表。我现在有一个具有4个属性的块。我希望能够创建一个列表（或列表，取决于块属性标签）。下面是我到目前为止的代码。我还附上了一张图片来帮助演示我最终想做什么。左边的8个块具有相同的名称：TEMP。属性标签是ID、NUMBER、LOCATION和COLOR。
左边的2个列表最终是我想要创建的，但在Excel中。
我现在需要帮助的是获取信息并对其进行排序。
任何帮助都将不胜感激！
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

Matt W
"成为红袜队球迷就像成为最高安全监狱中的120磅重的人。"
**** Hidden Message *****

王乐乐 发表于 2005-10-17 08:40:54

好。。。看起来也许我没有正确发布图像或其他东西。 有时我看到，有时我不知道。
以下是图像的外观：
================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================
================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================
01 03 04 01， 右， 右
， 黄色 右中 右 03， 中心
， 青色黄色 青色黄色 04， 右， 黄色
==========================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================================
我不确定我是否可以用一本字典做到这一点，或者我是否需要两个或更多?!?! 如果有人能为我指出正确的方向，我将不胜感激。
再次感谢！
马特·

大天狼星 发表于 2005-10-17 12:43:24

我很想帮你，但我是洋基队的球迷。
不过，说真的，如果你能等到今晚，我会仔细看看，看看我所做的比较，如果适用的话，我会把它贴出来。在此期间，我相信我们众多常驻天才中的一位能够比我更好地帮助你。

同年同月同日生 发表于 2005-10-20 17:38:37

很像ALCS，对扬基队的球迷来说，这看起来是一个漫长的夜晚。

查看完整版本: 脚本字典帮助