Code archives/Miscellaneous/Some date functions

This code has been declared by its author to be Public Domain code.

Download source code

Some date functions by _33
(Posted 19 years ago)
These are a small collection of date functions I created for my console project. Use at your leasure. I'll probably post an example or two some day.

Cheers. 
Function Convert_FileDate_To_Expanded$(fd$,mode%=2)
   m% = Int(Mid$(fd$,1,2))
   d% = Int(Mid$(fd$,4,2))
   y% = Int(Mid$(fd$,7,4))
   If m%>0 And d%>0 And y%>0 Then 
      Return (GetDayOfWeek$(d%,m%,y%,mode%)+ " " + GetMonthAlpha$(m%,mode%) + " " + Str$(d%) + " " + Str$(y%))
   Else
      Return (Str$(d%) + " " + Str$(y%))
   EndIf
End Function

Const Months$ = "January  Febuary  March    April    May      June     July     August   SeptemberOctober  November December "
Function GetMonthNumeric(month$)
   For i% = 1 To 12
      If Mid$(Months$,(i% * 9 - 8),3) = month$ Then Return i%
   Next
   Return 0
End Function

Function GetMonthAlpha$(month%,mode% = 2)
   If mode% = 1 Then
      Return Mid$(Months$,(month% * 9 - 8),3)
   ElseIf mode% = 2 Then
      Return Trim$(Mid$(Months$,(month% * 9 - 8),9))
   ElseIf mode% = 3 Then
      Return Mid$(Months$,(month% * 9 - 8),1)
   Else
      Return Mid$(Months$,(month% * 9 - 8),9)
   EndIf
End Function

Const Weekdays$ = "Sunday   Monday   Tuesday  WednesdayThursday Friday   Saturday "
Function GetDayOfWeek$(day,month,year, mode% = 2)
   d%=GetDayOfWeekVal%(day,month,year)
   If mode% = 1 Then
      Return Mid$(Weekdays$,(d% * 9 - 8),3)
   ElseIf mode% = 2 Then
      Return Trim$(Mid$(Weekdays$,(d% * 9 - 8),9))
   ElseIf mode% = 3 Then
      Return Mid$(Weekdays$,(d% * 9 - 8),1)
   Else
      Return Mid$(Weekdays$,(d% * 9 - 8),9)
   EndIf
End Function

Function GetDayOfWeekName$(d%, mode% = 1)
   If mode% = 1 Then
      Return Mid$(Weekdays$,(d% * 9 - 8),3)
   ElseIf mode% = 2 Then
      Return Trim$(Mid$(Weekdays$,(d% * 9 - 8),9))
   Else
      Return Mid$(Weekdays$,(d% * 9 - 8),1)
   EndIf
End Function

Const DaysInMonth$ = "312831303130313130313031"
Function GetDaysInMonth%(month%, year%)
   If month% = 2 And LeapYear(year%) Then
      Return 29
   Else
      Return Int(Mid$(DaysInMonth$,(month% * 2 - 1),2))
   EndIf
End Function

Function LeapYear(year%)
   If (year Mod 400) = 0 Then Return True
   If (year Mod 4) = 0 And (year Mod 100) <> 0 Then Return True
   Return False
End Function

Function GetDayOfWeekVal%(day,month,year)
   a = (14 - month)/12
   y = year - a
   m = month + 12*a - 2
   d = (day + y + y/4 - y/100 + y/400 + (31*m)/12)
   Return ((d Mod 7) + 1)
End Function

Comments

_33
(Posted 19 years ago)
Calendar example:
Type calendar
	Field day%
	Field t%
	Field d%
End Type
Function calendar(year$, width% = 3)
   height% = Int(12 / width%) - 1
   today$ = CurrentDate$()
   currentday% = Int(Left$(today$,2))
   currentmonth% = GetMonthNumeric(Mid$(today$,4,3))
   currentyear% = Int(Right$(today$,4))
   If year$ = "" Then
      y% = Int(Right$(today$,4))
   Else
      y% = Int(year$)
   EndIf
   For w = 1 To 7
      dow$ = dow$ + GetDayOfWeekName$(w)
   Next
   For month_y = 0 To height
      c$ = ""
      For month_x = 1 To width ; number of months displayed in width
         cal.calendar = New calendar
         cal\day = 0
         cal\t = GetDaysInMonth(month_y*width%+month_x,y%)
         cal\d = GetDayOfWeekVal(1,month_y*width%+month_x,y%)
         c$ = c$ + GetMonthAlpha$(month_y*width%+month_x,4) + String$(" ",12)
      Next
      Print c$
      Print String$(dow$,width)
      For i = 1 To 6 ; number of lines for each month
         c$ = ""
         month_x = 0
         For cal.calendar = Each calendar
            month_x = month_x + 1
            month% = (month_x + month_y * width)
            For w = 1 To 7
               If cal\day = 0 Then
                  If cal\d = w Then
                     cal\day = 1
                  EndIf
               Else
                  cal\day = cal\day + 1
               EndIf
               If cal\day <= cal\t And cal\day > 0 Then
                  If cal\day = currentday And month = currentmonth And y% = currentyear Then
                     c$ = c$ LSet$(cal\day,2)
                  Else
                     c$ = c$ + RSet$(LSet$(cal\day,2),3)
                  EndIf
               Else
                  c$ = c$ + "   "
               EndIf
            Next
         Next
         If Trim(c$) > "" Then Print c$
      Next
      Delete Each calendar
   Next
End Function

Graphics 1024,768,32,2
calendar(1998, 3)
WaitKey()
End


Make sure to include the above functions to make this work!

The parms for Calendar is year and number of months in width.

Code Archives Forum