Option Explicit Rem ------------------------------------------- Rem Add Two Command Button Rem One List Box - Checkbox Style Rem One Comman Dialog Box Rem One Progress Bar Control Rem One Check Box Rem Two Label Controls Rem ------------------------------------------- Private Con As ADODB.Connection Private Rec As ADODB.Recordset Private Dbs As ADOX.Catalog Private Tbl As ADOX.Table Private CountData As Long Private Chk As Boolean Private Constr As String

Private Sub Check1_Click() Dim i As Long If Check1.Value = 1 Then Check1.Caption = "&Clear All" For i = 0 To List1.ListCount - 1 List1.Selected(i) = True Next i List1.ListIndex = 0 CmdClearData.SetFocus Else Check1.Caption = "&Select All" For i = 0 To List1.ListCount - 1 List1.Selected(i) = False Next i End If End Sub Private Sub CmdClearData_Click() On Error GoTo Err Screen.MousePointer = vbHourglass Chk = False If List1.ListCount > 0 Then For CountData = 0 To List1.ListCount - 1 If List1.Selected(CountData) = True Then Chk = True Exit For End If Next End If If Chk = False Then MsgBox "Select At Least One Table To Clear Data.", vbExclamation + vbOKOnly, "Clear Database" Screen.MousePointer = vbDefault Exit Sub End If Check1.Enabled = False CmdSelectPath.Enabled = False CmdClearData.Enabled = False Set Con = New ADODB.Connection With Con .Mode = adModeReadWrite .ConnectionString = Constr .Open End With Set Rec = New ADODB.Recordset With Rec .CursorLocation = adUseClient .CursorType = adOpenKeyset .LockType = adLockOptimistic End With Chk = False Con.BeginTrans Chk = True CountData = 0 Prg1.Max = List1.ListCount For CountData = 0 To List1.ListCount - 1 If List1.Selected(CountData) = True Then If Rec.State = 1 Then Rec.Close Dim TBlName As String TBlName = vbNullString TBlName = List1.List(CountData) Rec.Open "DELETE FROM " & TBlName, Con, , , adCmdText End If Label1.Caption = "Status : Deleting " & TBlName Prg1.Value = Prg1.Value + 1 Next CountData Label1.Caption = "Status" Prg1.Value = 0 Con.CommitTrans Set Rec = Nothing Set Con = Nothing Me.Height = 1650 CmdClearData.Enabled = False Text1.Text = "" MsgBox "Selected Table Cleared Successfully.", vbInformation + vbOKOnly, "Clear Database" Screen.MousePointer = vbDefault CmdSelectPath.Enabled = True CmdSelectPath.SetFocus Exit Sub Err: If Err Then Label1.Caption = "Status" MsgBox Err.Description, vbCritical + vbOKOnly, "Error ...!" Screen.MousePointer = vbDefault Me.Height = 1650 List1.Clear Check1.Enabled = False Check1.Value = 0 CmdSelectPath.Enabled = True CmdClearData.Enabled = False If Chk = True Then Con.RollbackTrans End If CmdSelectPath.SetFocus Exit Sub End If End Sub Private Sub CmdSelectPath_Click() On Error GoTo Err Check1.Value = 0 Check1.Enabled = False Check1.Visible = False Text1.Enabled = False Text1.Visible = False Label2.Enabled = False Label2.Visible = False With DLGSelect .CancelError = False .DialogTitle = "Select The Database" .Flags = cdlOFNHideReadOnly Or cdlOFNFileMustExist Or _ cdlOFNShareAware Or cdlOFNExplorer Or _ cdlOFNPathMustExist Or cdlOFNLongNames Or _ cdlOFNNoChangeDir .FilterIndex = 0 .Filter = "MS Access Files (*.Mdb)|*.Mdb|" .Action = 1 If .FileName = "" Then Constr = "": CmdClearData.Enabled = False: Exit Sub Check1.Enabled = False: Check1.Value = 0 List1.Clear: List1.Refresh Constr = Get_ADO_Connection_String(.FileName, Text1.Text) Me.Height = 4545 Call ShowAllTables End With Exit Sub Err: If Err Then MsgBox Err.Description, vbCritical + vbOKOnly, "Error ...!" Me.Height = 1650 DLGSelect.FileName = "" Screen.MousePointer = vbDefault Exit Sub End If End Sub Private Sub Form_Load() Check1.Value = 0 Check1.Enabled = False Check1.Visible = False Text1.Text = "" Text1.Enabled = False Text1.Visible = False Label2.Enabled = False Label2.Visible = False Me.Height = 1650 CmdClearData.Enabled = False End Sub Private Function Get_ADO_Connection_String(ByVal DataPath As String, Optional DPassword As String = "") As String If DataPath = "" Then Exit Function Get_ADO_Connection_String = "" If DPassword = "" Then Get_ADO_Connection_String = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & DataPath & ";" & _ "Persist Security Info=False" Else Get_ADO_Connection_String = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & DataPath & ";" & _ "Persist Security Info=True;" & _ "Jet OLEDB:Database Password=" & DPassword End If End Function Private Sub ShowAllTables() On Error GoTo Err Set Con = New ADODB.Connection With Con .Mode = adModeReadWrite .ConnectionString = Constr .Open End With Set Dbs = New ADOX.Catalog Set Tbl = New ADOX.Table Screen.MousePointer = vbHourglass With Dbs List1.Clear List1.Refresh .ActiveConnection = Con For Each Tbl In Dbs.Tables If Tbl.Type = "TABLE" Then List1.AddItem Tbl.Name End If DoEvents Next End With Set Dbs = Nothing Set Tbl = Nothing Set Con = Nothing Screen.MousePointer = vbDefault If List1.ListCount > 0 Then Check1.Enabled = True: _ Check1.Visible = True: _ Me.Height = 4545 CmdClearData.Enabled = True List1.SetFocus Exit Sub Err: If Err Then If Err.Number = -2147217843 Then MsgBox Err.Description, vbCritical + vbOKOnly, "Error ...!" Me.Height = 4545 CmdClearData.Enabled = False Check1.Enabled = False Check1.Visible = False Text1.Enabled = True Text1.Visible = True Label2.Enabled = True Label2.Visible = True Text1.SetFocus Else DLGSelect.FileName = "" Me.Height = 1650 CmdClearData.Enabled = False Check1.Enabled = False Text1.Enabled = False Text1.Visible = False Label2.Enabled = False Label2.Visible = False MsgBox Err.Description, vbCritical + vbOKOnly, "Error ...!" End If Screen.MousePointer = vbDefault End If End Sub Private Sub Text1_KeyPress(KeyAscii As Integer) On Error GoTo Err If KeyAscii = 13 Then Label2.Enabled = False Label2.Visible = False Text1.Enabled = False Text1.Visible = False Me.Height = 1650 Constr = Get_ADO_Connection_String(DLGSelect.FileName, Text1.Text) Call ShowAllTables DLGSelect.FileName = "" End If Exit Sub Err: If Err Then Check1.Value = 0 Check1.Enabled = False Check1.Visible = False Text1.Text = "" Text1.Enabled = False Text1.Visible = False Label2.Enabled = False Label2.Visible = False MsgBox Err.Description, vbCritical + vbOKOnly, "Error ...!" Me.Height = 1650 DLGSelect.FileName = "" Screen.MousePointer = vbDefault Exit Sub End If End Sub