article

MDB ADO DateValue

Email
Submitted on: 10/28/2016 10:40:57 AM
By: Quake 
Level: Intermediate
User Rating: By 2 Users
Compatibility: VB 6.0
Views: 4267
 
     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. Commented out. See * New

This article has accompanying files

 
				'******************************************************************
' 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 < -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

winzip iconDownload article

Note: Due to the size or complexity of this submission, the author has submitted it as a .zip file to shorten your download time. Afterdownloading it, you will need a program like Winzip to decompress it.Virus note:All files are scanned once-a-day by Planet Source Code for viruses, but new viruses come out every day, so no prevention program can catch 100% of them. For your own safety, please:
  1. Re-scan downloaded files using your personal virus checker before using it.
  2. NEVER, EVER run compiled files (.exe's, .ocx's, .dll's etc.)--only run source code.
  3. Scan the source code with Minnow's Project Scanner

If you don't have a virus scanner, you can get one at many places on the net including:McAfee.com


Other 22 submission(s) by this author

 


Report Bad Submission
Use this form to tell us if this entry should be deleted (i.e contains no code, is a virus, etc.).
This submission should be removed because:

Your Vote

What do you think of this article (in the Intermediate category)?
(The article with your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor (See voting log ...)
 

Other User Comments


 There are no comments on this submission.
 

Add Your Feedback
Your feedback will be posted below and an email sent to the author. Please remember that the author was kind enough to share this with you, so any criticisms must be stated politely, or they will be deleted. (For feedback not related to this particular article, please click here instead.)
 

To post feedback, first please login.