frmmainexe.frm

很好用的Access工具

    If Not bProgress Then Information_Clear: Exit Sub
    Me.MousePointer = vbHourglass
    lblData.Caption = qDB.Name
    Me.Refresh
    Information_Update
    Me.Refresh
    bProgress = Database_Compile
    cmdCopy.Enabled = bProgress
    cmdSave.Enabled = bProgress
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdSave_Click()
    Dim iFreeFile As Integer
    
    On Error GoTo SaveErr
    cmData.Filter = "Basic Files|*.bas|Text Files|*.txt|All Files|*.*"
    cmData.DefaultExt = ".bas"
    cmData.FileName = "modCreateDB.bas"
    cmData.FilterIndex = 0
    cmData.DialogTitle = "Save File..."
    cmData.CancelError = True
    cmData.ShowSave
    iFreeFile = FreeFile
    Open cmData.FileName For Output As #iFreeFile
    Print #iFreeFile, "Attribute VB_Name = " & Chr$(34) & "CreateDB" & Chr$(34) & vbCrLf
    Print #iFreeFile, sText
    If qDB.Queries > 0 Then Print #iFreeFile, sQuery
    Close iFreeFile
    Exit Sub
SaveErr:
    Close iFreeFile
    If Err.Number = cdlCancel Then Exit Sub
    MsgBox "An error occured while trying to create code module." & vbCrLf & "Error: " & Err.Description
    cmdSave.Enabled = False
End Sub

Private Sub imgSplit_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    qSplit.bMove = True
    Main_SplitterMove X
End Sub

Private Sub imgSplit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If qSplit.bMove Then Main_SplitterMove X
End Sub

Private Sub imgSplit_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    With qSplit
        If .bMove Then
            .bMove = False
            picSplit.Visible = False
            Main_Resize
        End If
    End With
End Sub

Public Sub Main_SplitterMove(ByVal X As Single)
    With qSplit
        X = X + imgSplit.Left
        If X < .sLeft Then
            X = .sLeft
        ElseIf X > .sRight Then
            X = .sRight
        End If
    End With
    imgSplit.Move X
    picSplit.Move X
    picDetails.Left = X + 60
    picData.Width = X
    picSplit.Visible = True
End Sub

Private Sub Form_Load()
    tvwData.ImageList = imlTree
    Information_FieldType
    Information_Clear
End Sub

Private Sub Form_Resize()
    Main_Resize
End Sub

Private Sub Main_Resize()
    Dim sngTemp As Single
    
    If eWindowState = vbMinimized Then eWindowState = Me.WindowState: Exit Sub
    eWindowState = Me.WindowState
    If eWindowState = vbMinimized Then Exit Sub
    With picMain
        qSplit.sRight = .ScaleWidth \ 2 + 30
        qSplit.sLeft = .ScaleWidth \ 4 + 30
        imgSplit.Height = .ScaleHeight
    End With
    If imgSplit.Left < qSplit.sLeft Then imgSplit.Left = qSplit.sLeft
    If imgSplit.Left > qSplit.sRight Then imgSplit.Left = qSplit.sRight
    With imgSplit
        picSplit.Move .Left, .Top, .Width, .Height
        picData.Move 0, 0, .Left, .Height
        sngTemp = .Left + 60
        picDetails.Move sngTemp, 0, picMain.ScaleWidth - sngTemp, picMain.ScaleHeight
    End With
    picDataBar.Move 0, 0, picData.ScaleWidth
    lblData.Width = picDataBar.ScaleWidth - 120
    picDetailsBar.Move 0, 0, picDetails.ScaleWidth
    lblDetails.Width = picDetailsBar.ScaleWidth - 120
    sngTemp = picDataBar.Height
    tvwData.Move 0, sngTemp, picData.ScaleWidth, picData.ScaleHeight - sngTemp
    lvDetails.Move 0, sngTemp, picDetails.ScaleWidth, picDetails.ScaleHeight - sngTemp
    If lvDetails.Width > 5340 Then
        lvDetails.ColumnHeaders(1).Width = (lvDetails.Width - 840) / 3
        lvDetails.ColumnHeaders(2).Width = (lvDetails.Width - 840) / 3 * 2
    Else
        lvDetails.ColumnHeaders(1).Width = 1500
        lvDetails.ColumnHeaders(2).Width = 3000
    End If
End Sub

Public Sub Information_Clear()
    Dim tvNode As Node
    
    lblData.Caption = "数据库(Access)"
    cmdCopy.Enabled = False
    cmdSave.Enabled = False
    tvwData.Nodes.Clear
    Set tvNode = tvwData.Nodes.Add(, , "Main", "请您打开数据库(Access)")
    lvDetails.ListItems.Clear
