Solved Problems with "renewal date" code

[HillTJ]

Hi all, I'm attempting to write a module that will return one of several warning messages when a training 'Renewal Date' approaches as Renewals are required 3 years after training.

So, I pass the last 'Completion Date' to the function below & add 3 years to it. (I call it 'dteRenewal' in the function for want of a better name).

I then wish to return a warning at 3 months till renewal, 1 month, 1 week & 'Expired' when the Renewal date is < actual date.

Seems I've gotten my wires crossed & would appreciate some guidance.

Thanks in advance.

Option Compare Database
Option Explicit
Public Function CalcExpiry(dteRenewal As Date) As String
Const conJetDate = "\#mm\/dd\/yyyy\#"
'system date format is dd/mm/yyyy
MsgBox Format(dteRenewal, conJetDate) ' for testing
MsgBox DateAdd("m", 3, Date) 'for testing

Select Case dteRenewal


        Case DateAdd("m", 3, Date) > Format(dteRenewal, conJetDate)
            CalcExpiry = "Expires in 3 Months"
           MsgBox "3 Months"
        
        Case DateAdd("m", 1, Date) > Format(dteRenewal, conJetDate)
            CalcExpiry = "Expires in 1 Month"
            
        Case DateAdd("WW", 1, Date) > Format(dteRenewal, conJetDate)
            CalcExpiry = "Expires in 1 Week"
            
        Case Date > Format(dteRenewal, conJetDate)
            CalcExpiry = "Expired"
 End Select
    MsgBox CalcExpiry
    
End Function

 

[arnelgp]

' arnelgp
Public Function CalcExpiry(ByVal dteRenewal As Date) As String
    Dim imonths As Integer, iweeks As Integer, idays As Integer
    Dim status As String
    dteRenewal = DateAdd("m", 3, dteRenewal)
    idays = DateDiff("d", Date, dteRenewal)
    iweeks = DateDiff("ww", Date, dteRenewal)
    imonths = DateDiff("m", Date, dteRenewal)
    Select Case True
        Case idays < 1
            status = "Expired"
        Case imonths > 0
            status = "Expires in " & imonths & " month(s)"
        Case iweeks > 0
            status = "Expires in " & iweeks & " week(s)"
        Case Else
            status = "Expires in " & idays & " day(s)"
    End Select
    CalcExpiry = status
End Function

 

[Gasman]

Do not format dates when calculating, just do the math on the date field itself.

 

[Gasman]

' arnelgp
Public Function CalcExpiry(ByVal dteRenewal As Date) As String
    Dim imonths As Integer, iweeks As Integer, idays As Integer
    Dim status As String
    Select Case True
        Case idays < 1
            status = "Expired"
        Case imonths > 0
            status = "Expires in " & imonths & " month(s)"
        Case iweeks > 0
            status = "Expires in " & iweeks & " week(s)"
        Case Else
            status = "Expires in " & idays & " day(s)"
    End Select
    CalcExpiry = status
End Function

Arnel, where do any of those case tests get set?

 

[Gasman]

' arnelgp
Public Function CalcExpiry(ByVal dteRenewal As Date) As String
    Dim imonths As Integer, iweeks As Integer, idays As Integer
    Dim status As String
    dteRenewal = DateAdd("m", 3, dteRenewal)
    idays = DateDiff("d", Date, dteRenewal)
    iweeks = DateDiff("ww", Date, dteRenewal)
    imonths = DateDiff("m", Date, dteRenewal)
    Select Case True
        Case idays < 1
            status = "Expired"
        Case imonths > 0
            status = "Expires in " & imonths & " month(s)"
        Case iweeks > 0
            status = "Expires in " & iweeks & " week(s)"
        Case Else
            status = "Expires in " & idays & " day(s)"
    End Select
    CalcExpiry = status
End Function

Sneaky rofl

 

[HillTJ]

Friends, thanks. Will give arnelgp's module a go & let this thread know.

Appreciate the prompt response.

 

[Gasman]

Friends, thanks. Will give arnelgp's module a go & let this thread know.

Appreciate the prompt response.

Do pass the value as a date though, as that is what the function expects.

 

[Gasman]

I would also be careful where you define the conJetDate?
I had mine in the declarations section of a module.
You have yours in the function, and whilst that function is Public, I do not think the Const is available elsewhere?

A quick test

Public Function fnTestConst(dtDate As Date) As String
Const conDate = "\#mm\/dd\/yyyy\#"
Debug.Print "dtDate is " & Format(dtDate, conDate)
End Function

produces

fntestconst(date)
dtDate is #10/03/2022#
? format(date,condate)
03/10/2022

 

[HillTJ]

@Gasman , understood & thanks.

 

[HillTJ]

@arnelgp , thanks. Module works well. Only change I made was dteRenewal = DateAdd("yyyy", 3, dteRenewal) - changed "m" to "YYYY" to reflect 3 years. Appreciate your help and appreciate @Gasman's thoroughness.

 

[arnelgp]

you can also add the Year option?

Public Function CalcExpiry(ByVal dteRenewal As Date) As String
    Dim iyears As Integer, imonths As Integer, iweeks As Integer, idays As Integer
    Dim status As String
    dteRenewal = DateAdd("yyyy", 3, dteRenewal)
    iyears = DateDiff("yyyy", Date, dteRenewal)
    idays = DateDiff("d", Date, dteRenewal)
    iweeks = DateDiff("ww", Date, dteRenewal)
    imonths = DateDiff("m", Date, dteRenewal)
    Select Case True
        Case idays < 1
            status = "Expired"
        Case iyears > 0
            status = "Expires in " & iyears & " year(s)"
        Case imonths > 0
            status = "Expires in " & imonths & " month(s)"
        Case iweeks > 0
            status = "Expires in " & iweeks & " week(s)"
        Case Else
            status = "Expires in " & idays & " day(s)"
    End Select
    CalcExpiry = status
End Function

 

[HillTJ]

@arnelgp , i shall. Cool code. Thanks.