database.frm

SQL数据库工具就是一种即可以进行数据浏览、添加、删除和修改等数据库管理操作

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmDatabase 
   Caption         =   "数据库"
   ClientHeight    =   5025
   ClientLeft      =   3630
   ClientTop       =   2895
   ClientWidth     =   3690
   HelpContextID   =   2016146
   Icon            =   "Database.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MDIChild        =   -1  'True
   ScaleHeight     =   5025
   ScaleWidth      =   3690
   ShowInTaskbar   =   0   'False
   Begin VB.ComboBox Combo1 
      Height          =   300
      Left            =   50
      TabIndex        =   1
      Top             =   10
      Width           =   3600
   End
   Begin MSComctlLib.ImageList imlTreePics 
      Left            =   1215
      Top             =   1560
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   6
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Database.frx":014A
            Key             =   "Table"
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Database.frx":025C
            Key             =   "View"
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Database.frx":036E
            Key             =   "Index"
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Database.frx":0480
            Key             =   "Property"
         EndProperty
         BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Database.frx":0592
            Key             =   "Attached"
         EndProperty
         BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Database.frx":06A4
            Key             =   "Field"
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.TreeView tvDatabase 
      Height          =   4495
      Left            =   0
      TabIndex        =   0
      Top             =   400
      Width           =   3615
      _ExtentX        =   6376
      _ExtentY        =   7938
      _Version        =   393217
      Indentation     =   353
      LineStyle       =   1
      Style           =   7
      ImageList       =   "imlTreePics"
      Appearance      =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
End
Attribute VB_Name = "frmDatabase"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'>>>>>>>>>>>>>>>>>>>>>>>>
Const FORMCAPTION = "数据库窗口"
'>>>>>>>>>>>>>>>>>>>>>>>>

Dim mnodEditNode As Node

'载入数据库
Public Sub LoadDatabase()
  On Error GoTo ADErr

  Dim nodX As Node    ' 创建变量。
  Dim sTBLName As String
  Dim sQRYName As String
  Dim sPropName As String
  Dim bTablesFound As Boolean
  Dim sTmp As String
  Me.MousePointer = vbHourglass
  tvDatabase.Nodes.Clear

  '添加属性节点
  Set nodX = tvDatabase.Nodes.Add(, , ">" & PROPERTIES_STR, "数据库全部用户表", PROPERTY_STR)
  nodX.Tag = PROPERTIES_STR
  nodX.Expanded = False

   '添加表
   
  Dim cnn As New ADODB.Connection
  Dim rs     As ADODB.Recordset
  cnn.Open gdbConString
  Set rs = cnn.OpenSchema(adSchemaTables)
   
  Do Until rs.EOF
      If rs!TABLE_TYPE = "TABLE" Then
      sTBLName = rs!TABLE_NAME
      bTablesFound = True

      Set nodX = tvDatabase.Nodes.Add(, , "T" & sTBLName, sTBLName, TABLE_STR)
    
      nodX.Tag = TABLE_STR
'      Set nodX = tvDatabase.Nodes.Add("T" & sTBLName, tvwChild, _
'                                      sTBLName & ">Fields", _
'                                      "字段", FIELD_STR)
'      nodX.Tag = FIELDS_STR
      End If
      rs.MoveNext
  Loop

  Me.MousePointer = vbDefault
  rs.Close
  cnn.Close

  Exit Sub
  
ADErr:
  ShowError
End Sub







Private Sub Combo1_Click()
gdbConString = ChangeDB(gdbConString) & Combo1.Text
LoadDatabase

End Sub

Private Sub Form_Load()
  On Error Resume Next
  Me.Caption = FORMCAPTION
  Dim Str As String
  Dim i As Integer
  Str = ChangeDB(gdbConString) & "master"
  Dim cnn As New ADODB.Connection
  cnn.ConnectionString = Str
  cnn.Open
  Dim rs As New ADODB.Recordset
  rs.Open "select * from sysdatabases", cnn, adOpenKeyset, adLockOptimistic
  For i = 0 To rs.RecordCount - 1
  Combo1.AddItem rs.Fields(0)
  rs.MoveNext
  Next
  Combo1.ListIndex = 0
  rs.Close
  cnn.Close
  Me.Height = Val(GetRegistryString("DBWindowHeight", "5870"))
  Me.Width = Val(GetRegistryString("DBWindowWidth", "3835"))
  Me.Top = Val(GetRegistryString("DBWindowTop", "0"))
  Me.Left = Val(GetRegistryString("DBWindowLeft", "0"))

  Err.Clear
