• Home
 · 
• Databases/Data Access/DAO/ADO
 · 
• Delete Thousands Of Tables And Thousands Of records of Data In Less Than 10 Seconds

Delete Thousands Of Tables And Thousands Of records of Data In Less Than 10 Seconds

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



Rate Delete Thousands Of Tables And Thousands Of records of Data In Less Than 10 Seconds

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

    
    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