cdbexplorer.cls

《VB6数据库开发指南》所有的例程的源码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CDBExplorer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' database object
Dim mdb As Database

' Treeview control objects
Private mtvw As TreeView

' Listview control objects
Private mlvw As ListView

' flag for initialization routine
Private mblnInTVInit As Boolean

Private Enum dbExpNodeType
  ntDatabase = 0
  ntRootCollection = 1
  ntRootObject = 2
  ntObjectCollection = 3
  ntObject = 4
End Enum

Private Sub Class_Terminate()
' clean up
On Error Resume Next

  mdb.Close
  Set mdb = Nothing
  
  Set mtvw = Nothing
  
  Set mlvw = Nothing

End Sub

Private Sub TVInit()
' initialize the treeview

  Dim strDBName As String
  Dim nd As Node

  strDBName = mdb.Name

  ' add db and first level nodes
  With mtvw.Nodes
    .Clear
    Set nd = .Add(, , strDBName, strDBName)
    ' Add the root nodes under the database
    ' a bogus node is added under each to make it expandable
    Set nd = .Add _
      (strDBName, tvwChild, "TableDefs", "TableDefs")
    Set nd = .Add("TableDefs", tvwChild)
    Set nd = .Add _
      (strDBName, tvwChild, "QueryDefs", "QueryDefs")
    Set nd = .Add("QueryDefs", tvwChild)
    Set nd = .Add _
      (strDBName, tvwChild, "Relations", "Relations")
    Set nd = .Add("Relations", tvwChild)
    mblnInTVInit = True
    .Item(strDBName).Expanded = True
    mblnInTVInit = False
  End With

End Sub
Private Sub TVGetTableDefs()

  Dim strTDName As String
  Dim nd As Node
  Dim td As TableDef
  
  With mtvw.Nodes
    ' refresh the collection
    mdb.TableDefs.Refresh
    For Each td In mdb.TableDefs
      ' skip system tables
      If (td.Attributes And dbSystemObject) = 0 Then
        strTDName = td.Name
        ' add the node for the table
        Set nd = .Add _
          ("TableDefs", tvwChild, strTDName, strTDName)
        ' add a bogus node so it can be expanded
        Set nd = .Add(strTDName, tvwChild)
      End If
    Next  ' TableDef
  End With

End Sub
Private Sub TVGetQueryDefs()

  Dim strQDName As String
  Dim nd As Node
  Dim qd As QueryDef

  With mtvw.Nodes
    ' refresh the collection
    mdb.QueryDefs.Refresh
    For Each qd In mdb.QueryDefs
      strQDName = qd.Name
      ' add the node for the query
      .Add "QueryDefs", tvwChild, strQDName, strQDName
      ' add nodes for fields and parameters
      ' add a blank node so it's expandable
      .Add strQDName, tvwChild
    Next  ' QueryDef
  End With

End Sub
Private Sub TVGetRelations()

  Dim strRelName As String
  Dim rel As Relation
  
  With mtvw.Nodes
    ' refresh collection
    mdb.Relations.Refresh
    For Each rel In mdb.Relations
      strRelName = rel.Name
      .Add "Relations", tvwChild, _
        "Relations" & strRelName, strRelName
      ' add a blank child node so that it can be expanded
      .Add "Relations" & strRelName, tvwChild
    Next  ' Relation
  End With

End Sub
Private Sub TVGetTableDefFields(strTableDefName As String)

  Dim fld As Field
  Dim strFieldName As String

  With mtvw.Nodes
    ' refresh collection
    mdb.TableDefs(strTableDefName).Fields.Refresh
    For Each fld In mdb.TableDefs(strTableDefName).Fields
      strFieldName = fld.Name
      .Add strTableDefName & "Fields", tvwChild, _
        strTableDefName & "Fields" & strFieldName, _
        strFieldName
    Next  ' Field
  End With

