MDB ADO DateValue

by Quake (33 Submissions)
Category: Databases/Data Access/DAO/ADO
Compatability: VB 6.0
Difficulty: Intermediate
Date Added: Fri 12^th 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.
Rate MDB ADO DateValue
' 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
Download this snippet Add to My Saved Code
MDB ADO DateValue Comments

No comments have been posted about MDB ADO DateValue. Why not be the first to post a comment about MDB ADO DateValue.
MDB ADO DateValue

MDB ADO DateValue Comments

Post your comment

Difficulty
