by Quake (33 Submissions)
Category: Databases/Data Access/DAO/ADO
Compatability: VB 6.0
Difficulty: Intermediate
Date Added: Fri 12th February 2021
Rating: (0 Votes)
Getting the DateValue DateDiff between 2 dates. Useful for setting
up a History Auto delete. Just Added Double Checker. Will only Delete if
they match. Good if you're not using Index/ID's.
' 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