树视图和 AutoCAD 块的速度问题

Sub UpdateOutages()
Dim rsTemp As DAO.Recordset
Dim rsSSTemp As DAO.Recordset
Dim strSQL As String
Dim MyOutage As clsOutageLocation
Dim strDev As String
Dim ndLocation As MSComctlLib.Node
Dim ndDevice As MSComctlLib.Node
Dim ndBucket As MSComctlLib.Node
Dim intcnt As Integer
On Error GoTo Err_Control
 'STATUS Field Values and Description
 '1        Active Record(Power Is Off)
 '2        Power Restored
 '3        Call Back
 '4        No Response
 '5        Still Out of Power
 '6        Undialable
 '7        Error
 '8        Max Dial
 
 
 strSQL = "Select * from VIEW_RECORDS WHERE [STATUS] = 1 OR [STATUS] = 5 Order by [SUBSTATION],[CIRCUIT],[MAPNUM]"
 Set rsTemp = OpenRSPorche(strSQL)
 'Add Outages to the collection
 Do Until rsTemp.EOF
      Set MyOutage = New clsOutageLocation
      If IsNull(rsTemp.Fields("MAPNUM")) = False Then
           MyOutage.Location = rsTemp.Fields("MAPNUM")
           If Len(rsTemp.Fields("DEVICE")) > 10 Then
                strDev = Left(rsTemp.Fields("DEVICE"), 3) & "-" & Mid(rsTemp.Fields("DEVICE"), 4, 2) & "-" & Mid(rsTemp.Fields("DEVICE"), 6, Len(rsTemp.Fields("DEVICE")) - 5)
           Else
                strDev = IIf(rsTemp.Fields("DEVICE") = " ", "Unknown", rsTemp.Fields("DEVICE"))
           End If
           MyOutage.Device = strDev
           MyOutage.SubCir = IIf(Len(rsTemp.Fields("SUBSTATION")) = 2, rsTemp.Fields("SUBSTATION") & "-0" & rsTemp.Fields("CIRCUIT"), "0" & rsTemp.Fields("SUBSTATION") & "-0" & rsTemp.Fields("CIRCUIT"))
           If IsNull(rsTemp.Fields("BUCKET_NAME")) = False Then
                MyOutage.Bucket = rsTemp.Fields("BUCKET_NAME")
           Else
                MyOutage.Bucket = ""
           End If
           AddOutageToCollection MyOutage, colOutages
      End If
      rsTemp.MoveNext
 Loop
 'check to see if any need to be deleted
 If colOutages Is Nothing Then
      ResetBlockScale
      Timer2.Enabled = False
 Else
      Timer2.Enabled = True
      For Each MyOutage In colOutages
           rsTemp.FindFirst "MAPNUM = '" & MyOutage.Location & "'"
           If rsTemp.NoMatch = True Then
                RemoveOutage MyOutage
                colOutages.Remove MyOutage.Location
           End If
      Next
 End If
 
 If cmdView.Caption = "Click to View Buckets" Then
      TreeView1(0).Visible = True
      If TreeView1(1).Nodes.Count > 0 Then
           cmdView.Enabled = True
           ClearBuckets
           InsertBuckets
           HideBuckets
      Else
           cmdView.Enabled = False
      End If
 Else
      If TreeView1(1).Nodes.Count > 0 Then
           cmdView.Enabled = True
           TreeView1(1).Visible = True
           ClearBuckets
           InsertBuckets
           ShowBuckets
      Else
           cmdView.Enabled = False
           cmdView.Caption = "Click to View Buckets"
           TreeView1(0).Visible = True
      End If
 End If
  
Exit_Here:
 Exit Sub
 
Err_Control:
 Select Case Err.Number
      Case Else
           LogError Err.Number, Err.Description, "UpdateOutages", "OutageTree.ctl"
           Resume Next
 End Select
