Find Code:
All Words
Any of the Words
Exact Phrase
Home
:
Code
:
Forums
:
Submit
:
Mailing List
:
About
:
Contact
Code
All
VB.NET
ASP.NET
C#
VB Classic
ASP Classic
Snippets
Popular
Resources
Submit Code
Forums
Articles
Tips
Links
Books
Contest
Link to us
Delete Thousands Of Tables And Records
Author:
Gehan Fernando
E-mail:
Click to e-mail author
Submitted:
5/19/2007
Version:
VB6
Compatibility:
VB6
Category:
Databases
Views:
10700
Delete Thousands Of Tables And Thousands Of records of Data In Less Than 10 Seconds.
Declarations:
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
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
Home
|
Forums
|
Submit
|
Books
|
Mailing List
|
Advertising
|
About
|
Contact
© 2024 A1VBCode. All rights reserved.
Legal disclaimer & terms of use
Privacy statement