frmmainexe.frm

很好用的Access工具

                    .TypeText = "Procedure"
                Case QueryDefTypeEnum.dbQSelect
                    .TypeText = "Select"
                Case QueryDefTypeEnum.dbQSetOperation
                    .TypeText = "Set Operation"
                Case QueryDefTypeEnum.dbQSPTBulk
                    .TypeText = "SPT Bulk"
                Case QueryDefTypeEnum.dbQSQLPassThrough
                    .TypeText = "SQL Pass Through"
                Case QueryDefTypeEnum.dbQUpdate
                    .TypeText = "Update"
                Case Else
                    .TypeText = .Type
            End Select
            .SQLText = Information_SQL(qQuery.SQL)
            Set qNode = tvwData.Nodes.Add("QUERY", tvwChild, "Q" & iNode, "视图: " & .Name, "Query")
            qNode.Tag = iNode
            ReDim Preserve qlNode(iNode)
            qlNode(iNode).Name = .Name
            qlNode(iNode).Reference = iCount
            qlNode(iNode).Type = qdQuery
            iNode = iNode + 1
            iCount = iCount + 1
        End With
    Loop
    Do While iRelate <= qDB.Relations - 1
        Set qRelation = qData.Relations(iRelate)
        ReDim Preserve qlRelation(0 To iRelate)
        With qlRelation(iRelate)
            .Name = qRelation.Name
            .Table = Information_Index_Get(qRelation.Table, qdTable, 0)
            .ForeignTable = Information_Index_Get(qRelation.ForeignTable, qdTable, 0)
            .Field = Information_Index_Get(qRelation.Fields(0).Name, qdField, .Table)
            .ForeignField = Information_Index_Get(qRelation.Fields(0).ForeignName, qdField, .ForeignTable)
            If CBool(qRelation.Attributes And RelationAttributeEnum.dbRelationDeleteCascade) Then .Attributes = Attributes_Add(.Attributes, "dbRelationDeleteCascade")
            If CBool(qRelation.Attributes And RelationAttributeEnum.dbRelationDontEnforce) Then .Attributes = Attributes_Add(.Attributes, "dbRelationDontEnforce")
            If CBool(qRelation.Attributes And RelationAttributeEnum.dbRelationInherited) Then .Attributes = Attributes_Add(.Attributes, "dbRelationInherited")
            If CBool(qRelation.Attributes And RelationAttributeEnum.dbRelationLeft) Then .Attributes = Attributes_Add(.Attributes, "dbRelationLeft")
            If CBool(qRelation.Attributes And RelationAttributeEnum.dbRelationRight) Then .Attributes = Attributes_Add(.Attributes, "dbRelationRight")
            If CBool(qRelation.Attributes And RelationAttributeEnum.dbRelationUnique) Then .Attributes = Attributes_Add(.Attributes, "dbRelationUnique")
            If CBool(qRelation.Attributes And RelationAttributeEnum.dbRelationUpdateCascade) Then .Attributes = Attributes_Add(.Attributes, "dbRelationUpdateCascade")
            Set qNode = tvwData.Nodes.Add("D0", tvwChild, "R" & iNode, "关系: " & .Name, "Relation")
            qNode.Tag = iNode
            ReDim Preserve qlNode(iNode)
            qlNode(iNode).Name = .Name
            qlNode(iNode).Reference = iRelate
            qlNode(iNode).Type = qdRelation
            iNode = iNode + 1
        End With
        iRelate = iRelate + 1
    Loop
    tvwData.Nodes("D0").Selected = True
    Information_Item_Get 0
    Set qData = Nothing
    Set qTable = Nothing
    Set qRelation = Nothing
    Set qField = Nothing
    Set qIndex = Nothing
End Sub

Private Function Attributes_Add(ByVal sText As String, ByVal sNew As String) As String
    If sText <> "" Then sText = sText & " + "
    sText = sText & sNew
    Attributes_Add = sText
End Function

Private Sub tvwData_NodeClick(ByVal Node As ComctlLib.Node)
    Node.EnsureVisible
    If Node.Key = "Main" Then Exit Sub
    Information_Item_Get Node.Tag
End Sub

