树视图和 AutoCAD 块的速度问题
AutoCAD 2004 VB6 activeX 控件使用 ACAD 可停靠容器我在使用中断管理应用程序时遇到了一些速度问题
这是应用程序的要点，如果有人有一些想法，我将
在稍后进行更详细的介绍。
当控件在 AutoCAD 中运行时，AutoCAD dwg 会查询
与我们的自动中断系统的 ODBC 连接（它仅接听电话并显示断电的帐户的灵活网格
）
如果有任何帐户已中断，则会将它们添加到两个树视图之
一（如果调度程序已将其放在”Bucket“它进入treeview2，如果不是，它进入treeview1）
”Bucket“是一个中断，
如果树视图中不存在键，它就会向DWG添加块，显示中断的位置
，它查询另一个数据库以获取断电的极点或服务的句柄，然后使用
句柄获取块的插入点
，这很好，直到在刷新触发之前有 400 个或更多调用（每分钟刷新一次）
他们希望能够从存储桶切换到未分配的中断
存储桶视图：
如果根节点展开 = False，则在中断的中心点显示存储桶块
，否则
在示例存储桶名称中显示每个调用的所有设备和服务节点
|
>设备
||
| >调用
|的帐户 >调用
>设备
|的
帐户 >调用
未分配视图的帐户：
如果扩展的根节点=false 不显示树的该部分的任何内容
，则在
示例
变电站电路|中显示每个呼叫的所有设备和服务
节点
>设备
||
| >调用
|的帐户 >调用
>设备
|的
帐户 >称为
切换过程的帐户 当有400多个中断呼叫时，
我们每天有多达3500个在严重的冰暴期间每天有多达3500个呼叫
只是让我知道谁在帮助，我将开始发布您认为需要的任何内容的
代码
。
**** Hidden Message ***** 下面是更新应用程序的一些代码。每次刷新都会发生这种情况。
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 = 1 OR = 5 Order by ,,"
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.BucketOutage.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 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 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
以下是在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，
我已经使用过几次树视图，发现它对于大型数据库来说非常慢。
如果可以改用简单的列表框，则列表框会快得多。
要避免的另一件事是使用for/next或do/while循环来读取数据库。 相反，将数据库传输到VBA中的数组，这将快得多。
还更改
对于每个 objEnt 在 objSelSet 如果
TypeOf objEnt 是 AcadBlockReference 然后
到
对于每个 objBlockReference 在 objSelSet 中，因为你的选择集已经是块引用 “Inserts”
你有没有测试过代码，看看你的最长延迟在哪里？
弗雷德·卡斯蒂略
如果您对objselset中的每个objblkref执行此操作，您会在下一个objblkref上得到一个恼人的错误
当填充树时，我有格式为
map number Device Sub Circuit Bucket Status
的记录，因此最简单的方法就是尝试添加节点并捕捉错误
如果您将treeview visible设置为false以添加节点，则速度很快
只有2个atts Bucket和Outage
我想我昨晚创建时想到了解决方案
节点并插入块我需要保存句柄到节点的标签值
根节点Tag = SCS|handle
设备节点Tag = DEV|handle
调用In节点Tag = LOC|handle
然后只需为treeview中的每个节点做一个
set objent = thisdrawing。 HandleToObject(right(Tag，len(Tag)-4))
objent . visible = True/False
块的搜索需要很长时间
每次遇到新的根节点时，它都必须搜索同一组块。
这样，我只处理正确节点的blockref for >不再搜索YAAAAAA
感谢大家的回复。稍后我会让你们知道它是如何运作的。
Chuck
目前的最后一句话:
请记住，树控件有32'767个节点的限制 废话。！
希望有了2个树状视图，我就没事了。
我想我需要检查vb加速器树状视图控件。 所有问题都得到了满意的解决。
速度很好。我们用1000个电话对其进行了测试。
树视图中大约 2000 个节点。没有问题！！
我更改了所有块子和函数以使用
Thisdrawing.HandleToObject
还检查RsTemp.Fields（“Location”）与中断Collection
Add 如果密钥不存在
，那么对于每个中断，请查找First MyOutage。位置
如果noMatch=True，则删除MyOutage
他们现在喜欢该应用程序!!!
谢谢你 这是我使用树控件(主数据轨道开关数据库)的一个作品的剪辑。由于
超过60，000个数据集，点击节点时会填充sub:
太好了，当事情进展缓慢的时候，我们将不得不做更多的检查。
页:
[1]