End Sub
Private Function AddOutageToCollection(Outage As clsOutageLocation, col As Collection) As Boolean
Dim bKeyExists As Boolean
Dim tempOutage As clsOutageLocation
On Error GoTo addOutageToCollection_Error
 
 bKeyExists = False
 col.Add Outage, Outage.Location  ' "" Then
           'Propably need to Add the Blocks in the AddNodeToTree Sub
           AddNodeToTree 1, Outage.Bucket, Outage.Device, Outage.Location, Outage
      Else
           'Propably need to Add the Blocks in the AddNodeToTree Sub
           AddNodeToTree 0, Outage.SubCir, Outage.Device, Outage.Location, Outage
      End If
 Else
      Set tempOutage = col.Item(Outage.Location)
      If tempOutage.Bucket  Outage.Bucket Then
           'delete the old outage in the tree add it to the correct tree and bucket
           RemoveOutage tempOutage
           tempOutage.Bucket = Outage.Bucket
           tempOutage.Device = Outage.Device
           tempOutage.SubCir = Outage.SubCir
           If tempOutage.Bucket  "" Then
                AddNodeToTree 1, tempOutage.Bucket, tempOutage.Device, tempOutage.Location, Outage
           Else
                AddNodeToTree 0, tempOutage.SubCir, tempOutage.Device, tempOutage.Location, Outage
           End If
      End If
 End If
 
ExitHere:
    bKeyExists = False
    On Error GoTo 0
    Exit Function
addOutageToCollection_Error:
    Select Case Err.Number
    Case 457 'the key already exists
        bKeyExists = True
        Resume Next
    Case Else
        LogError Err.Number, Err.Description, "AddOutageToCollection", "OutageTree.ctl"
        Resume ExitHere
    End Select
End Function
Private Sub AddNodeToTree(intTreeIndex As Integer, strSC As String, strDev As String, strLoc As String, Outage As clsOutageLocation)
Dim strBucketKey As String
Dim strDeviceKey As String
Dim strLocKey As String
Dim bKeyExist As Boolean
Dim varInsPnt As Variant
Dim strLocList As String
Dim strAttValue As String
Dim strType As String
Dim rsSSTemp As DAO.Recordset
Dim strHandle As String
Dim blnTreeVisible As Boolean
On Error GoTo Err_Control
 
 strBucketKey = strSC
 strDeviceKey = strSC & strDev
 strLocKey = Outage.Location
 
 'Add Sub-Cir
 TreeView1(intTreeIndex).Nodes.Add Key:=strBucketKey, Text:=strSC
 Set nd = TreeView1(intTreeIndex).Nodes(strBucketKey)
 nd.Tag = "SCS"
 If bKeyExist = False Then
      'Add The Block if it is a bucket
      If Outage.Bucket  "" Then
'           If GetCenter(Outage.Bucket, varInsPnt) = True Then
'                AddBlocks varInsPnt, "OutageCalls", "Flag", Outage.Bucket, Outage.Bucket
'           End If
      Else
           nd.Expanded = True
      End If
 End If
 
 bKeyExist = False
 
 'Add Device
 TreeView1(intTreeIndex).Nodes.Add strSC, tvwChild, strDeviceKey, strDev
 Set nd = TreeView1(intTreeIndex).Nodes(strDeviceKey)
 nd.Tag = "DEV"
 If bKeyExist = False Then
      If Outage.Bucket = "" Then
           nd.Expanded = True
      End If
      'Add The Block
      strLocList = "Select * from SSMap WHERE [Location] LIKE '*" & strDev & "*'"
      strAttValue = strDev
      If InStr(2, strDev, "RC") > 2 Then
           strType = "RC"
      ElseIf InStr(2, strDev, "FU") > 2 Then
           strType = "FU"
      Else
           strType = ""
      End If
      If strType  "" Then
           Set rsSSTemp = OpenRSSSMap(strLocList)
           If rsSSTemp.BOF = False Or rsSSTemp.EOF = False Then
                rsSSTemp.MoveFirst
                strHandle = rsSSTemp.Fields("Handle")
                AddBlocks HandleToInsertionPoint(strHandle), "OutageCalls", strType, strAttValue, strSC
           End If
      End If
 End If
 
 bKeyExist = False
 
 'Add Location
 TreeView1(intTreeIndex).Nodes.Add strSC & strDev, tvwChild, strLocKey, strLoc
 Set nd = TreeView1(intTreeIndex).Nodes(strLocKey)
 nd.Tag = "LOC"
 If bKeyExist = False Then
      If Outage.Bucket = "" Then
           nd.Expanded = True
      End If
      'Add The Block
      strLocList = "Select * from SSMap WHERE [Location] LIKE '*" & strLoc & "*'"
      strAttValue = strLoc
      strType = "SER"
      Set rsSSTemp = OpenRSSSMap(strLocList)
      If rsSSTemp.BOF = False Or rsSSTemp.EOF = False Then
           rsSSTemp.MoveFirst
           strHandle = rsSSTemp.Fields("Handle")
           AddBlocks HandleToInsertionPoint(strHandle), "OutageCalls", strType, strAttValue, strSC
      End If
 End If
 bKeyExist = False
 
