frmmain.frm

ado对数据库的表进行查询、删除等管理操作。

    imgLoading.Visible = True
    Me.Refresh
    SortOrder = True
    LastColumnSort = 0
    Set gridData.DataSource = Nothing
    adoData.RecordSource = ""
    adoData.ConnectionString = ""
    adoData.ConnectionString = dbConnectionString
    adoData.RecordSource = "SELECT * FROM " & ResolveTable(cmbTables.Text)
    adoData.Refresh
    txtSqlStatement = adoData.RecordSource
    If adoData.Recordset.Fields.Count = 0 Then
        gridData.ClearFields
    Else
        Set gridData.DataSource = adoData.Recordset
        gridData.ClearFields
        gridData.ReBind
    End If
    lblStatus.caption = "Record Count: " & adoData.Recordset.RecordCount
    imgLoading.Visible = False
    LockTextBox = False
    Exit Sub
e_Trap:
    lblStatus.caption = "Error: " & Err.Description & " (" & Err.Number & ")"
    imgLoading.Visible = False
    LockTextBox = False

End Sub

Private Sub gridData_HeadClick(ByVal ColIndex As Integer)
Dim startingSql As String
Dim lastSql As String

    On Error GoTo e_Trap
    LockTextBox = True
    imgLoading.Visible = True
    Me.Refresh
    Call LockWindow(gridData.hwnd)
    If LastColumnSort = ColIndex Then
        SortOrder = Not SortOrder
    Else
        SortOrder = True
    End If
    lastSql = adoData.RecordSource
    If cmbTables.Text = DEF_CUSTOM_SQL Then
        If InStr(1, UCase(txtSqlStatement), "ORDER BY") <> 0 Then
            startingSql = Mid(txtSqlStatement, 1, InStr(1, UCase(txtSqlStatement), "ORDER BY") - 2)
            adoData.RecordSource = startingSql & " ORDER BY " & ResolveTable(adoData.Recordset.Fields(ColIndex).Name) & " " & IIf(SortOrder, "ASC", "DESC")
        Else
            adoData.RecordSource = txtSqlStatement & " ORDER BY " & ResolveTable(adoData.Recordset.Fields(ColIndex).Name) & " " & IIf(SortOrder, "ASC", "DESC")
        End If
    Else
        adoData.RecordSource = "SELECT * FROM " & ResolveTable(cmbTables.Text) & " ORDER BY " & ResolveTable(adoData.Recordset.Fields(ColIndex).Name) & " " & IIf(SortOrder, "ASC", "DESC")
    End If
    LastColumnSort = ColIndex
    txtSqlStatement = adoData.RecordSource
    adoData.Refresh
    Set gridData.DataSource = adoData
    cmbTables.SetFocus
    Call ReleaseWindow
    imgLoading.Visible = False
    LockTextBox = False
    Exit Sub
e_Trap:
    lblStatus.caption = "Order Error: " & Err.Description & " (" & Err.Number & ")"
    If adoData.Recordset Is Nothing And lastSql <> "" Then
        adoData.RecordSource = lastSql
        adoData.Refresh
    End If
    Call ReleaseWindow
    LockTextBox = False
End Sub



Private Sub mnuAddColumn_Click()
    frmAddColumn.sTableName = ResolveTable(cmbTables.Text)
    frmAddColumn.Show vbModal, Me
End Sub

Private Sub mnuAddTable_Click()
    frmAddTable.Show vbModal, Me
End Sub

