' Put in a Module '****************************************************************** Option Explicit Public CON As New ADODB.Connection Public CMD As New ADODB.Command Public RCS As New ADODB.Recordset Public ConnStr As String Public DBName As String Dim sPSFalse As String Dim sJET As String Dim DBPass As String Dim sPass As String Public conTable As String Public Sub Set_DBVariables() 'On Error GoTo Err_Proc sJET = "Provider='Microsoft.JET.OLEDB.4.0';Data Source=" If DBName = "" Then DBName = App.path & "\Database" If Right$(DBName, 1) "\" Then DBName = DBName & "\" DBName = DBName & "\temp.mdb" DBName = Replace(DBName, "\\", "\") End If sPSFalse = ";Persist Security Info=False" DBPass = ";Jet OLEDB:Database Password=" & sPass & "; " Exit Sub Err_Proc: Call Error("Set_DBVariables") End Sub Public Sub Open_DB() 'On Error GoTo Err_Proc '------[ START CHECK ]------ If Not (CON Is Nothing) Then If (CON.State And adStateOpen) = adStateOpen Then CON.Close Set CON = Nothing End If '------[ END CHECK ]------ Set CON = New ADODB.Connection CON.Open sJET & DBName & sPSFalse & DBPass Exit Sub Err_Proc: Call Error("Open_DB") End Sub Public Sub Open_RS(ByVal strTable As String) 'On Error GoTo Err_Proc RCS.Open "[" & strTable & "]", CON, adOpenStatic, adLockOptimistic Exit Sub Err_Proc: Call Error("Open_RS") End Sub Public Sub Close_Con() 'On Error GoTo Err_Proc '------[ START CHECKS ]------ If Not (CON Is Nothing) Then If (CON.State And adStateOpen) = adStateOpen Then CON.Close Set CON = Nothing End If '------[ END CHECK ]------ Exit Sub Err_Proc: Call Error("Close_Con") End Sub Public Sub Close_rcs() 'On Error GoTo Err_Proc '------[ START CHECKS ]------ If Not (RCS Is Nothing) Then If (RCS.State And adStateOpen) = adStateOpen Then RCS.Close Set RCS = Nothing End If '------[ END CHECK ]------ Exit Sub Err_Proc: Call Error("Close_rcs") End Sub Public Sub Delete_History() 'On Error GoTo Err_Proc Dim sIndex As Integer Dim sName As String Dim sDate As Long Dim Sql As String Call Open_DB Call Open_RS("History") If (RCS.RecordCount > 0) Then RCS.MoveFirst Do Until RCS.EOF sIndex = CStr(Trim(RCS!Index)) sName = CStr(Trim(RCS!name)) sDate = DateDiff("d", DateValue(Now()), DateValue(RCS!DateTime)) If sDate "\" Then DBName = DBName & "\" DBName = DBName & "\temp.mdb" DBName = Replace(DBName, "\\", "\") End If sPSFalse = ";Persist Security Info=False" DBPass = ";Jet OLEDB:Database Password=" & sPass & "; " Exit Sub Err_Proc: Call Error("Set_DBVariables") End Sub Public Sub Open_DB() 'On Error GoTo Err_Proc '------[ START CHECK ]------ If Not (CON Is Nothing) Then If (CON.State And adStateOpen) = adStateOpen Then CON.Close Set CON = Nothing End If '------[ END CHECK ]------ Set CON = New ADODB.Connection CON.Open sJET & DBName & sPSFalse & DBPass Exit Sub Err_Proc: Call Error("Open_DB") End Sub Public Sub Open_RS(ByVal strTable As String) 'On Error GoTo Err_Proc RCS.Open "[" & strTable & "]", CON, adOpenStatic, adLockOptimistic Exit Sub Err_Proc: Call Error("Open_RS") End Sub Public Sub Close_Con() 'On Error GoTo Err_Proc '------[ START CHECKS ]------ If Not (CON Is Nothing) Then If (CON.State And adStateOpen) = adStateOpen Then CON.Close Set CON = Nothing End If '------[ END CHECK ]------ Exit Sub Err_Proc: Call Error("Close_Con") End Sub Public Sub Close_rcs() 'On Error GoTo Err_Proc '------[ START CHECKS ]------ If Not (RCS Is Nothing) Then If (RCS.State And adStateOpen) = adStateOpen Then RCS.Close Set RCS = Nothing End If '------[ END CHECK ]------ Exit Sub Err_Proc: Call Error("Close_rcs") End Sub Public Sub Delete_History() 'On Error GoTo Err_Proc Dim sIndex As Integer Dim sName As String Dim sDate As Long Dim Sql As String Call Open_DB Call Open_RS("History") If (RCS.RecordCount > 0) Then RCS.MoveFirst Do Until RCS.EOF sIndex = CStr(Trim(RCS!Index)) sName = CStr(Trim(RCS!name)) sDate = DateDiff("d", DateValue(Now()), DateValue(RCS!DateTime)) If sDate < -30 Then Debug.Print sDate End If If sDate "\" Then DBName = DBName & "\" DBName = DBName & "\temp.mdb" DBName = Replace(DBName, "\\", "\") End If sPSFalse = ";Persist Security Info=False" DBPass = ";Jet OLEDB:Database Password=" & sPass & "; " Exit Sub Err_Proc: Call Error("Set_DBVariables") End Sub Public Sub Open_DB() 'On Error GoTo Err_Proc '------[ START CHECK ]------ If Not (CON Is Nothing) Then If (CON.State And adStateOpen) = adStateOpen Then CON.Close Set CON = Nothing End If '------[ END CHECK ]------ Set CON = New ADODB.Connection CON.Open sJET & DBName & sPSFalse & DBPass Exit Sub Err_Proc: Call Error("Open_DB") End Sub Public Sub Open_RS(ByVal strTable As String) 'On Error GoTo Err_Proc RCS.Open "[" & strTable & "]", CON, adOpenStatic, adLockOptimistic Exit Sub Err_Proc: Call Error("Open_RS") End Sub Public Sub Close_Con() 'On Error GoTo Err_Proc '------[ START CHECKS ]------ If Not (CON Is Nothing) Then If (CON.State And adStateOpen) = adStateOpen Then CON.Close Set CON = Nothing End If '------[ END CHECK ]------ Exit Sub Err_Proc: Call Error("Close_Con") End Sub Public Sub Close_rcs() 'On Error GoTo Err_Proc '------[ START CHECKS ]------ If Not (RCS Is Nothing) Then If (RCS.State And adStateOpen) = adStateOpen Then RCS.Close Set RCS = Nothing End If '------[ END CHECK ]------ Exit Sub Err_Proc: Call Error("Close_rcs") End Sub Public Sub Delete_History() 'On Error GoTo Err_Proc Dim sIndex As Integer Dim sName As String Dim sDate As Long Dim Sql As String Call Open_DB Call Open_RS("History") If (RCS.RecordCount > 0) Then RCS.MoveFirst Do Until RCS.EOF sIndex = CStr(Trim(RCS!Index)) sName = CStr(Trim(RCS!name)) sDate = DateDiff("d", DateValue(Now()), DateValue(RCS!DateTime)) If sDate < -30 Then Debug.Print sDate End If If sDate < -30 Then ' This Sql = "DELETE * FROM [History] WHERE Index = " & sIndex ' OR This 'Sql = "DELETE * FROM [History] WHERE Name=(""" & sName & """)" ' OR This 'Sql = "DELETE * FROM [History] WHERE Name=[" & sName & "]" ' OR This * NEW 'Sql = "DELETE * FROM [History] WHERE Name =(""" & sName & """) AND Path =(""" & sPath & """)" CON.Execute Sql End If RCS.MoveNext Loop End If Call Close_rcs Call Close_Con Exit Sub Err_Proc: Call Error("Delete_History") Call Close_rcs Call Close_Con End Sub Public Sub Error(ByVal sError As String) If Err.Number = 0 Or Err.Number = 5 Or Err.Number = 91 Then Exit Sub Else MsgBox "Err Number:" & vbTab & Err.Number & vbCrLf & _ "Err Source:" & vbTab & Err.Source & vbCrLf & _ "Err Description: " & vbTab & Err.Description & vbNewLine & _ "In Module: " & vbTab & sError & vbNewLine _ , vbCritical + vbOKOnly, "ErrorException" Exit Sub End If End Sub '****************************************************************** ' Put in a Form or in Setup Calling '****************************************************************** Option Explicit ' Referrences: ' * Microsoft ADO Ext. 2.7/2.8 for DLL and Security ' * Microsoft ActiveX Data Objects 2.7/2.8 Library ' I'd Referrence the 2.8's if you have them if not Referrenced already Private Sub Form_Load() 'On Error GoTo Err_Proc '***************** ' SET UP DataBase Call Set_DBVariables Me.Caption = DBName '****************** Exit Sub Err_Proc: Call Error("Form_Load") End Sub Private Sub Command1_Click() Call Delete_History End Sub