Exit_Here:
 Exit Sub
 
Err_Control:
 Select Case Err.Number
      Case 35602
           'Duplicate key is not unique
           bKeyExist = True
           Err.Clear
           Resume Next
     Case Else
           LogError Err.Number, Err.Description, "AddNodeToTree", "OutageTree.ctl"
           Resume Exit_Here
 End Select
 
End Sub
Sub RemoveOutage(Outage As clsOutageLocation)
Dim strDev As String
Dim ndLocation As MSComctlLib.Node
Dim ndDevice As MSComctlLib.Node
Dim ndBucket As MSComctlLib.Node
On Error GoTo Err_Control
 'Remove From Treeview Here and Blocks
 If Outage.Bucket  "" Then
      Set ndLocation = TreeView1(1).Nodes(Outage.Location)
      Set ndDevice = ndLocation.Parent
      If ndDevice.Children = 1 Then
           Set ndBucket = ndDevice.Parent
           If ndBucket.Children = 1 Then
                'Remove Bucket,Device, & Location
                RemoveBucket Outage.Bucket
                RemoveDevice Outage.Device
                RemoveLocation Outage.Location
                TreeDeleteSection 1, ndBucket
           Else
                'Remove Device & Location
                RemoveDevice Outage.Device
                RemoveLocation Outage.Location
                TreeDeleteSection 1, ndDevice
           End If
      Else
           'Remove Location
           RemoveLocation Outage.Location
           TreeDeleteSection 1, ndLocation
      End If
 Else
      Set ndLocation = TreeView1(0).Nodes(Outage.Location)
      Set ndDevice = ndLocation.Parent
      If ndDevice.Children = 1 Then
           Set ndBucket = ndDevice.Parent
           If ndBucket.Children = 1 Then
                'Remove Bucket,Device, & Location
                RemoveDevice Outage.Device
                RemoveLocation Outage.Location
                TreeDeleteSection 0, ndBucket
           Else
                'Remove Device & Location
                RemoveDevice Outage.Device
                RemoveLocation Outage.Location
                TreeDeleteSection 0, ndDevice
           End If
      Else
           'Remove Location
           RemoveLocation Outage.Location
           TreeDeleteSection 0, ndLocation
      End If
 End If
Exit_Here:
 Exit Sub
Err_Control:
 Select Case Err.Number
      Case Else
           LogError Err.Number, Err.Description, "RemoveOutage", "OutageTree.ctl"
           Resume Next
 End Select
End Sub

Private Sub cmdView_Click()
 'Toggles between the treeviews
 Select Case cmdView.Caption
      Case "Click to View Buckets"
           TreeView1(0).Visible = False
           TreeView1(1).Visible = True
           ToggleTrees 0
           cmdView.Caption = "Click to View Unassigned"
      Case "Click to View Unassigned"
           TreeView1(1).Visible = False
           TreeView1(0).Visible = True
           ToggleTrees 1
           cmdView.Caption = "Click to View Buckets"
 End Select
End Sub
Public Sub ToggleTrees(intTreeToShow As Integer)
Dim MyOutage As clsOutageLocation
Dim BucketsOn As Boolean
Dim NodeX As MSComctlLib.Node
Dim intcnt As Integer
Dim intNodecnt As Integer
On Error GoTo Err_Control
 'Maybe do this for each tree
 'Then For each node.parent is nothing
 'Show or Hide blocks by node.text
 For intcnt = 0 To 1
      If TreeView1(intcnt).Nodes.Count > 0 Then
           For intNodecnt = 1 To TreeView1(intcnt).Nodes.Count
                Set NodeX = TreeView1(intcnt).Nodes(intNodecnt)
                If NodeX.Parent Is Nothing Then
                     If intTreeToShow = intcnt Then
                          'Show the blocks
                          If intTreeToShow = 0 Then
                               ShowBlocks NodeX.Text
                          Else
                               If NodeX.Expanded = True Then
                                    'Show the Locations & Devices
                                    ShowBlocks NodeX.Text
                               Else
                                    'Hide the Locations & Devices
                                    HideBlocks NodeX.Text
                               End If
                          End If
                     Else
                          'Hide the Blocks
                          HideBlocks NodeX.Text
                     End If
                End If
           Next
      End If
 Next
 
 If intTreeToShow = 0 Then
      HideBuckets
 End If
