frmmain.frm

几个不错的VB例子

  NodX.Tag = "QUERIES"
  NodX.ForeColor = vbBlue
    
  For Each TBL In mCat.Tables
    If TBL.Type = "TABLE" Then
      Set NodX = TV.Nodes.Add("TABLES", tvwChild, TBL.name, TBL.name, "TABLE")
    ElseIf TBL.Type = "LINK" Then
      Set NodX = TV.Nodes.Add("TABLES", tvwChild, TBL.name, TBL.name, "TABLELINKED")
    End If
    
    If TBL.Type = "TABLE" Or TBL.Type = "LINK" Then
      DoEvents
      NodX.Tag = "TABLE"
      NodX.EnsureVisible
      Set NodX = TV.Nodes.Add(TBL.name, tvwChild, TBL.name & "\" & "COLUMNS", "", "COLUMN")
      NodX.Tag = "COLUMNS"
      
      For Each Col In TBL.Columns
        If Left$(Col.name, 2) <> "s_" Then
          Set NodX = TV.Nodes.Add(TBL.name & "\" & "COLUMNS", tvwChild, TBL.name & "\" & Col.name, Col.name, "COLUMN")
          NodX.Tag = "COLUMN"
        End If
      Next
      TV.Nodes(TBL.name & "\" & "COLUMNS").Text = "Columns (" & TV.Nodes(TBL.name & "\" & "COLUMNS").Children & ")"
      
      Set NodX = TV.Nodes.Add(TBL.name, tvwChild, TBL.name & "\" & "INDEXES", "", "COLUMN")
      NodX.Tag = "INDEXES"
      
      For Each IDX In TBL.Indexes
        If Left$(IDX.name, 2) <> "s_" Then
          Set NodX = TV.Nodes.Add(TBL.name & "\" & "INDEXES", tvwChild, "IDX:" & TBL.name & "\" & IDX.name, IDX.name, "COLUMN")
          NodX.Tag = "INDEX"
        End If
      Next
      TV.Nodes(TBL.name & "\" & "INDEXES").Text = "Indexes (" & TV.Nodes(TBL.name & "\" & "INDEXES").Children & ")"
    ElseIf TBL.Type = "VIEW" Or TBL.Type = "PROC" Then
      Debug.Print TBL.name & " is a " & TBL.Type
    End If
  Next
  
  TV.Nodes("TABLES").Bold = (TV.Nodes("TABLES").Children > 0)
  TV.Nodes("TABLES").Text = "Tables (" & TV.Nodes("TABLES").Children & ")"
  
  Screen.MousePointer = vbDefault
  'Exit Sub
  
' View / procedures / query
  For Each VIW In mCat.Views
    Set NodX = TV.Nodes.Add("QUERIES", tvwChild, VIW.name, VIW.name, "QUERY")
    NodX.Tag = "VIEW"
  Next
  
  For Each PROC In mCat.Procedures
    Set NodX = TV.Nodes.Add("QUERIES", tvwChild, PROC.name, PROC.name, "QUERY")
    NodX.Tag = "PROC"
  Next
  
   TV.Nodes("QUERIES").Bold = (TV.Nodes("QUERIES").Children > 0)
  TV.Nodes("QUERIES").Text = "Queries (" & TV.Nodes("QUERIES").Children & ")"

  Screen.MousePointer = vbDefault

Exit Sub
ErrTrap:
  MsgBox Err.Number & " / " & Err.Description, vbExclamation, "Error in AnalyzeDB"
  Exit Sub
  Resume
End Sub

Private Sub Form_Unload(Cancel As Integer)
  
  mMRU.Save
  Set mMRU = Nothing
  
  Set mCat = Nothing
  Set mCon = Nothing

End Sub

Private Sub mnuFileAnalyzeDB_Click()
  
  AnalyzeDB

End Sub

Private Sub mnuFileExit_Click()
  
  Unload Me
  End

End Sub

Private Sub Load_ImgList()
On Error GoTo ErrTrap
' Load the icons from the resourcefile into the Imagelist...

  imgList.ListImages.Clear
  imgList.ImageHeight = 16
  imgList.ImageWidth = 16
  
  imgList.ListImages.Add , "DATABASE", LoadResPicture("DATABASE", vbResIcon)
  imgList.ListImages.Add , "TABLES", LoadResPicture("TABLES", vbResIcon)
  imgList.ListImages.Add , "TABLE", LoadResPicture("TABLE", vbResIcon)
  imgList.ListImages.Add , "TABLELINKED", LoadResPicture("TABLELINKED", vbResIcon)
  imgList.ListImages.Add , "COLUMNS", LoadResPicture("COLUMNS", vbResIcon)
  imgList.ListImages.Add , "COLUMN", LoadResPicture("COLUMN", vbResIcon)
  imgList.ListImages.Add , "VARIABLE", LoadResPicture("VARIABLE", vbResIcon)
  imgList.ListImages.Add , "QUERY", LoadResPicture("QUERY", vbResIcon)
  
Exit Sub
ErrTrap:
  MsgBox Err.Number & " / " & Err.Description, vbExclamation, "Error in Load_ImgList"
  Exit Sub
  Resume
End Sub

Private Sub TV_Setup()
' Setup of the TreeView...

  TV.LabelEdit = tvwManual
  TV.Indentation = 256
  TV.LineStyle = tvwTreeLines
  TV.Sorted = 1 ' True
  Set TV.ImageList = imgList

End Sub

Private Sub LV_Setup()

  LV.View = lvwReport
  
  LV.LabelEdit = lvwManual
  LV.GridLines = 1 ' True
  
  LV.ColumnHeaders.Add , "VARIABLE", "Variable", LV.Width * 0.35
  LV.ColumnHeaders.Add , "VALUE", "Value", LV.Width * 0.5
  
  Set LV.SmallIcons = imgList
  
  LV.PictureAlignment = lvwTile
  LV.Picture = LoadResPicture("LVBG", vbResBitmap)


End Sub

Private Sub SB_Setup()

  SB.Style = sbrSimple
  SB.SimpleText = "No MDB loaded."

End Sub

Private Sub Menu_Setup()
Dim I As Byte
  If mMRU Is Nothing Then Set mMRU = New cMRU
  
  mnuMRUFiles(0).Visible = False
  
  mMRU.Number = 4
  mMRU.Load
  
  
  For I = 1 To mMRU.Number
    Load mnuMRUFiles(I)
    mnuMRUFiles(I).Visible = False
  Next I
  
  mMRU.Update Me
  
End Sub

Private Sub LV_LoadDATABASE() '(ByVal Node As MSComctlLib.Node)
Dim ItmX As ListItem
  
  LV.ListItems.Clear
  Set ItmX = LV.ListItems.Add(, "FILENAME", "File Name", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", DB_Name
  
  Set ItmX = LV.ListItems.Add(, "PASSWORD", "Jet OleDB:Password", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", mJetPassword
  
  Dim F As Integer
  For F = 0 To mCon.Properties.Count - 1
    Set ItmX = LV.ListItems.Add(, F & "Key", mCon.Properties(F).name, , "VARIABLE")
    ItmX.ListSubItems.Add , "VALUE", mCon.Properties(F).Value
  Next F
  
End Sub

Private Sub LV_LoadTABLE(ByVal Node As MSComctlLib.Node)
Dim ItmX As ListItem
Dim KEY As ADOX.KEY
Dim IDX As ADOX.Index
Dim Column As ADOX.Column
Dim F As Integer
Dim sPK As String, sFK As String
On Error Resume Next
  
  LV.ListItems.Clear
  Set ItmX = LV.ListItems.Add(, "TABLENAME", "Table Name", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", mCat.Tables(Node.Text).name

' find Primary Keys (from the indexes)
  For Each IDX In mCat.Tables(Node.Text).Indexes
    If IDX.PrimaryKey Then
      For Each Column In IDX.Columns
        sPK = sPK & Column.name & "; "
      Next
    End If
  Next
  
  If Len(sPK) > 2 Then
    Set ItmX = LV.ListItems.Add(, "PKEY", "Primary Key(s)", , "VARIABLE")
    ItmX.ListSubItems.Add , "VALUE", Left$(sPK, Len(sPK) - 2)
  End If
' Find Foreign Keys
  For Each KEY In mCat.Tables(Node.Text).Keys
   If KEY.Type = adKeyForeign Then
     For Each Column In KEY.Columns
       sFK = sFK & Column.name & "; "
     Next
   End If
  Next
  
  Set ItmX = LV.ListItems.Add(, "FKEYS", "Foreign Key(s)", , "VARIABLE")
  If Len(sFK) > 0 Then ItmX.ListSubItems.Add , "VALUE", Left$(sFK, Len(sFK) - 2)
  
  For F = 0 To mCat.Tables(Node.Text).Properties.Count - 1
    Set ItmX = LV.ListItems.Add(, F & "Key", mCat.Tables(Node.Text).Properties(F).name, , "VARIABLE")
    ItmX.ListSubItems.Add , "VALUE", mCat.Tables(Node.Text).Properties(F).Value
  Next F
  
End Sub

Private Sub LV_LoadCOLUMN(ByVal Node As MSComctlLib.Node)
Dim ItmX As ListItem
Dim TName As String
Dim CName As String
Dim Pos As Byte

  Pos = InStr(1, Node.KEY, "\")
  
  TName = Left$(Node.KEY, Pos - 1)
  CName = Mid$(Node.KEY, Pos + 1)
  
  LV.ListItems.Clear
  Set ItmX = LV.ListItems.Add(, "TABLENAME", "Table Name", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", TName
  
  Set ItmX = LV.ListItems.Add(, "COLUMNNAME", "Column Name", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", CName
  
  Set ItmX = LV.ListItems.Add(, "DATATYPE", "Data Type", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", cType(mCat.Tables(TName).Columns(CName).Type)
  
  Set ItmX = LV.ListItems.Add(, "NULLABLE", "Nullable", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", cColumnAttributes(mCat.Tables(TName).Columns(CName).Attributes)
  
  
'Dim F As Integer
'
'  For F = 0 To mCat.Tables(TName).Columns(CName).Properties.Count - 1
'    Set ItmX = LV.ListItems.Add(, F & "Key", mCat.Tables(TName).Columns(CName).Properties(F).name, , "VARIABLE")
'    ItmX.ListSubItems.Add , "VALUE", mCat.Tables(TName).Columns(CName).Properties(F).Value
'  Next F
  
  
  Set ItmX = LV.ListItems.Add(, "SIZE", "Size", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", mCat.Tables(TName).Columns(CName).DefinedSize
  
  If mCat.Tables(TName).Columns(CName).Properties("AutoIncrement") Then
    ItmX.ListSubItems("VALUE").Text = ItmX.ListSubItems("VALUE").Text & " (AutoIncrement)"
  End If
  
  Set ItmX = LV.ListItems.Add(, "DESCRIPTION", "Description", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", mCat.Tables(TName).Columns(CName).Properties("Description").Value

  Set ItmX = LV.ListItems.Add(, "DEFAULT", "Default Value", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", mCat.Tables(TName).Columns(CName).Properties("Default").Value
  
'  Set ItmX = LV.ListItems.Add(, "ZEROLENGTH", "Allow Zero Length", , "VARIABLE")
'  ItmX.ListSubItems.Add , "VALUE", CStr(mCat.Tables(TName).Columns(CName).Properties("Jet OLEDB:Allow Zero Length").Value)
  
End Sub

Private Sub LV_LoadQuery(ByVal Node As MSComctlLib.Node)
Dim ItmX As ListItem
Dim QName As String
Dim DateCreated As Variant
Dim DateModified As Variant
Dim CMD As ADODB.Command

  If Node.Tag = "VIEW" Then
    QName = mCat.Views(Node.KEY).name
    DateCreated = mCat.Views(Node.KEY).DateCreated
    DateModified = mCat.Views(Node.KEY).DateModified
    Set CMD = mCat.Views(Node.KEY).Command
    
  ElseIf Node.Tag = "PROC" Then
    QName = mCat.Procedures(Node.KEY).name
    DateCreated = mCat.Procedures(Node.KEY).DateCreated
    DateModified = mCat.Procedures(Node.KEY).DateModified
    Set CMD = mCat.Procedures(Node.KEY).Command

  End If

  LV.ListItems.Clear
  
  If Len(QName) > 0 Then
    Set ItmX = LV.ListItems.Add(, "QNAME", "Query Name", , "VARIABLE")
    ItmX.ListSubItems.Add , "VALUE", QName
    
    Set ItmX = LV.ListItems.Add(, "TYPE", "Type", , "VARIABLE")
    ItmX.ListSubItems.Add , "VALUE", Node.Tag
    
    Set ItmX = LV.ListItems.Add(, "DC", "Date Created", , "VARIABLE")
    ItmX.ListSubItems.Add , "VALUE", DateCreated
    Set ItmX = LV.ListItems.Add(, "DM", "Date Modified", , "VARIABLE")
    ItmX.ListSubItems.Add , "VALUE", DateModified
    
    Set ItmX = LV.ListItems.Add(, "CMDTEXT", "Command Text", , "VARIABLE")
    ItmX.ListSubItems.Add , "VALUE", Replace(Replace(CMD.CommandText, vbCrLf, " "), """", "'")
  
  End If
  

End Sub

Private Sub LV_LoadINDEX(ByVal Node As MSComctlLib.Node)
Dim ItmX As ListItem
Dim TName As String
Dim IName As String
Dim CName As String
Dim Col As ADOX.Column
Dim Pos As Byte

  Pos = InStr(1, Node.KEY, "\")
  
  TName = Mid$(Node.KEY, 5, Pos - 5)
  IName = Mid$(Node.KEY, Pos + 1)
  
  LV.ListItems.Clear
  Set ItmX = LV.ListItems.Add(, "TABLENAME", "Table Name", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", TName
  
  Set ItmX = LV.ListItems.Add(, "INDEXNAME", "Index Name", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", IName
  
  Set ItmX = LV.ListItems.Add(, "COLUMNNAME", "Column Names", , "VARIABLE")
  For Each Col In mCat.Tables(TName).Indexes(IName).Columns
    CName = CName & Col.name & "; "
  Next
  ItmX.ListSubItems.Add , "VALUE", Left$(CName, Len(CName) - 2)
  
  Set ItmX = LV.ListItems.Add(, "UNIQUE", "Unique", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", IIf(mCat.Tables(TName).Indexes(IName).Unique, "True", "False")
  
  Set ItmX = LV.ListItems.Add(, "Clustered", "Clustered", , "VARIABLE")
  ItmX.ListSubItems.Add , "VALUE", IIf(mCat.Tables(TName).Indexes(IName).Clustered, "True", "False")
  
End Sub


Private Sub mnuHelpAbout_Click()
Dim S As String

  S = App.Title & " is a small database tool where you create a " & vbCrLf
  S = S & "BAS-module containing the structure to create an Access" & vbCrLf
  S = S & "database on the fly using ADO and ADOX." & vbCrLf & vbCrLf
  S = S & "Future features could be the data included in the BAS-module." & vbCrLf & vbCrLf
  S = S & "Any comments, please mail to: [e-mail]"
  
  MsgBox S, vbApplicationModal + vbInformation, App.Title & " v" & App.Major & "." & App.Minor & "." & App.Revision
  
End Sub

Private Sub mnuMRUFiles_Click(Index As Integer)

  If Index > 0 Then OpenDB mnuMRUFiles(Index).Caption
  
End Sub

Private Sub SB_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
   
   Me.MousePointer = vbDefault

End Sub

Private Sub TV_Expand(ByVal Node As MSComctlLib.Node)
  Node.Sorted = 1 ' True
End Sub

Private Sub TV_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
     
  Me.MousePointer = vbDefault

End Sub

Private Sub TV_NodeClick(ByVal Node As MSComctlLib.Node)
  
  Select Case Node.Tag
    Case "COLUMN": LV_LoadCOLUMN Node
    Case "INDEX": LV_LoadINDEX Node
    Case "TABLE": LV_LoadTABLE Node
    Case "VIEW", "PROC": LV_LoadQuery Node
    Case "DATABASE": LV_LoadDATABASE 'Node
  End Select
  
End Sub

Private Sub ArrangeControls()
On Error Resume Next
Dim hgt1 As Single
Dim hgt2 As Single

' Don't bother if we're iconized.
  If WindowState = vbMinimized Then Exit Sub

  hgt1 = (Me.ScaleWidth - SPLITTER_WIDTH) * Percentage1
  TV.Move Me.ScaleLeft, Me.ScaleTop, hgt1, Me.ScaleHeight - SB.Height
    
  hgt2 = (Me.ScaleWidth - SPLITTER_WIDTH) - hgt1
  LV.Move hgt1 + SPLITTER_WIDTH, Me.ScaleTop, hgt2, Me.ScaleHeight - SB.Height
    
End Sub