End Sub

Private Sub Form_Resize()
  On Error Resume Next
  tvDatabase.Width = Me.ScaleWidth - (tvDatabase.Left * 2)
  tvDatabase.Height = Me.ScaleHeight - (tvDatabase.Top * 2) + 300
End Sub

Private Sub Form_Unload(Cancel As Integer)
  CloseCurrentDB
  If Me.WindowState = vbNormal Then
    SaveSetting APP_CATEGORY, APPNAME, "DBWindowTop", Me.Top
    SaveSetting APP_CATEGORY, APPNAME, "DBWindowLeft", Me.Left
    SaveSetting APP_CATEGORY, APPNAME, "DBWindowWidth", Me.Width
    SaveSetting APP_CATEGORY, APPNAME, "DBWindowHeight", Me.Height
  End If
End Sub


Private Sub tvDatabase_DblClick()
  If gnodDBNode Is Nothing Then Exit Sub
  
  '从鼠标单击中反相自动扩展改变
  gnodDBNode.Expanded = Not gnodDBNode.Expanded
    Set gnodDBNode2 = gnodDBNode
   frmMDI.mnuDBPUOpen_Click

  
End Sub

Private Sub tvDatabase_MouseUp(BUTTON As Integer, Shift As Integer, x As Single, Y As Single)
  On Error Resume Next
  If BUTTON = vbRightButton Then
    '试着得到那些右击的节点
    Set gnodDBNode2 = tvDatabase.HitTest(x, Y)
    If gnodDBNode2 Is Nothing Then
      Set gnodDBNode2 = tvDatabase.HitTest(800, Y)
    End If
    If gnodDBNode2 Is Nothing Then
      '再试一次大的
      Set gnodDBNode2 = tvDatabase.HitTest(1200, Y)
    End If
   
  End If
End Sub

Private Sub tvDatabase_NodeClick(ByVal Node As Node)
 On Error GoTo tvDatabase_NodeClickErr
 
  Dim cnn As New ADODB.Connection
  Dim rs     As New ADODB.Recordset
  cnn.Open gdbConString
  
  Dim nod As Node
  Dim nodX As Node
  Dim fldObj As ADODB.Field
  Dim idxObj As DAO.Index
  Dim prpObj As ADODB.Property
  Dim colTmp As Object
  Dim vTmp As Variant

  Set gnodDBNode = Node

  Select Case Node.Tag
    Case TABLE_STR
      If Node.Children > 0 Then Exit Sub
      '添加字段
      rs.Open "select top 1 * from [" & Node.Text & "]", cnn, adOpenKeyset, adLockOptimistic
      For Each fldObj In rs.Fields
        Set nodX = tvDatabase.Nodes.Add(Node.key, _
                                       tvwChild, Node.key & ">" & FIELDS_STR & ">" & fldObj.Name, _
                                       fldObj.Name, FIELD_STR)
        nodX.Tag = FIELD_STR
      Next
      Node.Expanded = True
    Case FIELD_STR
      If Node.Children > 0 Then Exit Sub
      rs.Open "select top 1 * from [" & Node.Parent.Text & "]", cnn, adOpenKeyset, adLockOptimistic
      
      For Each prpObj In rs.Fields(Node.Text).Properties
        'Value 属性的特殊情况，
        '因为在 tabledef 中的 field 对象中，它是无效的。
        If prpObj.Name <> "Value" Then
          vTmp = GetPropertyValue(prpObj)
          Set nodX = tvDatabase.Nodes.Add(Node.key, _
                                         tvwChild, _
                                         Node.Parent.key & Node.key & ">" & prpObj.Name, _
                                         prpObj.Name & "=" & vTmp, PROPERTY_STR)
          nodX.Tag = PROPERTY_STR
        End If
      Next
      Node.Expanded = True
      Set tvDatabase.SelectedItem = Node
    
  End Select
  
  Exit Sub
tvDatabase_NodeClickErr:
  If Err = 35602 Then Resume Next
    
  Dim errloop As ADODB.Error
  Dim strerror As String
   For Each errloop In cnn.Errors
      strerror = errloop.Description & vbCr
      MsgBox strerror
   Next
   
  rs.Close
  cnn.Close
End Sub

Function GetPropertyValue(prpObj As ADODB.Property) As Variant
  On Error Resume Next
  
  If IsNull(prpObj.Value) Then
  GetPropertyValue = "N/A"
  Else
    GetPropertyValue = prpObj.Value
  End If
  
End Function