' Another way I tried it that was not fast enough 
' If intTreeToShow = 1 Then BucketsOn = True
'
' For Each MyOutage In colOutages
'      If MyOutage.Bucket = "" Then
'           If BucketsOn Then
'                'Hide These
'                HideBlocks MyOutage.SubCir
'           Else
'                'Show These
'                Set NodeX = TreeView1(0).Nodes(MyOutage.SubCir)
'                If NodeX.Expanded = True Then
'                     'Hide the bucket show the Locations & Devices
'                     ShowBlocks MyOutage.SubCir
'                Else
'                     'Show the Bucket hide the Locations & Devices
'                     HideBlocks MyOutage.SubCir
'                End If
'           End If
'      Else
'           If BucketsOn Then
'                'Show These
'                Set NodeX = TreeView1(0).Nodes(MyOutage.Bucket)
'                If NodeX.Expanded = True Then
'                     'Show the Locations & Devices
'                     ShowBlocks MyOutage.Bucket
'                Else
'                     'Hide the Locations & Devices
'                     HideBlocks MyOutage.Bucket
'                End If
'           Else
'                'Hide These
'                HideBlocks MyOutage.Bucket
'           End If
'      End If
' Next
 
ExitHere:
 Exit Sub
 
Err_Control:
 Select Case Err.Number
      Case Else
           LogError Err.Number, Err.Description, "AddOutageToCollection", "OutageTree.ctl"
           Resume ExitHere
 End Select
End Sub
Public Function HideBlocks(strBucket As String) As Boolean
Dim objSelSet As AcadSelectionSet
Dim objEnt As AcadEntity
Dim objBlkRef As AcadBlockReference
Dim intType(0 To 1) As Integer
Dim varData(0 To 1) As Variant
Dim varAtts As Variant
Dim objAttRef As AcadAttributeReference
Dim intLoop As Integer
On Error GoTo Err_Control
 
 Set objSelSet = Thisdrawing.PickfirstSelectionSet
 intType(0) = 0: varData(0) = "INSERT"
 intType(1) = 2: varData(1) = BlockAttributeFilter("BUCKET")
 objSelSet.Select Mode:=acSelectionSetAll, FilterType:=intType, FilterData:=varData
 For Each objEnt In objSelSet
      If TypeOf objEnt Is AcadBlockReference Then
           Set objBlkRef = objEnt
           If objBlkRef.HasAttributes Then
                varAtts = objBlkRef.GetAttributes
                For intLoop = LBound(varAtts) To UBound(varAtts)
                     Set objAttRef = varAtts(intLoop)
                     If objAttRef.TagString = "BUCKET" Then
                          If strBucket = objAttRef.TextString Then
                               If objBlkRef.Name = "Flag" Then
                                    objBlkRef.Visible = True
                               Else
                                    objBlkRef.Visible = False
                               End If
                          End If
                     End If
                Next intLoop
           End If
      End If
 Next
 ACADApp.Update
 Set objSelSet = Nothing
 Set objEnt = Nothing
 Set objBlkRef = Nothing
 HideBlocks = True
Exit_Here:
 Exit Function
Err_Control:
 Select Case Err.Number
      Case Else
           LogError Err.Number, Err.Description, "HideBlocks", "modACAD.bas"
           HideBlocks = False
           Resume Exit_Here
 End Select
