VBA Snippets

Date_ControlAddDays

Public Sub Date_ControlAddDays( _
         ByVal ctlControlDay As Control)

Const sPROCNAME As String = "Date_ControlAddDays"

Dim idaycount As Integer
   For idaycount = 1 To 31
      ctlControlDay.AddItem idaycount
   Next idaycount
End Sub

Date_ControlAddMonths

Public Sub Date_ControlAddMonths( _
         ByVal ctlControlMonth As Control)

Const sPROCNAME As String = "Date_ControlAddMonths"

   On Error GoTo ErrorHandler
   With ctlControlMonth
      .AddItem "January":     .AddItem "February":      .AddItem "March"
      .AddItem "April":       .AddItem "May":           .AddItem "June"
      .AddItem "July":        .AddItem "August":        .AddItem "September"
      .AddItem "October":     .AddItem "November":      .AddItem "December"
   End With

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "add the months to the control '" & ctlControlMonth.Name & "'.")
End Sub

Date_ControlAddYears

Public Sub Date_ControlAddYears( _
         ByVal ctlControlYear As Control, _
         ByVal iNoOfFutureYears As Integer, _
         ByVal bInclude2Previous As Boolean)

Const sPROCNAME As String = "Date_ControlAddYears"
   On Error GoTo ErrorHandler

   Dim inoofyears As Integer
   With ctlControlYear
      If bInclude2Previous = True Then .AddItem Year(Now()) - 2
      If bInclude2Previous = True Then .AddItem Year(Now()) - 1
      
      For inoofyears = Year(Now()) To (Year(Now()) + iNoOfFutureYears)
         .AddItem inoofyears
      Next inoofyears
   End With

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "add the years to the control '" & ctlControlYear.Name & "'.")
End Sub

Date_ControlCheckValid

Public Function Date_ControlCheckValid( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control) _
         As Boolean

Const sPROCNAME As String = "Date_ControlCheckValid"
Dim sDate As String
Dim iday As Integer
   On Error GoTo ErrorHandler

   Form_DateCheckValid = True
   If ctlControlDay.ListIndex > -1 And _
      ctlControlMonth.ListIndex > -1 And _
      ctlControlYear.ListIndex > -1 Then
      sDate = ctlControlDay.ListIndex + 1 & "/" & _
              ctlControlMonth.ListIndex + 1 & "/" & _
              ctlControlYear.List(ctlControlYear.ListIndex)
      If Date_Valid(sDate) = False Then
         Call MsgBox("This is not a valid date. Please choose a valid date.", vbInformation, _
                     "BET: Invalid Date")
         Form_DateCheckValid = False
      Else
         sLastDate = sDate
      End If
   End If

   If gbDEBUG_ERRMSG = False Then Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "check if the selected date is valid.")
End Function

Date_ControlCheckValidDay

Public Sub Date_ControlCheckValidDay( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control)

Const sPROCNAME As String = "Date_ControlCheckValidDay"
Dim ipreviousindex As Integer
   On Error GoTo ErrorHandler

   If ctlControlMonth.ListIndex = -1 Or ctlControlYear.ListIndex = -1 Then Exit Sub
   If Len(gsLastDate) = 0 Then
      gsLastDate = Date_ControlReturn(ctlControlDay, ctlControlMonth, ctlControlYear)
   End If
   
   ipreviousindex = Day(gsLastDate) - 1
   If Date_ControlCheckValid(ctlControlDay, ctlControlMonth, ctlControlYear) = False Then
      ctlControlDay.ListIndex = ipreviousindex
   End If

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "check if the 'day' selected is valid.")
End Sub

Date_ControlCheckValidMonth

Public Sub Date_ControlCheckValidMonth( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control)

Const sPROCNAME As String = "Date_ControlCheckValidMonth"
Dim ipreviousindex As Integer
   On Error GoTo ErrorHandler

   If ctlControlDay.ListIndex = -1 Or ctlControlYear.ListIndex = -1 Then Exit Sub
   If Len(gsLastDate) = 0 Then
      gsLastDate = Date_ControlReturn(ctlControlDay, ctlControlMonth, ctlControlYear)
   End If
   
   ipreviousindex = Month(gsLastDate) - 1
   If Date_ControlCheckValid(ctlControlDay, ctlControlMonth, ctlControlYear) = False Then
      ctlControlMonth.ListIndex = ipreviousindex
   End If

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "check if the 'month' selected is valid.")
End Sub