End Sub
Private Sub TVGetTableDefIndexes(strTableDefName As String)

  Dim idx As Index
  Dim strIndexName As String
  
  With mtvw.Nodes
    ' refresh collection
    mdb.TableDefs(strTableDefName).Indexes.Refresh
    For Each idx In mdb.TableDefs(strTableDefName).Indexes
      strIndexName = idx.Name
      .Add strTableDefName & "Indexes", tvwChild, _
        strTableDefName & "Indexes" & strIndexName, _
        strIndexName
    Next  ' Index
  End With

End Sub
Private Sub TVGetQueryDefFields(strQueryDefName As String)

  Dim fld As Field
  Dim strFieldName As String
  
  With mtvw.Nodes
    ' refresh collection
    mdb.QueryDefs(strQueryDefName).Fields.Refresh
    For Each fld In mdb.QueryDefs(strQueryDefName).Fields
      strFieldName = fld.Name
      .Add strQueryDefName & "Fields", tvwChild, _
        strQueryDefName & "Fields" & strFieldName, _
        strFieldName
    Next  ' Field
  End With

End Sub
Private Sub TVGetQueryDefParameters _
  (strQueryDefName As String)

  Dim param As Parameter
  Dim strParameterName As String
  
  With mtvw.Nodes
    ' refresh collection
    mdb.QueryDefs(strQueryDefName).Parameters.Refresh
    For Each param In _
      mdb.QueryDefs(strQueryDefName).Parameters
      strParameterName = param.Name
      .Add strQueryDefName & "Parameters", tvwChild, _
        strQueryDefName & "Parameters" & strParameterName, _
        strParameterName
    Next  ' Parameter
  End With

End Sub
Private Sub TVGetRelationFields(strRelationName As String)

  Dim fld As Field
  Dim strFieldName As String
  
  With mtvw.Nodes
    ' refresh collection
    mdb.Relations(strRelationName).Fields.Refresh
    For Each fld In mdb.Relations(strRelationName).Fields
      strFieldName = fld.Name
      .Add _
        "Relations" & strRelationName & "Fields", _
        tvwChild, _
        "Relations" & strRelationName & _
          "Fields" & strFieldName, _
        strFieldName
    Next  ' Field
  End With
        
End Sub
Private Function TVGetNodeType(nd As Node) As Long
' Determine where we are in the database
' Can be one of the following:
'   the database
'   one of the root collections:
'     TableDefs, QueryDefs, Relations
'   an object in one of the root collections:
'     TableDef, QueryDef, or Relation
'   one of the object collections:
'     Fields, Indexes, Parameters
'   bottom level object: Field, Index, Parameter
' This works by running an accumlator to determine the "depth"
' in the tree. The depth is represented by the dbExpNodeType
' enumeration in the header section

  Dim lngDepth As Long
  Dim ndParent As Node
  Dim ndRoot As Node

  Set ndRoot = nd.Root
  
  If nd = ndRoot Then
    ' root node
    lngDepth = 0
  Else
    lngDepth = 1
    Set ndParent = nd.Parent
    Do
      If ndParent = ndRoot Then
        ' done
        Exit Do
      Else
        ' move up one level
        lngDepth = lngDepth + 1
        Set ndParent = ndParent.Parent
      End If
    Loop
  End If

  TVGetNodeType = lngDepth

End Function
Private Sub LVInit()
' Initialize the ListView

  Static blnFirstTime As Boolean

  ' set view
  mlvw.View = lvwReport
  
  If Not blnFirstTime Then
    ' setup ColumnHeaders
    With mlvw.ColumnHeaders
      .Clear
      .Add , "Property", "Property"
      .Add , "Value", "Value"
    End With
    mlvw.ColumnHeaders("Value").Width = _
      mlvw.Width - mlvw.ColumnHeaders("Property").Width
    blnFirstTime = True
  End If

End Sub
Private Sub LVListProperties(obj As Object)
' List the properties of an object
' Note: Since every DAO object except for the collections
'   have a properties collection this procedure can be
'   completely generic
'   The error handler traps the collections error
'   This module could be extended to list the members of
'   collections instead of just trapping the error
On Error GoTo ProcError

  Dim prop As Property
  Dim strPropertyName As String
  Dim li As ListItem

  With mlvw
    .ListItems.Clear