End Function
Public Function ShowBlocks(strBucket As String) As Boolean
Dim objSelSet As AcadSelectionSet
Dim objEnt As AcadEntity
Dim objBlkRef As AcadBlockReference
Dim intType(0 To 1) As Integer
Dim varData(0 To 1) As Variant
Dim varAtts As Variant
Dim objAttRef As AcadAttributeReference
Dim intLoop As Integer
Dim interr As Integer
On Error GoTo Err_Control
 
 Set objSelSet = Thisdrawing.PickfirstSelectionSet
 intType(0) = 0: varData(0) = "INSERT"
 intType(1) = 2: varData(1) = BlockAttributeFilter("BUCKET")
 
 objSelSet.Select Mode:=acSelectionSetAll, FilterType:=intType, FilterData:=varData
 For Each objEnt In objSelSet
      If TypeOf objEnt Is AcadBlockReference Then
           Set objBlkRef = objEnt
           If objBlkRef.HasAttributes Then
                varAtts = objBlkRef.GetAttributes
                For intLoop = LBound(varAtts) To UBound(varAtts)
                     Set objAttRef = varAtts(intLoop)
                     If objAttRef.TagString = "BUCKET" Then
                          If strBucket = objAttRef.TextString Then
                               If objBlkRef.Name = "Flag" Then
                                    objBlkRef.Visible = False
                               Else
                                    objBlkRef.Visible = True
                               End If
                          End If
                     End If
                Next intLoop
           End If
      End If
 Next
 ACADApp.Update
 Set objSelSet = Nothing
 Set objEnt = Nothing
 Set objBlkRef = Nothing
 ShowBlocks = True
Exit_Here:
 Exit Function
Err_Control:
 Select Case Err.Number
      Case Else
           LogError Err.Number, Err.Description, "HideBlocks", "modACAD.bas"
           ShowBlocks = False
           Resume Exit_Here
 End Select
End Function
Public Function HideBuckets() As Boolean
Dim objSelSet As AcadSelectionSet
Dim objEnt As AcadEntity
Dim objBlkRef As AcadBlockReference
Dim intType(0 To 1) As Integer
Dim varData(0 To 1) As Variant
Dim varAtts As Variant
Dim objAttRef As AcadAttributeReference
Dim intLoop As Integer
Dim interr As Integer
On Error GoTo Err_Control
 
 Set objSelSet = Thisdrawing.PickfirstSelectionSet
 intType(0) = 0: varData(0) = "INSERT"
 intType(1) = 2: varData(1) = "Flag"
 
 objSelSet.Select Mode:=acSelectionSetAll, FilterType:=intType, FilterData:=varData
 For Each objEnt In objSelSet
      If TypeOf objEnt Is AcadBlockReference Then
           Set objBlkRef = objEnt
           If objBlkRef.Name = "Flag" Then
                objBlkRef.Visible = False
           End If
      End If
 Next
 ACADApp.Update
 Set objSelSet = Nothing
 Set objEnt = Nothing
 Set objBlkRef = Nothing
 HideBuckets = True
Exit_Here:
 Exit Function
Err_Control:
 Select Case Err.Number
      Case Else
           LogError Err.Number, Err.Description, "HideBuckets", "modACAD.bas"
           HideBuckets = False
           Resume Exit_Here
 End Select
End Function
Public Function ShowBuckets() As Boolean
Dim objSelSet As AcadSelectionSet
Dim objEnt As AcadEntity
Dim objBlkRef As AcadBlockReference
Dim intType(0 To 1) As Integer
Dim varData(0 To 1) As Variant
Dim varAtts As Variant
Dim objAttRef As AcadAttributeReference
Dim intLoop As Integer
Dim interr As Integer
On Error GoTo Err_Control
 
 Set objSelSet = Thisdrawing.PickfirstSelectionSet
 intType(0) = 0: varData(0) = "INSERT"
 intType(1) = 2: varData(1) = "Flag"
 
 objSelSet.Select Mode:=acSelectionSetAll, FilterType:=intType, FilterData:=varData
 For Each objEnt In objSelSet
      If TypeOf objEnt Is AcadBlockReference Then
           Set objBlkRef = objEnt
           If objBlkRef.Name = "Flag" Then
                objBlkRef.Visible = True
           End If
      End If
 Next
 ACADApp.Update
 Set objSelSet = Nothing
 Set objEnt = Nothing
 Set objBlkRef = Nothing
 ShowBuckets = True
Exit_Here:
 Exit Function
Err_Control:
 Select Case Err.Number
      Case Else
           LogError Err.Number, Err.Description, "ShowBuckets", "modACAD.bas"
           ShowBuckets = False
           Resume Exit_Here
 End Select
End Function