Date_ControlCheckValidYear

Public Sub Date_ControlCheckValidYear( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control)

Const sPROCNAME As String = "Date_ControlCheckValidYear"
Dim ipreviousindex As Integer
   On Error GoTo ErrorHandler

   If ctlControlDay.ListIndex = -1 Or ctlControlMonth.ListIndex = -1 Then Exit Sub
   If Len(gsLastDate) = 0 Then
      gsLastDate = Date_ControlReturn(ctlControlDay, ctlControlMonth, ctlControlYear)
   End If
   
   ipreviousindex = Year(gsLastDate) - 2
   If Date_ControlCheckValid(ctlControlDay, ctlControlMonth, ctlControlYear) = False Then
      ctlControlYear.ListIndex = ipreviousindex
   End If

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "check if the 'year' selected is valid.")
End Sub

Date_ControlReturn

Public Function Date_ControlReturn( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control, _
Optional ByVal sFormat As String = "dd mmm yyyy") _
         As String

Const sPROCNAME As String = "Date_ControlReturn"
   On Error GoTo ErrorHandler

   Dim sdateformat As String
   sdateformat = ctlControlDay.Text & " " & _
                 ctlControlMonth.Text & " " & _
                 ctlControlYear.Text
                        
   sdateformat = Format(sdateformat, sFormat)
              
   Date_ControlReturn = sdateformat
                        
   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "return the selected date from the date controls.")
End Function

Date_ControlSelect

Public Sub Date_ControlSelect( _
         ByVal iDay As Integer, _
         ByVal iMonth As Integer, _
         ByVal iYear As Integer, _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control)

Const sPROCNAME As String = "Date_ControlSelect"
   On Error GoTo ErrorHandler

   ctlControlDay.ListIndex = iDay - 1
   ctlControlMonth.ListIndex = iMonth - 1
   ctlControlYear.ListIndex = iYear - giSTARTYEAR

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "select the following date from the date controls:" & vbCrLf & _
        """" & iDay & " " & iMonth & " " & iYear & """")
End Sub

Date_ControlSelectCurrent

Public Sub Date_ControlSelectCurrent( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _ 
         ByVal ctlControlYear As Control)

Const sPROCNAME As String = "Date_ControlSelectCurrent"
   On Error GoTo ErrorHandler

   ctlControlDay.ListIndex = Day(Now()) - 1
   ctlControlMonth.ListIndex = Month(Now()) - 1
   ctlControlYear.ListIndex = 2    'always display 5 years 2 before and 2 after

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "select the current date from the date controls.")
End Sub

Date_ControlSelectCurrentDay

Public Sub Date_ControlSelectCurrentDay( _
         ByVal ctlControlDay As Control)

   ctlControlDay.ListIndex = Day(Now()) - 1
End Sub

Date_ControlSelectCurrentMonth

Public Sub Date_ControlSelectCurrentMonth( _
         ByVal ctlControlMonth As Control)

   ctlControlMonth.ListIndex = Month(Now()) - 1
End Sub

Date_ControlSelectCurrentYear

Public Sub Date_ControlSelectCurrentYear( _
         ByVal ctlControlYear As Control)

   ctlControlYear.ListIndex = Year(Now()) - giSTARTYEAR
End Sub

Date_ConvertToString

Public Function Date_ConvertToString( _
         ByVal sDateValue As String, _
         ByVal sDateFormatFrom As String, _
Optional ByVal sDateFormatTo As String = "dd-mmm-yyyy", _
Optional ByVal bInformUser As Boolean = True) _
         As String

