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
    For Each prop In obj.Properties
      strPropertyName = prop.Name
      Set li = mlvw.ListItems.Add _
        (, strPropertyName, strPropertyName)
      li.SubItems(1) = CStr(prop.Value)
    Next  ' Property
  End With
  
  Exit Sub

ProcError:
  Select Case Err.Number
    Case 3251, 3219, 3267
      ' property can't be read in this manner
      ' continue
      Resume Next
    Case 438
      ' object doesn't support this property or method
      ' this is a collection object
      Exit Sub
    Case Else
      ' something else, raise it again
      Err.Raise _
        Err.Number, _
        Err.Source, _
        Err.Description, _
        Err.HelpFile, _
        Err.HelpContext
  End Select