Author : Buddhika Fernando.
Date Submitted : 6/15/2006
Category : Database
Compatibility : VB 6,VB 5
This code has been accessed 4845 times.
Task : Delete Thousands Of Tables And Thousands Of records of Data In Less Than 10 Seconds
Declarations
Code
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