End Sub

Public Function Database_Open() As Boolean
    On Local Error GoTo Database_Open_Error
    
    cmData.Filter = "Access Database (*.mdb)|*.mdb|All files (*.*)|*.*"
    cmData.FilterIndex = 0
    cmData.DialogTitle = "Open File..."
    cmData.CancelError = True
    cmData.ShowOpen
    Set qData = Nothing
    Set qData = DBEngine.OpenDatabase(cmData.FileName, True, True)
    qDB.Name = cmData.FileTitle
    Database_Open = True
    Exit Function
Database_Open_Error:
    Database_Open = False
    If Err.Number = cdlCancel Then Exit Function
    MsgBox "An error occured while trying to open " & cmData.FileName & vbCrLf & "Error: " & Err.Description
End Function

Public Sub Information_Update()
    Dim iTable As Integer
    Dim iRelate As Integer
    Dim iIndex As Integer
    Dim iField As Integer
    Dim iCount As Integer
    Dim qTable As TableDef
    Dim sTableNode As String
    Dim qField As Field
    Dim qIndex As Index
    Dim qRelation As Relation
    Dim qQuery As QueryDef
    Dim sSQLQueryText As String
    Dim qNode As Node
    Dim iNode As Integer
    
    ReDim qlNode(0)
    ReDim qlTable(0)
    ReDim qlRelation(0)
    ReDim qlField(0)
    ReDim qlIndex(0)
    ReDim qlQuery(0)

    With qDB
        .Relations = qData.Relations.Count
        .Tables = qData.TableDefs.Count
        .Queries = qData.QueryDefs.Count
        .Fields = 0
        .Indexes = 0
        If .Relations > 1 Or .Tables > 1 Then
        .ItemCount = True
        Else
        .ItemCount = False
        End If
    End With
    tvwData.Nodes.Clear
    Set qNode = tvwData.Nodes.Add(, tvwFirst, "D0", "数据库: " & qDB.Name, "dbOpen")
    qNode.Tag = 0
    qlNode(0).Name = qDB.Name
    qlNode(0).Reference = 0
    qlNode(0).Type = qdDatabase
    iNode = 1
    ReDim qlTable(0 To qDB.Tables)
    iTable = 0
    Do While iTable <= qDB.Tables - 1
        Set qTable = qData.TableDefs(iTable)
        If CBool(qTable.Attributes And TableDefAttributeEnum.dbSystemObject) Then
            qlTable(iTable).Name = "#"
            GoTo IU_Table_Complete
        End If
        
        With qlTable(iTable)
            .Name = qTable.Name
            .Fields = qTable.Fields.Count
            If .Fields > 1 Or .Indexes > 1 Then qDB.ItemCount = True
            qDB.Fields = qDB.Fields + .Fields
            'qDB.Indexes = qDB.Indexes + .Indexes
            sTableNode = "T" & iNode
            Set qNode = tvwData.Nodes.Add("D0", tvwChild, sTableNode, "表: " & .Name, "Table")
            qNode.Tag = iNode
            ReDim Preserve qlNode(iNode)
            qlNode(iNode).Name = .Name
            qlNode(iNode).Reference = iTable
            qlNode(iNode).Type = qdTable
            iNode = iNode + 1
            ' Get table attributes
            If CBool(qTable.Attributes And TableDefAttributeEnum.dbAttachedODBC) Then .Attributes = Attributes_Add(.Attributes, "dbAttachedODBC")
            If CBool(qTable.Attributes And TableDefAttributeEnum.dbAttachedTable) Then .Attributes = Attributes_Add(.Attributes, "dbAttachedTable")
            If CBool(qTable.Attributes And TableDefAttributeEnum.dbAttachExclusive) Then .Attributes = Attributes_Add(.Attributes, "dbAttachExclusive")
            If CBool(qTable.Attributes And TableDefAttributeEnum.dbAttachSavePWD) Then .Attributes = Attributes_Add(.Attributes, "dbAttachSavePWD")
            If CBool(qTable.Attributes And TableDefAttributeEnum.dbHiddenObject) Then .Attributes = Attributes_Add(.Attributes, "dbHiddenObject")
            If CBool(qTable.Attributes And TableDefAttributeEnum.dbSystemObject) Then .Attributes = Attributes_Add(.Attributes, "dbSystemObject")
        End With
        ' Get Field information
        iCount = 0
        Do While iCount <= qlTable(iTable).Fields - 1
            Set qField = qTable.Fields(iCount)
            ReDim Preserve qlField(0 To iField)
            With qlField(iField)
                .Name = qField.Name
                .DefaultValue = qField.DefaultValue
                .Required = qField.Required
                .Size = qField.Size
                .Type = qField.Type
                .Table = iTable
                .Index = False
                If CBool(qField.Attributes And FieldAttributeEnum.dbAutoIncrField) Then .Attributes = Attributes_Add(.Attributes, "dbAutoIncrField")
                If CBool(qField.Attributes And FieldAttributeEnum.dbFixedField) Then .Attributes = Attributes_Add(.Attributes, "dbFixedField")
                If CBool(qField.Attributes And FieldAttributeEnum.dbHyperlinkField) Then .Attributes = Attributes_Add(.Attributes, "dbHyperlinkField")
                If CBool(qField.Attributes And FieldAttributeEnum.dbSystemField) Then .Attributes = Attributes_Add(.Attributes, "dbSystemField")
                If CBool(qField.Attributes And FieldAttributeEnum.dbUpdatableField) Then .Attributes = Attributes_Add(.Attributes, "dbUpdatableField")
                If CBool(qField.Attributes And FieldAttributeEnum.dbVariableField) Then .Attributes = Attributes_Add(.Attributes, "dbVariableField")
                Set qNode = tvwData.Nodes.Add(sTableNode, tvwChild, "F" & iNode, "字段: " & .Name, "Field")
                qNode.Tag = iNode
                ReDim Preserve qlNode(iNode)
                qlNode(iNode).Name = .Name
                qlNode(iNode).Reference = iField
                qlNode(iNode).Type = qdField
                iNode = iNode + 1
            End With
            iField = iField + 1
            iCount = iCount + 1
        Loop
        'Find Index information
        iCount = 0
        Do While iCount <= qTable.Indexes.Count - 1 ' qlTable(iTable).Indexes - 1
            Set qIndex = qTable.Indexes(iCount)
            If Not qTable.Indexes(iCount).Foreign Then
                qlTable(iTable).Indexes = qlTable(iTable).Indexes + 1
                ReDim Preserve qlIndex(0 To iIndex)
                
                ' Get Index information
                With qlIndex(iIndex)
                
                    .Name = qIndex.Name
                    .FieldIndex = Information_Index_Get(qIndex.Fields(0).Name, qdField, iTable)
                    qlField(.FieldIndex).Index = True
                    .Sort = CBool(qIndex.Fields(0).Attributes And dbDescending)
                    .Table = iTable
                    .Primary = qIndex.Primary
                    .Required = qIndex.Required
                    .Unique = qIndex.Unique
                    Set qNode = tvwData.Nodes.Add(sTableNode, tvwChild, "I" & iNode, "索引: " & .Name, "Index")
                    qNode.Tag = iNode
                    ReDim Preserve qlNode(iNode)
                    qlNode(iNode).Name = .Name
                    qlNode(iNode).Reference = iIndex
                    qlNode(iNode).Type = qdIndex
                    iNode = iNode + 1
                End With
                iIndex = iIndex + 1
            End If
            iCount = iCount + 1
        Loop
        qDB.Indexes = qDB.Indexes + qlTable(iTable).Indexes