Private Sub Information_Item_Get(ByVal iNode As Integer)
    Dim iRef As Integer
    Dim lvItem As ListItem
    
    lvDetails.ListItems.Clear
    iRef = qlNode(iNode).Reference
    Select Case qlNode(iNode).Type
        Case qDatabaseObjectEnum.qdDatabase
            With qDB
                lblDetails.Caption = "Database: " & .Name
                Set lvItem = lvDetails.ListItems.Add(1, , "Name")
                lvItem.SubItems(1) = .Name
                Set lvItem = lvDetails.ListItems.Add(2, , "Object")
                lvItem.SubItems(1) = "Database"
                Set lvItem = lvDetails.ListItems.Add(3, , "Tables")
                lvItem.SubItems(1) = .Tables
                Set lvItem = lvDetails.ListItems.Add(4, , "Relations")
                lvItem.SubItems(1) = .Relations
                Set lvItem = lvDetails.ListItems.Add(5, , "Indexes")
                lvItem.SubItems(1) = .Indexes
                Set lvItem = lvDetails.ListItems.Add(6, , "Fields")
                lvItem.SubItems(1) = .Fields
            End With
        Case qDatabaseObjectEnum.qdTable
            With qlTable(iRef)
                lblDetails.Caption = "Table: " & .Name
                Set lvItem = lvDetails.ListItems.Add(1, , "Name")
                lvItem.SubItems(1) = .Name
                Set lvItem = lvDetails.ListItems.Add(2, , "Object")
                lvItem.SubItems(1) = "Table"
                Set lvItem = lvDetails.ListItems.Add(3, , "Attributes")
                lvItem.SubItems(1) = .Attributes
                Set lvItem = lvDetails.ListItems.Add(4, , "Indexes")
                lvItem.SubItems(1) = .Indexes
                Set lvItem = lvDetails.ListItems.Add(5, , "Fields")
                lvItem.SubItems(1) = .Fields
            End With
        Case qDatabaseObjectEnum.qdIndex
            With qlIndex(iRef)
                lblDetails.Caption = "Index: " & .Name
                Set lvItem = lvDetails.ListItems.Add(1, , "Name")
                lvItem.SubItems(1) = .Name
                Set lvItem = lvDetails.ListItems.Add(2, , "Object")
                lvItem.SubItems(1) = "Index"
                Set lvItem = lvDetails.ListItems.Add(3, , "Field")
                lvItem.SubItems(1) = qlField(.FieldIndex).Name
                Set lvItem = lvDetails.ListItems.Add(4, , "Table")
                lvItem.SubItems(1) = qlTable(.Table).Name
                Set lvItem = lvDetails.ListItems.Add(5, , "Primary")
                lvItem.SubItems(1) = .Primary
                Set lvItem = lvDetails.ListItems.Add(6, , "Required")
                lvItem.SubItems(1) = .Required
                Set lvItem = lvDetails.ListItems.Add(7, , "Unique")
                lvItem.SubItems(1) = .Unique
                Set lvItem = lvDetails.ListItems.Add(8, , "Sort")
                If .Sort Then
                    lvItem.SubItems(1) = "Descending"
                Else
                    lvItem.SubItems(1) = "Ascending"
                End If
            End With
        Case qDatabaseObjectEnum.qdField
            With qlField(iRef)
                lblDetails.Caption = "Field: " & .Name
                Set lvItem = lvDetails.ListItems.Add(1, , "Name")
                lvItem.SubItems(1) = .Name
                Set lvItem = lvDetails.ListItems.Add(2, , "Object")
                lvItem.SubItems(1) = "Field"
                Set lvItem = lvDetails.ListItems.Add(3, , "Attributes")
                lvItem.SubItems(1) = .Attributes
                Set lvItem = lvDetails.ListItems.Add(4, , "Table")
                lvItem.SubItems(1) = qlTable(.Table).Name
                Set lvItem = lvDetails.ListItems.Add(5, , "Required")
                lvItem.SubItems(1) = .Required
                Set lvItem = lvDetails.ListItems.Add(6, , "Type")
                lvItem.SubItems(1) = qFType(.Type).Name
                Set lvItem = lvDetails.ListItems.Add(7, , "Size")
                lvItem.SubItems(1) = .Size
                Set lvItem = lvDetails.ListItems.Add(8, , "Default Value")
                lvItem.SubItems(1) = .DefaultValue
                Set lvItem = lvDetails.ListItems.Add(9, , "Indexed")
                lvItem.SubItems(1) = .Index
            End With
        Case qDatabaseObjectEnum.qdRelation
            With qlRelation(iRef)
                lblDetails.Caption = "Relation: " & .Name
                Set lvItem = lvDetails.ListItems.Add(1, , "Name")
                lvItem.SubItems(1) = .Name
                Set lvItem = lvDetails.ListItems.Add(2, , "Object")
                lvItem.SubItems(1) = "Relation"
                Set lvItem = lvDetails.ListItems.Add(3, , "Attributes")
                lvItem.SubItems(1) = .Attributes
                Set lvItem = lvDetails.ListItems.Add(4, , "Table")
                lvItem.SubItems(1) = qlTable(.Table).Name
                Set lvItem = lvDetails.ListItems.Add(5, , "Field")
                lvItem.SubItems(1) = qlField(.Field).Name
                Set lvItem = lvDetails.ListItems.Add(6, , "Foreign Table")
                lvItem.SubItems(1) = qlTable(.ForeignTable).Name
                Set lvItem = lvDetails.ListItems.Add(7, , "Foreign Field")
                lvItem.SubItems(1) = qlField(.ForeignField).Name
            End With
        Case qDatabaseObjectEnum.qdQueries
            lblDetails.Caption = "Queries"
            Set lvItem = lvDetails.ListItems.Add(1, , "Count")
            lvItem.SubItems(1) = qDB.Queries
        Case qDatabaseObjectEnum.qdQuery
            With qlQuery(iRef)
                lblDetails.Caption = "Query: " & .Name
                Set lvItem = lvDetails.ListItems.Add(1, , "Name")
                lvItem.SubItems(1) = .Name
                Set lvItem = lvDetails.ListItems.Add(2, , "Object")
                lvItem.SubItems(1) = "Query"
                Set lvItem = lvDetails.ListItems.Add(3, , "Fields")
                lvItem.SubItems(1) = .Fields
                Set lvItem = lvDetails.ListItems.Add(4, , "Type")
                lvItem.SubItems(1) = .TypeText
            End With
    End Select
