TheSwamp
Code Red => VB(A) => Topic started by: ChuckHardin on February 27, 2006, 12:24:51 PM
-
AutoCAD 2004 VB6 activeX control using ACAD Dockable Container
I am having some speed issues with an Outage Management app
Here is the gist of the app if some one has some ideas I will go into
more detail later.
AutoCAD dwg of all wire, poles, services, devices in the field for Distribution Electric Coop
when the control is running in AutoCAD (with a 55mb dwg) it queries a ODBC connection
to our Automated Outage system (it only takes phone calls and shows a flex grid of accounts
that are out of power)
If any accounts are out then it adds them to one of two treeviews
(if the dispatcher has put it in a "Bucket" it goes in treeview2 if not it goes in treeview1)
A "Bucket" is a outage that has been labled
if the keys do not exist in the treeview it adds blocks to the DWG showing where the outage is
it queries another database to get the handle of the pole or service that is out of power and then uses
the handle to get the insertion point for the block
this works great until 400 or more calls come in before the refresh fires (refresh fires once a minute)
They wanted to be able to toggle from Buckets to Unassigned Outages
Buckets View:
If the root nodes expanded=False show a bucket block in the center point of the outage
else show all the Devices and services
Nodes per Call in Example
BucketName
|
>Device
| |
| >Account that called
| >Account that called
>Device
|
>Account that called
Unassigned View:
if the root nodes expanded=false do not show anything for that part of the tree
else show all the Devices and services
Nodes per Call in Example
Substation-Circuit
|
>Device
| |
| >Account that called
| >Account that called
>Device
|
>Account that called
The toggle procedure is really slow when there are 400+ Outage calls
We have had as many as 3500 per day during severe ice storms
Just let me know who is intersted in helping and I will begin posting Code for whatever
you think is needed. warning the code for the whole app is pretty long.
-
Here is some of the code for updating the app. Iit is waht happens every time it refreshes.
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 '<=set the key so it is easy to find the outage
If bKeyExists = False Then
'Add to Treeview and Blocks
If Outage.Bucket <> "" 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
-
Here is most the code for toggling between treeviews
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
-
Chuck,
I have used the tree view a few times and have found it to be quite slow for large data base.
A simple list box would be much faster if you can use that instead.
Another thing to avoid is using a for/next or do/while loop to read a database. Instead transfer the database to an Array in VBA this will be much faster.
also change
For Each objEnt In objSelSet
If TypeOf objEnt Is AcadBlockReference Then
to
For Each objBlockReference In objSelSet ' since you selection set is already blocks references "Inserts"
Have you tested the code to see where your longest delay is ?
Fred Castillo
-
Hi Chuck. Man that's a good sized dwg.
I was wondering if you put a timer on the blockrefs part, if that would be longer than the rest.
If so, perhaps this dwg has a finite qty of blockrefs, in which case you could make a collection of integers (eg modelspace(20077)) to represent the blockrefs and work w/ that. (Like making a class for the dwg.)
intType(1) = 2: varData(1) = BlockAttributeFilter("BUCKET") ->sounds slow
varAtts = objBlkRef.GetAttributes
For intLoop = LBound(varAtts) To UBound(varAtts)-> if the blockrefs are constant use varAtts(number)
There's no exit for (maybe there is only 2 atts)
-
Chuck
To increase the speed while filling a tree view, we do following:
First, just fill the parent level w/o any child levels. Fill the child level on open the selected node.
-
If you do for each objblkref in objselset you can get an annoying error on next objblkref
when filling the tree I have records that come in that have a format of:
MapNumber Device Sub Circuit Bucket Status
So the easiest is to just try to add the node and catch the error
If you turn the treeview visible to false for adding nodes it is fast
there are only 2 atts Bucket and Outage
I think I came up the solution last night
When I create the node and insert the block I need to save the handle to the tag value of the node
Root Node Tag = SCS|handle
Device Node Tag = DEV|handle
Call In Node Tag = LOC|handle
then just do a for each node in treeview
set objent = thisdrawing.HandleToObject(right(Tag,len(tag)-4))
objent.visible = True/False
The search of blocks is what takes so long
It has to search through the same set of blocks every time it hits a new root node.
this way I am only dealing with the blockref for the correct nodes
NO MORE SEARCHING YAAAAAA :-D
Thanks everyone for the replies. I'll let yall know how it functions later.
-
Chuck
One last remark for the moment:
Keep in mind that the tree control has a limit of 32'767 nodes
-
Crap!!
Well hopefully with 2 treeviews I'll be alright.
Guess I need to check out the vbaccelerator treeview control.
-
All issues were worked out to everyones satisfaction.
The speed is great. We tested it with 1000 calls.
About 2000 nodes in the tree views. No problems!!
I changed all block subs and functions to use
Thisdrawing.HandleToObject
Also Check RsTemp.Fields("Location") with OutageCollection
Add If Key doesn't exist
Then For each Outage FindFirst MyOutage.Location
Remove MyOutage if noMatch=True
They love the app now!!!
Thanks yall
-
That's a clipping from one of my works using the tree control (Master data rail switch database). Because of more
than 60'000 datasets, the sub's are filled while click on the node:
(http://www.theswamp.org/screens/index.php?dir=JuergMenzi/&file=SwitchDatabase.gif)
-
Cool we will have to check into it some more when things slow down.