IU_Table_Complete:
        iTable = iTable + 1
    Loop
    ' Query Information
    If qDB.Queries > 0 Then
        Set qNode = tvwData.Nodes.Add("D0", tvwChild, "QUERY", "视图", "Query")
        qNode.Tag = iNode
        ReDim Preserve qlNode(iNode)
        qlNode(iNode).Name = "Queries"
        qlNode(iNode).Reference = 0
        qlNode(iNode).Type = qdQueries
        iNode = iNode + 1
    End If
    iCount = 0
    Do While iCount <= qDB.Queries - 1
        Set qQuery = qData.QueryDefs(iCount)
        ReDim Preserve qlQuery(0 To iCount)
        With qlQuery(iCount)
            .Name = qQuery.Name
            .Fields = qQuery.Fields.Count
            .Type = qQuery.Type
            Select Case .Type
                Case QueryDefTypeEnum.dbQAction
                    .TypeText = "Action"
                Case QueryDefTypeEnum.dbQAppend
                    .TypeText = "Append"
                Case QueryDefTypeEnum.dbQCompound
                    .TypeText = "Compound"
                Case QueryDefTypeEnum.dbQCrosstab
                    .TypeText = "Crosstab"
                Case QueryDefTypeEnum.dbQDDL
                    .TypeText = "DDL"
                Case QueryDefTypeEnum.dbQDelete
                    .TypeText = "Delete"
                Case QueryDefTypeEnum.dbQMakeTable
                    .TypeText = "Make Table"
                Case QueryDefTypeEnum.dbQProcedure