by Buddhika Fernando. (6 Submissions)
Category: Databases/Data Access/DAO/ADO
Compatability: Visual Basic 5.0
Difficulty: Unknown Difficulty
Originally Published: Thu 15th June 2006
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Delete Thousands Of Tables And Thousands Of records of Data In Less Than 10 Seconds
API Declarations
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
VBcoders
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
No comments have been posted about Delete Thousands Of Tables And Thousands Of records of Data In Less Than 10 Seconds. Why not be the first to post a comment about Delete Thousands Of Tables And Thousands Of records of Data In Less Than 10 Seconds.