Const sPROCNAME As String = "Date_ConvertToString"
Dim sDate As String
Dim dtdate As Date
      
   On Error GoTo ErrorHandler
                             
   If Date_IsValid(sDateValue, sDateFormatFrom) = False Then
      If bInformUser = True Then
         Call MsgBox("Unable to convert the value '" & sDate & "' to a date.")
      End If
      Date_ConvertToString = ""
      Exit Function
   Else
      dtdate = Date_StrToDate(sDateValue, sDateFormatFrom)
      
      Date_ConvertToString = Format(dtdate, sDateFormatTo)
   End If

   If gbDEBUG = False Then Exit Function

ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number & " " & Err.Description)
End Function

Date_DayAbbreviation

Public Function Date_DayAbbreviation( _
         ByVal iDayNo As Integer, _
Optional ByVal iNoOfChars As Integer = 3) As String

Const sPROCNAME As String = "Date_DayAbbreviation"                              
   On Error GoTo ErrorHandler

   If iDayNo > 7 Then iDayNo = iDayNo Mod 7
   Select Case iDayNo
      Case "1": Date_DayAbbreviation = Left("Monday", iNoOfChars)
      Case "2": Date_DayAbbreviation = Left("Tuesday", iNoOfChars)
      Case "3": Date_DayAbbreviation = Left("Wednesday", iNoOfChars)
      Case "4": Date_DayAbbreviation = Left("Thursday", iNoOfChars)
      Case "5": Date_DayAbbreviation = Left("Friday", iNoOfChars)
      Case "6": Date_DayAbbreviation = Left("Saturday", iNoOfChars)
      Case "7": Date_DayAbbreviation = Left("Sunday", iNoOfChars)
   End Select

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "return the abbreviation for day number '" & iDayNo & "'.")
End Function

Date_FormatCheck

Public Function Date_FormatCheck( _
         ByVal sDate As String, _
Optional ByVal bInformUser As Boolean = False) _
         As Boolean

Const sPROCNAME As String = "Date_FormatCheck"
Dim sFormat As String
   On Error GoTo ErrorHandler
   
   If Date_IsValid(Right(sDate, 2) & "-" & Mid(sDate, 5, 2) & "-" & Left(sDate, 4)) = True Then
      Date_FormatCheck = CDate(Right(sDate, 2) & "-" & Mid(sDate, 5, 2) & "-" & Left(sDate, 4))
   Else
      If bInformUser = True Then
         Call MsgBox("The value '" & sDate & "' is not date !" & vbCrLf & vbCrLf & _
                     "Unable to convert this to a date.")
      End If
      Date_FormatCheck = ""
   End If
   If gbDEBUG = False Then Exit Function

ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number & " " & Err.Description)
End Function

Date_FormatUSUK

Converts a date string between the US and the UK formats.

Public Function Date_FormatUSUK( _
         ByVal sDateValue As String, _
         ByVal sDateFormat As String, _
Optional ByVal bInUsFormat As Boolean = False) _
         As String

Const sPROCNAME As String = "Date_FormatUSUK"
Dim ifirstslash As Integer
Dim isecondslash As Integer
   On Error GoTo ErrorHandler

   If bInUsFormat = False Then
      ifirstslash = InStr(sDateValue, "/")
      isecondslash = ifirstslash + _
                             InStr(Right(sDateValue, Len(sDateValue) - ifirstslash), "/")
      sDateValue = Mid(sDateValue, ifirstslash + 1, isecondslash - ifirstslash - 1) & _
                           "/" & Left(sDateValue, ifirstslash - 1) & _
                           "/" & Right(sDateValue, Len(sDateValue) - isecondslash)
   End If
   Date_USUKFormat = Format(CDate(sDateValue), sDateFormat)

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "convert the date string ??")
Exit Function

Date_LeapYearIsIt

Public Function Date_LeapYearIsIt( _
         ByVal iYear As Integer) _
         As Boolean
      
   Date_LeapYearIsIt = Month(DateSerial(iYear, 2, 29)) = 2

End Function

Date_MonthNumber

Public Function Date_MonthNumber( _
         ByVal sMonthName As String) _
         As Integer

   Date_MonthNumber = Month(CDate("01 " & sMonthName & " 2024")) - 1

End Function

Date_NthDayOfWeek

Public Function Date_NthDayOfWeek( _
         ByVal iYear As Integer, _
         ByVal iMonth As Integer, _
         ByVal iDayOfWeek As Integer, _
         ByVal iNumber As Integer) _
         As String