End Sub

Private Sub Information_FieldType()
    qFType(DataTypeEnum.dbBigInt).Code = "dbBigInt"
    qFType(DataTypeEnum.dbBigInt).Name = "Big Integer"
    qFType(DataTypeEnum.dbBinary).Code = "dbBinary"
    qFType(DataTypeEnum.dbBinary).Name = "Binary"
    qFType(DataTypeEnum.dbBoolean).Code = "dbBoolean"
    qFType(DataTypeEnum.dbBoolean).Name = "Boolean (True/False)"
    qFType(DataTypeEnum.dbByte).Code = "dbByte"
    qFType(DataTypeEnum.dbByte).Name = "Byte"
    qFType(DataTypeEnum.dbChar).Code = "dbChar"
    qFType(DataTypeEnum.dbChar).Name = "Fixed String"
    qFType(DataTypeEnum.dbCurrency).Code = "dbCurrency"
    qFType(DataTypeEnum.dbCurrency).Name = "Currency"
    qFType(DataTypeEnum.dbDate).Code = "dbDate"
    qFType(DataTypeEnum.dbDate).Name = "Date"
    qFType(DataTypeEnum.dbDecimal).Code = "dbDecimal"
    qFType(DataTypeEnum.dbDecimal).Name = "Decimal"
    qFType(DataTypeEnum.dbDouble).Code = "dbDouble"
    qFType(DataTypeEnum.dbDouble).Name = "Double"
    qFType(DataTypeEnum.dbFloat).Code = "dbFloat"
    qFType(DataTypeEnum.dbFloat).Name = "Float"
    qFType(DataTypeEnum.dbGUID).Code = "dbGUID"
    qFType(DataTypeEnum.dbGUID).Name = "GUID (Globally Unique Identifier)"
    qFType(DataTypeEnum.dbInteger).Code = "dbInteger"
    qFType(DataTypeEnum.dbInteger).Name = "Integer"
    qFType(DataTypeEnum.dbLong).Code = "dbLong"
    qFType(DataTypeEnum.dbLong).Name = "Long"
    qFType(DataTypeEnum.dbLongBinary).Code = "dbLongBinary"
    qFType(DataTypeEnum.dbLongBinary).Name = "Long Binary"
    qFType(DataTypeEnum.dbMemo).Code = "dbMemo"
    qFType(DataTypeEnum.dbMemo).Name = "Memo"
    qFType(DataTypeEnum.dbNumeric).Code = "dbNumeric"
    qFType(DataTypeEnum.dbNumeric).Name = "Numeric"
    qFType(DataTypeEnum.dbSingle).Code = "dbSingle"
    qFType(DataTypeEnum.dbSingle).Name = "Single"
    qFType(DataTypeEnum.dbText).Code = "dbText"
    qFType(DataTypeEnum.dbText).Name = "Text"
    qFType(DataTypeEnum.dbTime).Code = "dbTime"
    qFType(DataTypeEnum.dbTime).Name = "Time"
    qFType(DataTypeEnum.dbTimeStamp).Code = "dbTimeStamp"
    qFType(DataTypeEnum.dbTimeStamp).Name = "Time Stamp"
    qFType(DataTypeEnum.dbVarBinary).Code = "dbVarBinary"
    qFType(DataTypeEnum.dbVarBinary).Name = "Variable length Binary"
End Sub


