VBA Snippets


ControlAddDays

Public Sub Date_ControlAddDays( _
ByVal ctlControlDay As Control)

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

ControlAddMonths

Public Sub Date_ControlAddMonths( _
ByVal ctlControlMonth As Control)

On Error GoTo AnError
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
AnError:
Call Error_Handle("Date_ControlAddMonths", msMODULENAME, _
"add the months to the control '" & ctlControlMonth.Name & "'.")
End Sub

ControlAddYears

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

On Error GoTo AnError

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
AnError:
Call Error_Handle("Date_ControlAddYears", msMODULENAME, _
"add the years to the control '" & ctlControlYear.Name & "'.")
End Sub

ControlCheckValid

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

Dim sDate As String
Dim iday As Integer
On Error GoTo AnError

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
AnError:
Call Error_Handle("Date_ControlCheckValid", msMODULENAME, _
"check if the selected date is valid.")
End Function

ControlCheckValidDay

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

Dim ipreviousindex As Integer
On Error GoTo AnError

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
AnError:
Call Error_Handle("Date_ControlCheckValidDay", msMODULENAME, _
"check if the 'day' selected is valid.")
End Sub

ControlCheckValidMonth

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

Dim ipreviousindex As Integer
On Error GoTo AnError

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
AnError:
Call Error_Handle("Date_ControlCheckValidMonth", msMODULENAME, _
"check if the 'month' selected is valid.")
End Sub

ControlCheckValidYear

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

Dim ipreviousindex As Integer
On Error GoTo AnError

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
AnError:
Call Error_Handle("Date_ControlCheckValidYear", msMODULENAME, _
"check if the 'year' selected is valid.")
End Sub

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

On Error GoTo AnError
Dim sdateformat As String
sdateformat = ctlControlDay.Text & " " & _
ctlControlMonth.Text & " " & _
ctlControlYear.Text

sdateformat = Format(sdateformat, sFormat)

Date_ControlReturn = sdateformat

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Date_ControlReturn", msMODULENAME, _
"return the selected date from the date controls.")
End Function

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)

On Error GoTo AnError
ctlControlDay.ListIndex = iDay - 1
ctlControlMonth.ListIndex = iMonth - 1
ctlControlYear.ListIndex = iYear - giSTARTYEAR

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

ControlSelectCurrent

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

On Error GoTo AnError
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
AnError:
Call Error_Handle("Date_ControlSelectCurrent", msMODULENAME, _
"select the current date from the date controls.")
End Sub

ControlSelectCurrentDay

Public Sub Date_ControlSelectCurrentDay( _
ByVal ctlControlDay As Control)

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

ControlSelectCurrentMonth

Public Sub Date_ControlSelectCurrentMonth( _
ByVal ctlControlMonth As Control)

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

ControlSelectCurrentYear

Public Sub Date_ControlSelectCurrentYear( _
ByVal ctlControlYear As Control)

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

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

Dim sDate As String
Dim dtdate As Date

On Error GoTo AnError

If Date_IsValid(sDateValue, sDateFormatFrom) = False Then
If bInformUser = True Then
Call MsgBox("Unable to convert the value '" & sDate & "' to a date.", , "SunGard_ConvertToDate")
End If
Date_ConvertToString = ""
Exit Function
Else
dtdate = Date_StrToDate(sDateValue, sDateFormatFrom)

Date_ConvertToString = Format(dtdate, sDateFormatTo)
End If

Exit Function

AnError:
Call Error_Handle(Err.Number & " " & Err.Description, "Date_ConvertToString")
End Function

DayAbbreviation

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

On Error GoTo AnError
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
AnError:
Call Error_Handle("Date_DayAbbreviation", msMODULENAME, 1, _
"return the abbreviation for day number '" & iDayNo & "'.")
End Function

FormatCheck

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

Dim sFormat As String
On Error GoTo AnError

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.", , "SunGard_ConvertToDate")
End If
Date_FormatCheck = ""
End If

AnError:
Call Error_Handle(Err.Number & " " & Err.Description, "Date_FormatCheck")
End Function
'****************************************************************************************
Public Function Date_FormatCheck( _
ByVal sFormatCode As String) _
As Boolean

Const sPROCNAME As String = "Date_FormatCheck"

On Error GoTo ErrorHandler
Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

If InStr(1, sFormatCode, "m") > 0 Or InStr(1, sFormatCode, "y") > 0 Or _
InStr(1, sFormatCode, "d") > 0 Then
Date_FormatCheck = True
End If
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

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 bInUsFormat As Boolean = False) _
As String

Dim ifirstslash As Integer
Dim isecondslash As Integer
On Error GoTo AnError

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
AnError:
Call Error_Handle("Date_FormatUSUK", msMODULENAME, 1,
"convert the date string ??")
Exit Function

LeapYearIsIt

Public Function Date_LeapYearIsIt( _
ByRef iYear As Integer) _
As Boolean

Date_LeapYearIsIt = Month(DateSerial(iYear, 2, 29)) = 2

End Function

MonthNumber

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

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

End Function

NthDayOfWeek

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

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

NthMonday

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

Dim dttempdate As Date

dttempdate = CDate(Date_FirstMonday(iYear)) + ((iWeek - 1) * 7)

End Function

StrToDate

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

Dim dtdate As Date
On Error GoTo AnError

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
Exit Function

AnError:
Call Error_Handle(Err.Number & " " & Err.Description, "Date_StrToDate")
End Function

TimeValid

Checks if the time is valid or not. Returns True or False.
Public Function Date_TimeValid() As Boolean

On Error GoTo AnError

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Date_TimeValid", msMODULENAME, 1,
"")
End Function

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
If IsNumeric(sDate) = True Then
dtDate = CLng(sDate)
Else
dtDate = CDate(sDate)
End If
Date_Valid = True
Exit Function
ErrorHandler:
Date_Valid = False
End Function
'****************************************************************************************
Public Function Date_Valid( _
ByVal sDate As String) As Boolean

Dim dtDate As Date
On Error GoTo AnError
Call Tracer_AddSubroutineStart(msMODULENAME, "Date_Valid")

If IsNumeric(sDate) = False Then
dtDate = DateValue(sDate)
Else
dtDate = CLng(sDate)
End If

Date_Valid = True

Exit Function
AnError:
Date_Valid = False
End Function
'****************************************************************************************
Public Function Date_IsValid( _
ByVal sDateValue As String, _
ByVal sDateFormat As String) _
As Boolean

Dim dtdate As Date
On Error GoTo AnError

Date_IsValid = 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
Exit Function

AnError:
Date_IsValid = False
End Function

WeekdayNext

Returns the date of the next weekday.
Public Function Date_WeekdayNext( _
ByVal lDate As Long, _
Optional ByVal iNoOfDays As Integer = 0) _
As String

On Error GoTo AnError
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
AnError:
Call Error_Handle("Date_WeekdayNext", msMODULENAME, 1,
"")
End Function

Current

source code

DateFormat


MonthIntegerReturn


TimeFormat


ToString

source code

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