Private Sub mnuClearPassword_Click()
    mnuClearPassword.Visible = False
    Call SaveSetting(App.Title, DEF_REGISTRY_CONNECTIONS & "\" & DEF_ACCESS, "Database Password", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
End Sub

Private Sub mnuCompact_Click()
Dim JetEngine As New JRO.JetEngine
Dim tempFilename As String
Dim startingType As String
Dim endingType As String
Dim existingTable As String
Dim errorMessage As String
    
    On Error GoTo e_Trap
    
    If Dir(dbPath) = "" Or Trim(dbPath) = "" Then Exit Sub
    
    Call frmConnecting.ShowConnecting("Connecting to " & "Compacting Access Database...", Me)
    If dbObj.State = adStateOpen Then
        On Error Resume Next
        existingTable = frmMain.cmbTables.Text
        Set dbObj = New ADODB.Connection
        Set adoData = New ADODB.Connection
        adoData.Recordset.ActiveConnection = Nothing
        On Error GoTo e_Trap
    End If
    
    tempFilename = Mid(dbPath, 1, Len(dbPath) - 4) & "2.mdb"
    If Dir(tempFilename) <> "" Then
        Kill tempFilename
    End If
    
    startingType = "Provider=Microsoft.Jet.OLEDB." & DEF_ACCESS97_OLEDB & ";" & "Data Source=" & dbPath & ";"
    
    startingType = "Jet OLEDB:Engine Type=4;" & "Data Source=" & dbPath
    endingType = "Provider=Microsoft.Jet.OLEDB." & DEF_ACCESS2K_OLEDB & ";" & "Data Source=" & tempFilename & ";"
    
    JetEngine.CompactDatabase startingType, endingType
            
    If Dir(tempFilename) <> "" Then
        Kill dbPath
        Call FileCopy(tempFilename, dbPath)
        Kill tempFilename
    End If
    
    frmConnecting.Hide
    Call frmMain.SetupDatabase(existingTable)
    Exit Sub
e_Trap:
    errorMessage = "Error: CompactAccessDatabase - " & Err.Description & " (" & Err.Number & ")"
    Call MsgBox(errorMessage, vbOKOnly + vbCritical, "Compact Error")
    frmConnecting.Hide
    Call frmMain.SetupDatabase(existingTable)
End Sub
Private Sub mnuDeleteColumn_Click()
Dim ret As Integer
    On Error GoTo e_Trap
    If gridData.Row <= 0 And gridData.SelStartCol <> -1 And adoData.Recordset.Fields.Count > 1 Then
        ret = MessageBox(Me.hwnd, "Are you sure you want to delete " & adoData.Recordset.Fields(gridData.SelStartCol).Name & " from " & cmbTables.Text & "?", vbYesNo + vbQuestion, "Delete Column")
        If ret = vbYes Then
            Call dbObj.Execute("ALTER TABLE " & ResolveTable(cmbTables.Text) & " DROP COLUMN [" & adoData.Recordset.Fields(gridData.SelStartCol).Name & "]")
            Call SetupDatabase(cmbTables.Text)
        End If
    End If
e_Trap:
    Exit Sub
End Sub

Private Sub mnuDropTable_Click()
Dim ret As Integer
    If cmbTables.Text = DEF_CUSTOM_SQL Then
        Exit Sub
    End If
    ret = MessageBox(Me.hwnd, "Are you sure you want to drop Table: " & cmbTables.Text & "?", vbYesNo + vbQuestion, "Drop Table")
    If ret = vbYes Then
        Call dbObj.Execute("DROP TABLE " & ResolveTable(cmbTables.Text))
        Call GetTableList
    End If
End Sub

Private Sub mnuEditMode_Click()
    chkEditMode.Value = IIf(chkEditMode.Value = vbChecked, vbUnchecked, vbChecked)
End Sub

Private Sub mnuExit_Click()
    Unload Me
End Sub

Private Function SelectFile(Title As String, filter As String, flags As Long, defaultExtension As String, Optional saveFile As Boolean = True, Optional lastFilename As String) As String
Dim sOpen As SelectedFile
Dim filename As String
Dim ret As Integer

    On Error GoTo e_Browse
    FileDialog.sFilter = filter
    FileDialog.flags = flags
    FileDialog.sDlgTitle = Title
    FileDialog.sInitDir = DetermineDirectory(lastFilename)
    FileDialog.sFile = DetermineFilename(lastFilename)
    
    Do While filename = ""
        If saveFile = False Then
            sOpen = ShowOpen(Me.hwnd, True)
        Else
            sOpen = ShowSave(Me.hwnd, True)
        End If
        If sOpen.sFiles(1) = "" Then
            ret = MessageBox(Me.hwnd, "Please select a " & Title, vbOKCancel + vbInformation, "Missing Filename")
            If ret = vbCancel Then
                Exit Function
            End If
        Else
            filename = sOpen.sLastDirectory & sOpen.sFiles(1)
            If InStr(1, filename, ".") = 0 Then
                If LCase(Right(filename, 4)) <> "." & defaultExtension Then
                    filename = filename & "." & defaultExtension
                End If
            End If
            SelectFile = filename
        End If
    Loop
    Exit Function
e_Browse:
    SelectFile = ""
    Exit Function
End Function


Private Sub mnuOpenAccess_Click()
Dim openFile As String
Dim lastFile As String
    On Error GoTo e_Trap
    Call SaveDefaultTable
    
    lastFile = GetSetting(App.Title, DEF_REGISTRY_CONNECTIONS & "\" & DEF_ACCESS, "Database Path", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
    openFile = SelectFile("Select Database", "Microsoft Access Database (*.mdb)" & Chr$(0) & "*.mdb", &H4 + &H1000, "mdb", False, lastFile)
    If openFile <> "" Then
        LastOpenedType = e_LastOpened_Access
        dbPath = openFile
        dbType = e_databaseTypes_AccessFile
        If lastFile <> openFile Then
            Call SaveSetting(App.Title, DEF_REGISTRY_CONNECTIONS & "\" & DEF_ACCESS, "Database Password", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
        End If
        Call SaveSetting(App.Title, DEF_REGISTRY_CONNECTIONS & "\" & DEF_ACCESS, "Database Path", dbPath, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
        dbConnectionString = "Driver={Microsoft Access Driver (*.mdb)};Dbq=" & dbPath & ";DefaultDir=" & DetermineDirectory(dbPath) & ";"
        Call SetupDatabase
    End If
    Exit Sub
e_Trap:
    Call MessageBox(Me.hwnd, "Error:" & Err.Description & " (" & Err.Number & ")", vbOKOnly + vbCritical, "Error")
End Sub


Private Sub mnuOpenNetwork_Click()
    Call SaveDefaultTable
    frmNetwork.Show vbModal, Me
End Sub

Private Sub mnuedit_Click()
    If cmbTables.Text = DEF_CUSTOM_SQL Then
        mnuDropTable.Enabled = False
    Else
        mnuDropTable.Enabled = True
    End If
    If adoData.Recordset Is Nothing Then
        mnuDeleteColumn.Enabled = False
        mnuRenameColumn.Enabled = False
    Else
        If gridData.Row <= 0 And gridData.SelStartCol <> -1 And adoData.Recordset.Fields.Count > 1 Then
            mnuDeleteColumn.Enabled = True
        Else
            mnuDeleteColumn.Enabled = False
        End If
        If cmbTables.Text <> DEF_CUSTOM_SQL And adoData.Recordset.Fields.Count > 0 Then
            mnuRenameColumn.Enabled = True
        Else
            mnuRenameColumn.Enabled = False
        End If
    End If
End Sub

Private Sub mnuPurgeDate_Click()
    frmPurgeDate.cmbTables.ListIndex = cmbTables.ListIndex
    frmPurgeDate.Show vbModal, Me
End Sub

Private Sub mnuReload_Click()
    Call SetupDatabase(cmbTables.Text)
End Sub

Private Sub mnuRenameColumn_Click()
    Call frmRenameColumn.ReloadColumns(gridData.SelStartCol)
    frmRenameColumn.Show vbModal, Me
End Sub

Private Sub mnuRenameTable_Click()
    frmRenameTable.cmbTables.ListIndex = cmbTables.ListIndex
    frmRenameTable.Show vbModal, Me
End Sub

Private Sub mnuShowSQL_Click()
    mnuShowSQL.Checked = Not mnuShowSQL.Checked
    Call Form_Resize
End Sub

Private Sub mnuViewColumns_Click()
    frmViewColumns.Show vbModal, Me
End Sub

Private Sub txtSqlStatement_Change()
    If Trim(txtSqlStatement) = "" Then
        cmdExecute.Enabled = False
    Else
        cmdExecute.Enabled = True
        cmdExecute.Default = True
        If LockTextBox = False Then
            LockTextBox = True
            cmbTables.ListIndex = cmbTables.ListCount - 1
            LockTextBox = False
        End If
    End If
End Sub

Private Sub txtSqlStatement_LostFocus()
    cmdExecute.Default = False
End Sub