Private Function Information_Index_Get(ByVal sName As String _
                                      , ByVal sType As qDatabaseObjectEnum _
                                      , ByVal iTable As Integer) As Integer
    Dim iCount As Integer
    Dim iHit As Integer
    
    If sType = qdField Then
        Do While iCount <= qDB.Fields - 1 Or iHit = 0
            If qlField(iCount).Name = sName And qlField(iCount).Table = iTable Then iHit = iCount + 1
            iCount = iCount + 1
        Loop
    Else
        Do While iCount <= qDB.Tables - 1 Or iHit = 0
            If qlTable(iCount).Name = sName Then iHit = iCount + 1
            iCount = iCount + 1
        Loop
    End If
    iHit = iHit - 1
    If iHit < 0 Then Stop
    Information_Index_Get = iHit
End Function

Private Function Database_Compile() As Boolean
    Dim iTable As Integer
    Dim iCount As Integer
    Dim sBack As String
    Dim sSubText As String
    Dim iSubOption As Integer
    
    On Error GoTo Database_CompileErr:
    ' Create the code for the database
    sText = "' ==============================================================" & vbCrLf
    sText = sText & "' Module:       CreateDB" & vbCrLf
    sText = sText & "' Purpose:      Create Database" & vbCrLf
    sText = sText & "' ==============================================================" & vbCrLf
    sText = sText & "' qbd DATABASE CODE CREATOR" & vbCrLf
    sText = sText & "' ==============================================================" & vbCrLf
    sText = sText & "' WHAT TO DO NEXT:" & vbCrLf
    sText = sText & "' 1.  Add reference to Microsoft DA0 3.5x Library" & vbCrLf
    sText = sText & "' 2.  Check the Database_Create() function for Optional Changes" & vbCrLf
    sText = sText & "' 3.  To create a database use:" & vbCrLf
    sText = sText & "'     bOkay = Database_Create sFilename" & vbCrLf
    sText = sText & "'     Where sFilename is the Path and Name of the Database" & vbCrLf
    sText = sText & "'     and bOkay is a boolean return value.  If return is false" & vbCrLf
    sText = sText & "'     then the creation routine was unsuccessful." & vbCrLf
    sText = sText & "' ==============================================================" & vbCrLf & vbCrLf
    sText = sText & "Private dbData as Database" & vbCrLf
    sText = sText & "Public Function Database_Create(byVal sFilename as String) As Boolean" & vbCrLf & vbCrLf
    sText = sText & "' Code created by the qbd Database Code Creator" & vbCrLf
    sText = sText & "' Use Find '#' to check optional settings" & vbCrLf & vbCrLf
    sText = sText & "On Error Goto Database_Create_Error" & vbCrLf & vbCrLf
    If qDB.Tables > 0 Then sText = sText & "Dim dtTable as TableDef" & vbCrLf

    'If qDB.Relations > 0 Then sText = sText & "Dim drRelation as Relation" & vbCrLf
    'If qDB.Indexes > 0 Then sText = sText & "Dim diIndex as Index" & vbCrLf
    'If qDB.Fields > 0 Then sText = sText & "Dim dfField As Field" & vbCrLf
    If qDB.Relations > 0 Then iSubOption = iSubOption + 4
    If qDB.Indexes > 0 Then iSubOption = iSubOption + 2
    If qDB.Fields > 0 Then iSubOption = iSubOption + 1
    'If qDB.ItemCount Then sText = sText & "Dim iItems as Integer" & vbCrLf
    sText = sText & vbCrLf
    sText = sText & "' Create the Database" & vbCrLf
    sText = sText & "' # Add password: insert '& """ & ";pwd=NewPassword" & """ after dbLangGeneral" & vbCrLf
    sText = sText & "' # Encrypt: insert '+ dbEncrypt' after dbVersion30" & vbCrLf
    sText = sText & "Set dbData = DBEngine.CreateDatabase(sFilename, dbLangGeneral, dbVersion30)" & vbCrLf & vbCrLf

    iTable = 0
    Do While iTable <= qDB.Tables - 1
        If qlTable(iTable).Name = "#" Then GoTo DC_Table_Complete
        sText = sText & "' Create table:'" & qlTable(iTable).Name & "'" & vbCrLf
        sText = sText & "Set dtTable = dbData.CreateTableDef(""" & qlTable(iTable).Name & """"
        If qlTable(iTable).Attributes = "" Then
            sText = sText & ")" & vbCrLf
        Else
            sText = sText & ", " & qlTable(iTable).Attributes & ")" & vbCrLf
        End If
        sText = sText & vbCrLf
        If qlTable(iTable).Indexes > 1 Then
            sText = sText & vbCrLf & "' Create Indexes for table: " & qlTable(iTable).Name
        ElseIf qlTable(iTable).Indexes = 1 Then
            sText = sText & vbCrLf & "' Create Index for table: " & qlTable(iTable).Name