Const sPROCNAME As String = "Date_NthDayOfWeek"
Dim dttempdate As Date
      
  dttempdate = DateSerial(iYear, iMonth, _
                          (8 - Weekday(DateSerial(iYear, iMonth, 1), _
                          (iDayOfWeek + 1) Mod 8)) + ((iNumber - 1) * 7))
  
  Date_NthDayOfWeek = CDate(dttempdate)

End Function

Date_NthMonday

Public Function Date_NthMonday( _
         ByVal iWeek As Integer, _
         ByVal iYear As Integer) _
         As String

Const sPROCNAME As String = "Date_NthMonday"
Dim dttempdate As Date
      
   dttempdate = CDate(Date_FirstMonday(iYear)) + ((iWeek - 1) * 7)

End Function

Date_StrToDate

Public Function Date_StrToDate( _
         ByVal sDateValue As String, _  
         ByVal sDateFormat As String) _
         As Date

Const sPROCNAME As String = "Date_StrToDate"
Dim dtdate As Date
   On Error GoTo ErrorHandler

   Select Case sDateFormat
      Case "yyyymmdd"
         Date_StrToDate = DateSerial(Left(sDateValue, 4), Mid(sDateValue, 5, 2), Right(sDateValue, 2))
      Case "ddmmyyyy"
         Date_StrToDate = DateSerial(Right(sDateValue, 4), Mid(sDateValue, 3, 2), Left(sDateValue, 2))
      Case "dd-mmm-yyyy"
         Date_StrToDate = DateSerial(Right(sDateValue, 4), Month(sDateValue), Left(sDateValue, 2))
   End Select

   If gbDEBUG = False Then Exit Function

ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number & " " & Err.Description)
End Function

Date_TimeValid

Checks if the time is valid or not. Returns True or False.

Public Function Date_TimeValid() As Boolean

Const sPROCNAME As String = "Date_TimeValid"
   On Error GoTo ErrorHandler

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "")
End Function

Date_Valid

Checks if the date is valid or not. Returns True or False.

Public Function Date_Valid( _
         ByVal sDate As String) _
         As Boolean
    
Const sPROCNAME As String = "Date_Valid"
Dim dtDate As Date
   On Error GoTo ErrorHandler
   Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

   If (IsNumeric(sDate) = True) Then
      dtDate = DateValue(sDate)
   Else
      dtDate = CDate(sDate)
   End If
   Date_Valid = True

   If gbDEBUG = False Then Exit Function

ErrorHandler:
   Date_Valid = False
End Function

Date_ValidFormat

Public Function Date_ValidFormat( _
         ByVal sDateValue As String, _
         ByVal sDateFormat As String) _
         As Boolean

Const sPROCNAME As String = "Date_ValidFormat"
Dim dtdate As Date
   On Error GoTo ErrorHandler

   Date_ValidFormat = True
   Select Case sDateFormat
      Case "yyyymmdd"
         dtdate = DateSerial(Left(sDateValue, 4), Mid(sDateValue, 5, 2), Right(sDateValue, 2))
      Case "ddmmyyyy"
         dtdate = DateSerial(Right(sDateValue, 4), Mid(sDateValue, 3, 2), Left(sDateValue, 2))
   End Select

   If gbDEBUG = False Then Exit Function

ErrorHandler:
   Date_ValidFormat = False
End Function

Date_WeekdayNext

Returns the date of the next weekday.

Public Function Date_WeekdayNext( _
         ByVal lDate As Long, _
Optional ByVal iNoOfDays As Integer = 0) _
         As String

Const sPROCNAME As String = "Date_WeekdayNext"
   On Error GoTo ErrorHandler

   Do While iNoOfDays > 0
      Select Case Application.WorksheetFunction.WeekDay(lDate)
         Case 1: lDate = lDate - 2
         Case 2: lDate = lDate - 3
         Case Else: lDate = lDate - 1
      End Select

'Need to change it to go forward and backwards
      iNoOfDays = iNoOfDays - 1
   Loop
   Date_WeekdayNext = Format(lDate, "DD/MM/YYYY")

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "")
End Function

---

© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top