+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Works in Progress (https://qb64phoenix.com/forum/forumdisplay.php?fid=9)
+---- Thread: some date/time/timestamp functions revisited (/showthread.php?tid=690)
some date/time/timestamp functions revisited - madscijr - 07-27-2022
One thing QB64 and its ancestors lacks, that VB6 and VBA and pretty much all modern languages have, is a native date/time type and associated operations and formatting functions. There are already 16 or so numeric types, so how about one for date/time?
I started throwing together some basic date/time functions, maybe someone will find this useful.
I'm sure this code could be done more efficiently but it seems to be working OK. There are still some features missing (a standard format date function, epoch-to-string function, count quarter/month/weekday/week, etc.) so this is still a Work in Progress.
Code: (Select All)
_TITLE "TimeStampFunctions"
' BOOLEAN VALUES
Const FALSE = 0
Const TRUE = Not FALSE
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' MAKE SCREEN BIG TO FIT A LOT OF TEXT: 1024x768=128cols,48rows and 1280x1024=160cols,64rows
Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
' DEMONSTRATION OF DATE/TIME STUFF:
TimeStringToSecondsTest
GetElapsedTimeTest
DateDiffTest
' EXIT
Screen 0
System ' return control to the operating system
End
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TIMESTAMP FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' QB64 equivalent of the Visual Basic / VBA DateDiff function.
' See:
' Microsoft > Office VBA Reference > DateDiff function
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
' Receives:
' interval$ = String expression that is the interval of time you use
' to calculate the difference between date1$ and date2$,
' and can be one of the following values:
' SETTING DESCRIPTION COMMENT
' ------- ----------- -------------------
' yyyy Year (NOT SUPPORTED YET)
' q Quarter (NOT SUPPORTED YET)
' m Month (NOT SUPPORTED YET)
' y Day of year (NOT SUPPORTED YET)
' d Day
' w Weekday (NOT SUPPORTED YET)
' ww Week (NOT SUPPORTED YET)
' h Hour
' n Minute
' s Second
'
' date1##, date2## = Two dates you want to use in the calculation,
' in UNIX time (# seconds elapsed since 1/1/1970 12:00:00 AM GMT),
' we assume the dates are timezone-corrected.
' Returns an _Float specifying the number of time intervals between
' two specified dates.
Function DateDiff## (interval$, fDate1##, fDate2##)
Dim fResult As _Float: fResult = 0
Dim fDiffSeconds As _Float
fDiffSeconds = fDate2## - fDate1##
Select Case interval$
Case "yyyy":
' Year = UNDER CONSTRUCTION
Case "q":
' Quarter = UNDER CONSTRUCTION
Case "m":
' Month = UNDER CONSTRUCTION
Case "y":
' Day of year = UNDER CONSTRUCTION
Case "d":
' Get # of days
fResult = (fDiffSeconds \ 86400)
Case "w":
' Weekday = UNDER CONSTRUCTION
Case "ww":
' Week = UNDER CONSTRUCTION
Case "h":
' Get # of hours
fResult = (fDiffSeconds \ 3600)
Case "n":
' get # of minutes
fResult = (fDiffSeconds \ 60)
Case "s":
' get # of seconds
fResult = fDiffSeconds
Case Else:
' Unknown
End Select
DateDiff## = fResult
End Function ' DateDiff##
' /////////////////////////////////////////////////////////////////////////////
Sub DateDiffTest
Dim in$
Cls
Print "Demonstration of Function DateDiff## (interval$, fDate1##, fDate2##)"
Print "--------------------------------------------------------------------"
DateDiffTest1 "s", "07-04-2022 12:00:00 PM", "07-04-2022 12:00:45 PM" ' 45s
DateDiffTest1 "s", "07/04/2022 12:00:00 PM", "07/04/2022 12:00:45 PM" ' 45s
DateDiffTest1 "s", "07-04-2022 12:00:00", "07-04-2022 12:00:45" ' 45s
DateDiffTest1 "s", "07/04/2022 12:00:00", "07/04/2022 12:00:45" ' 45s
Print
DateDiffTest1 "n", "07-04-2022 12:00:00 PM", "07-04-2022 12:12:34 PM" ' 754s
DateDiffTest1 "n", "07/04/2022 12:00:00 PM", "07/04/2022 12:12:34 PM" ' 754s
DateDiffTest1 "n", "07-04-2022 12:00:00", "07-04-2022 12:12:34" ' 754s
DateDiffTest1 "n", "07/04/2022 12:00:00", "07/04/2022 12:12:34" ' 754s
Print
DateDiffTest1 "h", "07-04-2022 12:00:00 PM", "07-04-2022 01:15:43 PM" ' 47743s
DateDiffTest1 "h", "07/04/2022 12:00:00 PM", "07/04/2022 01:15:43 PM" ' 47743s 1:15:43
DateDiffTest1 "h", "07-04-2022 12:00:00", "07-04-2022 13:15:43" ' 4543s 1:15:43
DateDiffTest1 "h", "07/04/2022 12:00:00", "07/04/2022 13:15:43" ' 4543s 1:15:43
Print
DateDiffTest1 "d", "07-04-2022 12:00:00 PM", "07-05-2022 01:15:43 PM" ' 134143s
DateDiffTest1 "d", "07/04/2022 12:00:00 PM", "07/05/2022 01:15:43 PM" ' 134143s 1:15:43
DateDiffTest1 "d", "07-04-2022 12:00:00", "07-05-2022 13:15:43" ' 94543s 26:15:43
DateDiffTest1 "d", "07/04/2022 12:00:00", "07/05/2022 13:15:43" ' 94543s 26:15:43
Input "PRESS ENTER TO CONTINUE"; in$
End Sub ' DateDiffTest
' /////////////////////////////////////////////////////////////////////////////
Sub DateDiffTest1 (interval$, date1$, date2$)
Dim fDiff As _Float
Dim sInterval As String
sInterval = GetTimeIntervalName$(interval$)
fDiff = DateDiff##(interval$, GetUnixTime##(date1$), GetUnixTime##(date2$))
Print _
StrPadLeft$(_Trim$(Str$(fDiff)), 8) + " " + _
StrPadRight$(sInterval, 7) + " " + _
"elapsed between " + _
StrPadRight$(date1$, 22) + " and " + _
StrPadRight$(date2$, 22)
End Sub ' DateDiffTest1
' /////////////////////////////////////////////////////////////////////////////
Sub DateDiffSanityTest1 (interval$, date1$, date2$)
Dim fDate1 As _Float
Dim fDate2 As _Float
fDate1 = GetUnixTime##(date1$)
fDate2 = GetUnixTime##(date2$)
Print StrPadRight$(date1$, 22) + " = " + StrPadRight$(_Trim$(Str$(fDate1)), 12) + " seconds"
Print StrPadRight$(date2$, 22) + " = " + StrPadRight$(_Trim$(Str$(fDate2)), 12) + " seconds"
Print StrPadRight$("", 22) + " " + StrPadRight$(_Trim$(Str$(fDate2 - fDate1)), 12) + " seconds difference"
Print
End Sub ' DateDiffSanityTest1
' /////////////////////////////////////////////////////////////////////////////
' Receives:
' fSeconds = time period in seconds
' Returns:
' The time period in the format "{days} days, {hours} hours, {minutes} minutes, {seconds} seconds"
' TODO:
' Add support for years, months, weeks
Function GetElapsedTime$ (fElapsedSeconds As _Float)
Dim sResult As String: sResult = ""
Dim fSeconds As _Float
Dim iDays As _Integer64
Dim iHours As Integer
Dim iMinutes As Integer
Dim iSeconds As Integer
Dim sSign As String
' Handle negative values
If Sgn(fElapsedSeconds) = -1 Then
fSeconds = 0 - fElapsedSeconds
sSign = "-"
Else
fSeconds = fElapsedSeconds
sSign = ""
End If
' Get # of days
iDays = fSeconds \ 86400
' Get # of hours
fSeconds = fSeconds - (iDays * 86400)
iHours = fSeconds \ 3600
' get # of minutes
fSeconds = fSeconds - (iHours * 3600)
iMinutes = fSeconds \ 60
' get # of seconds
fSeconds = fSeconds - (iMinutes * 60)
iSeconds = Int(fSeconds)
' Assemble output
If (iDays > 0) Then sResult = _Trim$(Str$(iDays)) + " days"
If (iHours > 0) Then sResult = AppendString$(sResult, _Trim$(Str$(iHours)) + " hours", ", ")
If (iMinutes > 0) Then sResult = AppendString$(sResult, _Trim$(Str$(iMinutes)) + " minutes", ", ")
If (iSeconds > 0) Then sResult = AppendString$(sResult, _Trim$(Str$(iSeconds)) + " seconds", ", ")
sResult = sSign + sResult
' Return result
GetElapsedTime$ = sResult
End Function ' GetElapsedTime$
' /////////////////////////////////////////////////////////////////////////////
' Based on "Test Steve timeStamp" by SMcNeill & bplus
' https://www.qb64.org/forum/index.php?topic=1638.30
' https://www.qb64.org/forum/index.php?topic=1638.msg108650#msg108650
Sub GetElapsedTimeTest
ReDim arrDateTime$(-1)
Dim iLoop1 As Integer
Dim iLoop2 As Integer
Dim MyDateTime1$
Dim MyDateTime2$
Dim iYear As Integer
Dim MyDate1$
Dim MyDate2$
Dim fSeconds1 As _Float
Dim fSeconds2 As _Float
Dim fDiffSeconds As _Float
Dim in$
Cls
Print "Demonstration of Function GetElapsedTime$ (fElapsedSeconds As _Float)"
Print "---------------------------------------------------------------------"
' TEST DATES
AppendToStringArray arrDateTime$(), "01-01-0966 00:00:00"
AppendToStringArray arrDateTime$(), "01-01-1815 00:00:00"
AppendToStringArray arrDateTime$(), "01-01-1970 00:00:00"
AppendToStringArray arrDateTime$(), "01-01-2020 00:00:00"
AppendToStringArray arrDateTime$(), "01-01-2020 12:00:00 AM"
AppendToStringArray arrDateTime$(), "01-01-2020 12:00:00 PM"
AppendToStringArray arrDateTime$(), "01-01-2020 01:00:00 PM"
AppendToStringArray arrDateTime$(), "01-01-2020 11:59:59 PM"
AppendToStringArray arrDateTime$(), "01-02-2020 12:00:00 AM"
AppendToStringArray arrDateTime$(), "07-27-2022 12:00:00 PM"
AppendToStringArray arrDateTime$(), "07-27-2022 06:00:00 PM"
AppendToStringArray arrDateTime$(), "07-28-2022 00:00:00"
AppendToStringArray arrDateTime$(), "01-01-2023 00:00:00"
AppendToStringArray arrDateTime$(), "01-01-2525 00:00:00"
' GET CURRENT DATE/TIME
MyDateTime1$ = GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}")
fSeconds1 = GetUnixTime##(MyDateTime1$)
Print "Current date/time is " + MyDateTime1$ + " = " + _Trim$(Str$(fSeconds1)) + " seconds"
Print
' COMPARE TEST DATES
For iLoop1 = LBound(arrDateTime$) To UBound(arrDateTime$)
MyDateTime2$ = arrDateTime$(iLoop1)
fSeconds2 = GetUnixTime##(MyDateTime2$)
fDiffSeconds = fSeconds1 - fSeconds2
Print _
StrPadRight$(MyDateTime1$, 22) + _
" - " + _
StrPadRight$(MyDateTime2$, 22) + _
" = " + _
StrPadRight$(_Trim$(Str$(fSeconds1)), 12) + "s" + _
" - " + _
StrPadRight$(_Trim$(Str$(fSeconds2)), 12) + "s" + _
" = " + _
StrPadRight$(_Trim$(Str$(fDiffSeconds)), 12) + "s" + _
" = " + _
GetElapsedTime$(fDiffSeconds)
Next iLoop1
Input "PRESS ENTER TO CONTINUE"; in$
End Sub ' GetElapsedTimeTest
' /////////////////////////////////////////////////////////////////////////////
Function GetTimeIntervalName$ (interval$)
Dim sInterval As String
Select Case interval$
Case "yyyy":
sInterval = "years"
Case "q":
sInterval = "quarters"
Case "m":
sInterval = "months"
Case "y":
sInterval = "days of the year"
Case "d":
sInterval = "days"
Case "w":
sInterval = "weekdays"
Case "ww":
sInterval = "weeks"
Case "h":
sInterval = "hours"
Case "n":
sInterval = "minutes"
Case "s":
sInterval = "seconds"
Case Else:
sInterval = "unknown units"
End Select
GetTimeIntervalName$ = sInterval
End Function ' GetTimeIntervalName$
' /////////////////////////////////////////////////////////////////////////////
' Based on "Test Steve timeStamp" by SMcNeill & bplus
' https://www.qb64.org/forum/index.php?topic=1638.30
' https://www.qb64.org/forum/index.php?topic=1638.msg108650#msg108650
' Receives:
' MyDate$ can be date or date+time, in any of the following formats:
' 12-hour time:
' 01-01-2020 11:59:59 PM
' 01/01/2020 11:59:59 PM
' 24-hour time:
' 01-01-2020 23:59:59
' 01/01/2020 23:59:59
' TODO: create the inverse function, receives epoch and returns a formatted date string.
Function GetUnixTime## (sDate$)
Dim iPos1 As Integer
Dim iPos2 As Integer
Dim iMonth As Integer
Dim iDay As Integer
Dim iYear As Integer
Dim iLoop1 As Integer
Dim fDateSeconds As _Float
Dim MyDate$
Dim sTime$
Dim fTimeSeconds As _Float ' MyTime##
Dim fTotalSeconds As _Float: fTotalSeconds = 0
' Do we have date+time or just date?
' Look at sDate$:
' e.g. 01-01-2020 11:59:59 PM
' 1234567890123456789012
' 10987654321
If Len(sDate$) > 19 Then
' Date + time, 12-hour time
sTime$ = Right$(sDate$, Len(sDate$) - 11)
fTimeSeconds = TimeStringToSeconds##(sTime$)
MyDate$ = Left$(sDate$, 10)
ElseIf Len(sDate$) > 10 Then
' Date + time, 24-hour time
sTime$ = Right$(sDate$, Len(sDate$) - 11)
fTimeSeconds = TimeStringToSeconds##(sTime$)
MyDate$ = Left$(sDate$, 10)
Else
' Just a date, assume time=12:00:00 AM
fTimeSeconds = 0
MyDate$ = sDate$
End If
MyDate$ = Replace$(MyDate$, "/", "-")
' Get seconds for date
iPos1 = InStr(MyDate$, "-")
iPos2 = InStr(iPos1 + 1, MyDate$, "-")
iMonth = Val(Left$(MyDate$, iPos1))
iDay = Val(Mid$(MyDate$, iPos1 + 1))
iYear = Val(Mid$(MyDate$, iPos2 + 1))
If iYear < 1970 Then
' CALCULATE SHE-IT BACKWARDS
Select Case iMonth ' turn the day backwards for the month
Case 1, 3, 5, 7, 8, 10, 12: iDay = 31 - iDay ' 31 days
Case 2: iDay = 28 - iDay ' special 28 or 29.
Case 4, 6, 9, 11: iDay = 30 - iDay ' 30 days
End Select
If iYear Mod 4 = 0 And iMonth < 3 Then ' check for normal leap year, and we're before it...
iDay = iDay + 1 ' assume we had a leap year, subtract another day
If iYear Mod 100 = 0 And iYear Mod 400 <> 0 Then iDay = iDay - 1 ' not a leap year if year is divisible by 100 and not 400
End If
' then count the months that passed after the current month
For iLoop1 = iMonth + 1 To 12
Select Case iLoop1
Case 2: iDay = iDay + 28
Case 3, 5, 7, 8, 10, 12: iDay = iDay + 31
Case 4, 6, 9, 11: iDay = iDay + 30
End Select
Next iLoop1
' we should now have the entered year calculated. Now lets add in for each year from this point to 1970
iDay = iDay + 365 * (1969 - iYear) ' 365 days per each standard year
For iLoop1 = 1968 To iYear + 1 Step -4 ' from 1968 onwards,backwards, skipping the current year (which we handled previously in the FOR loop)
iDay = iDay + 1 ' subtract an extra day every leap year
If (iLoop1 Mod 100) = 0 And (iLoop1 Mod 400) <> 0 Then iDay = iDay - 1 ' but skipping every year divisible by 100, but not 400
Next iLoop1
fDateSeconds = iDay * 24 * 60 * 60 ' Seconds are days * 24 hours * 60 minutes * 60 seconds
fTotalSeconds = -(fDateSeconds + 24 * 60 * 60 - fTimeSeconds)
'fDateSeconds = -(fDateSeconds + 24 * 60 * 60)
'Exit Function
Else
' CALCULATE FORWARD
iYear = iYear - 1970
For iLoop1 = 1 To iMonth ' for this year,
Select Case iLoop1 ' Add the number of days for each previous month passed
Case 1: iDay = iDay ' January doestn't have any carry over days.
Case 2, 4, 6, 8, 9, 11: iDay = iDay + 31
Case 3 ' Feb might be a leap year
If (iYear Mod 4) = 2 Then ' if this year is divisible by 4 (starting in 1972)
iDay = iDay + 29 ' its a leap year
If (iYear Mod 100) = 30 And (iYear Mod 400) <> 30 Then ' unless..
iDay = iDay - 1 ' the year is divisible by 100, and not divisible by 400
End If
Else ' year not divisible by 4, no worries
iDay = iDay + 28
End If
Case 5, 7, 10, 12: iDay = iDay + 30
End Select
Next iLoop1
iDay = (iDay - 1) + 365 * iYear ' current month days passed + 365 days per each standard year
For iLoop1 = 2 To iYear - 1 Step 4 ' from 1972 onwards, skipping the current year (which we handled previously in the FOR loopp)
iDay = iDay + 1 ' add an extra day every leap year
If (iLoop1 Mod 100) = 30 And (iLoop1 Mod 400) <> 30 Then iDay = iDay - 1 ' but skiping every year divisible by 100, but not 400
Next iLoop1
fDateSeconds = iDay * 24 * 60 * 60 ' Seconds are days * 24 hours * 60 minutes * 60 seconds
fTotalSeconds = fDateSeconds + fTimeSeconds
End If
GetUnixTime## = fTotalSeconds
End Function ' GetUnixTime##
' /////////////////////////////////////////////////////////////////////////////
' mod from Pete's calendar this is a very clear calc
' From "Test Steve timeStamp" by SMcNeill & bplus
' https://www.qb64.org/forum/index.php?topic=1638.30
' https://www.qb64.org/forum/index.php?topic=1638.msg108650#msg108650
Function IsLeapYear% (yr)
Dim bResult%: bResult% = FALSE
If yr Mod 4 = 0 Then
If yr Mod 100 = 0 Then
If yr Mod 400 = 0 Then
bResult% = TRUE
End If
Else
bResult% = TRUE
End If
End If
IsLeapYear% = bResult%
End Function ' IsLeapYear%
' /////////////////////////////////////////////////////////////////////////////
' Convert time string to seconds.
' Receives a time string in the format:
' {hh}:[mm}:{ss} {AM/PM}
' If the string contains "AM" or "PM" then it is treated as 12-hour time,
' else it is treated as 24-hour (military) time.
' Counts up the number of seconds from midnight until that time,
' and returns it as type Float.
' TODO:
' * First remove all non-numeric characters, except AM or PM on the right,
' so that we can parse dates with other separators, like "12.25.2003".
' * Create the inverse function "SecondsToTimeString$".
' * Create a date/time type with all the standard Date operations.
Function TimeStringToSeconds## (sTime$)
Dim sHH$: sHH$ = Left$(sTime$, 2)
Dim sNN$: sNN$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Dim fSeconds##: fSeconds## = 0
' MAKE SURE VALUES ARE NUMBERS
If (IsNum%(sHH$) = TRUE) And (IsNum%(sNN$) = TRUE) And (IsNum%(sSS$) = TRUE) Then
' IF TIME CONTAINS AM/PM, USE 12-HOUR TIME, ELSE 24-HOUR
If InStr(UCase$(sTime$), "AM") > 0 Then
' 12-HOUR TIME, A.M.
'Print "Ante-meridian!"
If Val(sHH$) = 12 Then
' Hour is zero for 12 A.M.
'Print "12 A.M., that's zero for hours"
fSeconds## = (Val(sNN$) * 60) + Val(sSS$)
Else
' Count hour normally
'Print "Between 1 A.M. and 11:59:59 A.M."
fSeconds## = (Val(sHH$) * 3600) + (Val(sNN$) * 60) + Val(sSS$)
End If
ElseIf InStr(UCase$(sTime$), "PM") > 0 Then
' 12-HOUR TIME, P.M.
' Unless it is noon, add 12 hours.
If Val(sHH$) = 12 Then
' Count hour normally
'Print "12 noon. Leave hours alone."
fSeconds## = (Val(sHH$) * 3600) + (Val(sNN$) * 60) + Val(sSS$)
Else
' Add 12 hours.
'Print "Post-meridian but not noon. Add 12 hours."
fSeconds## = ((Val(sHH$) + 12) * 3600) + (Val(sNN$) * 60) + Val(sSS$)
End If
Else
' 24-HOUR TIME
'Print "24 hours, boys!!"
fSeconds## = (Val(sHH$) * 3600) + (Val(sNN$) * 60) + Val(sSS$)
End If
'Else
' Print "Something's not right"
' Print "(IsNum%(sHH$) = " + _Trim$(Str$(IsNum%(sHH$))) + ", sHH$=" + chr$(34) + sHH$ + chr$(34)
' Print "(IsNum%(sNN$) = " + _Trim$(Str$(IsNum%(sNN$))) + ", sNN$=" + chr$(34) + sNN$ + chr$(34)
' Print "(IsNum%(sSS$) = " + _Trim$(Str$(IsNum%(sSS$))) + ", sSS$=" + chr$(34) + sSS$ + chr$(34)
End If
' RETURN RESULT
TimeStringToSeconds## = fSeconds##
End Function ' TimeStringToSeconds##
' /////////////////////////////////////////////////////////////////////////////
Sub TimeStringToSecondsTest
ReDim arrTime$(0 To 17)
Dim iLoop%
Dim in$
arrTime$(0) = "00:00:00"
arrTime$(1) = "12:00:00 AM"
arrTime$(2) = "01:00:00"
arrTime$(3) = "01:00:00 AM"
arrTime$(4) = "01:02:00 AM"
arrTime$(5) = "01:02:34 AM"
arrTime$(6) = "02:00:00"
arrTime$(7) = "02:00:00 AM"
arrTime$(8) = "02:02:00 AM"
arrTime$(9) = "02:02:34 AM"
arrTime$(10) = "01:00:00 PM"
arrTime$(11) = "01:02:00 PM"
arrTime$(12) = "01:02:34 PM"
arrTime$(13) = "13:00:00"
arrTime$(14) = "13:01:00"
arrTime$(15) = "13:01:34"
arrTime$(16) = "23:59:59"
arrTime$(17) = "11:59:59 PM"
Cls
Print "Demonstration of Function TimeStringToSeconds## (sTime$)"
Print "--------------------------------------------------------"
For iLoop% = LBound(arrTime$) To UBound(arrTime$)
Print "Time " + Chr$(34) + arrTime$(iLoop%) + Chr$(34) + " = " + _Trim$(Str$(TimeStringToSeconds##(arrTime$(iLoop%)))) + " seconds."
Next iLoop%
Input "PRESS ENTER TO CONTINUE"; in$
End Sub ' TimeStringToSecondsTest
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TIMESTAMP FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE ROUTINES #GEN
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
Function AppendString$ (MyString As String, NewString As String, MyDelimiter As String)
Dim sResult As String: sResult = MyString
If Len(MyString) > 0 Then
sResult = sResult + MyDelimiter
End If
sResult = sResult + NewString
AppendString$ = sResult
End Function ' AppendString$
' /////////////////////////////////////////////////////////////////////////////
Sub AppendToStringArray (MyStringArray$(), MyString$)
ReDim _Preserve MyStringArray$(LBound(MyStringArray$) To UBound(MyStringArray$) + 1)
MyStringArray$(UBound(MyStringArray$)) = MyString$
End Sub ' AppendToStringArray
' /////////////////////////////////////////////////////////////////////////////
' See also StringTo2dArray
Function Array2dToString$ (MyArray() As String)
Dim MyString As String
Dim iY As Integer
Dim iX As Integer
Dim sLine As String
MyString = ""
For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
sLine = ""
For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
sLine = sLine + MyArray(iY, iX)
Next iX
MyString = MyString + sLine + Chr$(13)
Next iY
Array2dToString$ = MyString
End Function ' Array2dToString$
' /////////////////////////////////////////////////////////////////////////////
'Function Array2dToStringTest$ (MyArray() As String)
' Dim MyString As String
' Dim iY As Integer
' Dim iX As Integer
' Dim sLine As String
' MyString = ""
' MyString = MyString + " 11111111112222222222333" + Chr$(13)
' MyString = MyString + " 12345678901234567890123456789012" + Chr$(13)
' For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
' sLine = ""
' sLine = sLine + Right$(" " + cstr$(iY), 2)
' For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
' sLine = sLine + MyArray(iY, iX)
' Next iX
' sLine = sLine + Right$(" " + cstr$(iY), 2)
' MyString = MyString + sLine + Chr$(13)
' Next iY
' MyString = MyString + " 12345678901234567890123456789012" + Chr$(13)
' MyString = MyString + " 11111111112222222222333" + Chr$(13)
' Array2dToStringTest$ = MyString
'End Function ' Array2dToStringTest$
' /////////////////////////////////////////////////////////////////////////////
' Convert a value to string and trim it (because normal Str$ adds spaces)
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
'' /////////////////////////////////////////////////////////////////////////////
'' Convert a Long value to string and trim it (because normal Str$ adds spaces)
'
'Function cstrl$ (myValue As Long)
' cstrl$ = _Trim$(Str$(myValue))
'End Function ' cstrl$
'
'' /////////////////////////////////////////////////////////////////////////////
'' Convert a Single value to string and trim it (because normal Str$ adds spaces)
'
'Function cstrs$ (myValue As Single)
' ''cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
' cstrs$ = _Trim$(Str$(myValue))
'End Function ' cstrs$
'
'' /////////////////////////////////////////////////////////////////////////////
'' Convert an unsigned Long value to string and trim it (because normal Str$ adds spaces)
'
'Function cstrul$ (myValue As _Unsigned Long)
' cstrul$ = _Trim$(Str$(myValue))
'End Function ' cstrul$
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
Function CurrentDateTime$
CurrentDateTime$ = Mid$(Date$, 7, 4) + "-" + _
Mid$(Date$, 1, 5) + " " + _
Time$
End Function ' CurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' TODO: verify this works
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function DblToStr$ (n#)
value$ = UCase$(LTrim$(Str$(n#)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") 'only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-": valu$ = Mid$(value$, 2, Xpos% - 2)
Else valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, "."): L% = Len(valu$)
If expo% > 0 Then add$ = String$(expo% - (L% - dot%), "0")
If expo% < 0 Then min$ = String$(Abs(expo%) - (dot% - 1), "0"): DP$ = "."
For n = 1 To L%
If Mid$(valu$, n, 1) <> "." Then num$ = num$ + Mid$(valu$, n, 1)
Next
Else DblToStr$ = value$: Exit Function
End If
DblToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
' Receives an {sDelim} delimited list {sInput}
' returns the list with all duplicate entries removed.
Function DedupeDelimList$ (sInput As String, sDelim As String)
ReDim arrLines(-1) As String
Dim sOutput As String
Dim iLoop As Integer
split sInput, sDelim, arrLines()
sOutput = sDelim
For iLoop = LBound(arrLines) To UBound(arrLines)
If InStr(1, sOutput, sDelim + arrLines(iLoop) + sDelim) = 0 Then
sOutput = sOutput + arrLines(iLoop) + sDelim
End If
Next iLoop
DedupeDelimList$ = sOutput
End Function ' DedupeDelimList$
' /////////////////////////////////////////////////////////////////////////////
' SMcNeill
' More efficient version of ExtendedTimer.
' This stores our day values and only updates them when necessary.
' We really don't need to figure out how many seconds are in today over and over endlessly
' -- just count them once, and when the clock swaps back to 0:0:0, add 24*60*60 seconds to the count.
' Re: how to time something (ie do loop for n seconds)
' https://forum.qb64.org/index.php?topic=4682.0
Function ExtendedTimer##
'modified extendedtimer to store the old day's count, and not have to recalculate it every time the routine is called.
Static olds As _Float, old_day As _Float
Dim m As Integer, d As Integer, y As Integer
Dim s As _Float, day As String
If olds = 0 Then 'calculate the day the first time the extended timer runs
day = Date$
m = Val(Left$(day, 2))
d = Val(Mid$(day, 4, 2))
y = Val(Right$(day, 4)) - 1970
Select Case m 'Add the number of days for each previous month passed
Case 2: d = d + 31
Case 3: d = d + 59
Case 4: d = d + 90
Case 5: d = d + 120
Case 6: d = d + 151
Case 7: d = d + 181
Case 8: d = d + 212
Case 9: d = d + 243
Case 10: d = d + 273
Case 11: d = d + 304
Case 12: d = d + 334
End Select
If (y Mod 4) = 2 And m > 2 Then d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
old_day = s
End If
If Timer < oldt Then 'we went from 23:59:59 (a second before midnight) to 0:0:0 (midnight)
old_day = s + 83400 'add another worth of seconds to our counter
End If
oldt = Timer
olds = old_day + oldt
ExtendedTimer## = olds
End Function ' ExtendedTimer##
' /////////////////////////////////////////////////////////////////////////////
' TODO: find the newer formatting function?
Function FormatNumber$ (myValue, iDigits As Integer)
Dim strValue As String
strValue = DblToStr$(myValue) + String$(iDigits, " ")
If myValue < 1 Then
If myValue < 0 Then
strValue = Replace$(strValue, "-.", "-0.")
ElseIf myValue > 0 Then
strValue = "0" + strValue
End If
End If
FormatNumber$ = Left$(strValue, iDigits)
End Function ' FormatNumber$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the 8-bit binary representation
' of an integer iInput where 0 <= iInput <= 255
Function GetBinary$ (iInput1 As Integer)
Dim sResult As String
Dim iLoop As Integer
Dim iInput As Integer: iInput = iInput1
sResult = ""
If iInput >= 0 And iInput <= 255 Then
For iLoop = 1 To 8
sResult = LTrim$(RTrim$(Str$(iInput Mod 2))) + sResult
iInput = iInput \ 2
'If iLoop = 4 Then sResult = " " + sResult
Next iLoop
End If
GetBinary$ = sResult
End Function ' GetBinary$
' /////////////////////////////////////////////////////////////////////////////
' wonderfully inefficient way to read if a bit is set
' ival = GetBit256%(int we are comparing, int containing the bits we want to read)
' See also: GetBit256%, SetBit256%
Function GetBit256% (iNum1 As Integer, iBit1 As Integer)
Dim iResult As Integer
Dim sNum As String
Dim sBit As String
Dim iLoop As Integer
Dim bContinue As Integer
'DIM iTemp AS INTEGER
Dim iNum As Integer: iNum = iNum1
Dim iBit As Integer: iBit = iBit1
iResult = FALSE
bContinue = TRUE
If iNum < 256 And iBit <= 128 Then
sNum = GetBinary$(iNum)
sBit = GetBinary$(iBit)
For iLoop = 1 To 8
If Mid$(sBit, iLoop, 1) = "1" Then
'if any of the bits in iBit are false, return false
If Mid$(sNum, iLoop, 1) = "0" Then
iResult = FALSE
bContinue = FALSE
Exit For
End If
End If
Next iLoop
If bContinue = TRUE Then
iResult = TRUE
End If
End If
GetBit256% = iResult
End Function ' GetBit256%
' /////////////////////////////////////////////////////////////////////////////
' Returns the text character at positon x%, y%
' Does the same as:
' Locate y%, x%
' GetCharXY% = Screen(CsrLin, Pos(0))
' See also: GetColorXY&
Function GetCharXY% (x%, y%)
GetCharXY% = Screen(y%, x%, 0) ' when 3rd parameter = 0 returns character code
End Function ' GetCharXY%
' /////////////////////////////////////////////////////////////////////////////
' Returns the text color at positon x%, y%
' See also: GetCharXY%
Function GetColorXY& (x%, y%)
GetColorXY& = Screen(y%, x%, 1) ' when 3rd parameter = 1 returns character color
End Function ' GetColorXY
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
' Format: {YYYY}-{MM}-{DD} {hh}:[mm}:{ss}
' Uses:
' TIME$
' The TIME$ Function returns a STRING representation
' of the current computer time in a 24 hour format.
' https://qb64phoenix.com/qb64wiki/index.php/TIME$
' DATE$
' The DATE$ function returns the current computer date
' as a string in the format "mm-dd-yyyy".
' https://qb64phoenix.com/qb64wiki/index.php/DATE$
'
' TODO: support template where
' {yyyy} = 4 digit year
' {mm} = 2 digit month
' {dd} = 2 digit day
' {hh} = 2 digit hour (12-hour)
' {rr} = 2 digit hour (24-hour)
' {nn} = 2 digit minute
' {ss} = 2 digit second
' {ampm} = AM/PM
' We got the nn for minute from Microsoft > Office VBA Reference > DateDiff function
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
' PRINT "Current date time (simple format) = " + Chr$(34) + GetCurrentDateTime$("{yyyy}-{mm}-{dd} {rr}:{nn}:{ss}") + Chr$(34)
' PRINT "Current date time (US format) = " + Chr$(34) + GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}") + Chr$(34)
' PRINT "Filename timestamp = " + Chr$(34) + GetCurrentDateTime$("{yyyy}{mm}{dd}_{rr}{nn}{ss}") + Chr$(34)
Function GetCurrentDateTime$ (sTemplate$)
Dim sDate$: sDate$ = Date$
Dim sTime$: sTime$ = Time$
Dim sYYYY$: sYYYY$ = Mid$(sDate$, 7, 4)
Dim sMM$: sMM$ = Mid$(sDate$, 1, 2)
Dim sDD$: sDD$ = Mid$(sDate$, 4, 2)
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sHH$: sHH$ = ""
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Dim iHour%: iHour% = Val(sHH24$)
Dim sAMPM$: sAMPM$ = ""
Dim result$: result$ = ""
' FIGURE OUT AM/PM
If InStr(sTemplate$, "{ampm}") > 0 Then
If iHour% = 0 Then
sAMPM$ = "AM"
iHour% = 12
ElseIf iHour% > 0 And iHour% < 12 Then
sAMPM$ = "AM"
ElseIf iHour% = 12 Then
sAMPM$ = "PM"
Else
sAMPM$ = "PM"
iHour% = iHour% - 12
End If
sHH$ = Right$("00" + _Trim$(Str$(iHour%)), 2)
End If
' POPULATE TEMPLATE
result$ = sTemplate$
result$ = Replace$(result$, "{yyyy}", sYYYY$)
result$ = Replace$(result$, "{mm}", sMM$)
result$ = Replace$(result$, "{dd}", sDD$)
result$ = Replace$(result$, "{hh}", sHH$)
result$ = Replace$(result$, "{rr}", sHH24$)
result$ = Replace$(result$, "{nn}", sMI$)
result$ = Replace$(result$, "{ss}", sSS$)
result$ = Replace$(result$, "{ampm}", sAMPM$)
' RETURN RESULT
GetCurrentDateTime$ = result$
End Function ' GetCurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the integer that corresponds to a binary string of length 8
Function GetIntegerFromBinary% (sBinary1 As String)
Dim iResult As Integer
Dim iLoop As Integer
Dim strBinary As String
Dim sBinary As String: sBinary = sBinary1
iResult = 0
strBinary = Replace$(sBinary, " ", "") ' Remove any spaces
For iLoop = 0 To Len(strBinary) - 1
iResult = iResult + 2 ^ iLoop * Val(Mid$(strBinary, Len(strBinary) - iLoop, 1))
Next iLoop
GetIntegerFromBinary% = iResult
End Function ' GetIntegerFromBinary%
' /////////////////////////////////////////////////////////////////////////////
' Receives a {sDelimeter} delimited list of numbers {MyString}
' and splits it up into an integer array arrInteger()
' beginning at index {iMinIndex}.
Sub GetIntegerArrayFromDelimList (MyString As String, sDelimiter As String, iMinIndex As Integer, arrInteger() As Integer)
ReDim arrString(-1) As String
Dim CleanString As String
Dim iLoop As Integer
Dim iCount As Integer: iCount = iMinIndex - 1
ReDim arrInteger(-1) As Integer
'DebugPrint "GetIntegerArrayFromDelimList " + _
' "MyString=" + chr$(34) + MyString + chr$(34) + ", " + _
' "sDelimiter=" + chr$(34) + sDelimiter + chr$(34) + ", " + _
' "iMinIndex=" + cstr$(iMinIndex) + ", " + _
' "arrInteger()"
If Len(sDelimiter) > 0 Then
CleanString = MyString
If sDelimiter <> " " Then
CleanString = Replace$(CleanString, " ", "")
End If
split CleanString, sDelimiter, arrString()
iCount = iMinIndex - 1
For iLoop = LBound(arrString) To UBound(arrString)
If IsNum%(arrString(iLoop)) = TRUE Then
iCount = iCount + 1
ReDim _Preserve arrInteger(iMinIndex To iCount) As Integer
arrInteger(iCount) = Val(arrString(iLoop))
'DebugPrint "5633 arrInteger(" + cstr$(iCount) + ") = VAL(arrString(" + cstr$(iLoop) + ")) = " + cstr$(arrInteger(iCount))
End If
Next iLoop
Else
If IsNum%(MyString) = TRUE Then
ReDim _Preserve arrInteger(iMinIndex To iMinIndex) As Integer
arrInteger(iMinIndex) = Val(MyString)
End If
End If
'CleanString=""
'for iLoop=lbound(arrInteger) to ubound(arrInteger)
'CleanString = CleanString + iifstr$(iLoop=lbound(arrInteger), "", ",") + cstr$(arrInteger(iLoop))
'next iLoop
'DebugPrint "arrInteger=(" + CleanString + ")"
End Sub ' GetIntegerArrayFromDelimList
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for integers
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for strings
Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
End Function
' /////////////////////////////////////////////////////////////////////////////
Function IntPadLeft$ (iValue As Integer, iWidth As Integer)
IntPadLeft$ = Right$(String$(iWidth, " ") + _Trim$(Str$(iValue)), iWidth)
End Function ' IntPadLeft$
' /////////////////////////////////////////////////////////////////////////////
Function IntPadRight$ (iValue As Integer, iWidth As Integer)
IntPadRight$ = Left$(_Trim$(Str$(iValue)) + String$(iWidth, " "), iWidth)
End Function ' IntPadRight$
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if number n is even
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
Function IsEven% (n)
If n Mod 2 = 0 Then
IsEven% = TRUE
Else
IsEven% = FALSE
End If
End Function ' IsEven%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if number n is odd
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
Function IsOdd% (n)
If n Mod 2 = 1 Then
IsOdd% = TRUE
Else
IsOdd% = FALSE
End If
End Function ' IsOdd%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value text$ is numeric.
Function IsNum% (text$)
IsNum% = IsNumber%(text$)
End Function ' IsNum%
'' NOTE: THIS FAILS FOR NUMBERS LIKE "002" AND "2.000":
'Function IsNum% (text$)
' Dim a$
' Dim b$
' a$ = _Trim$(text$)
' b$ = _Trim$(Str$(Val(text$)))
' If a$ = b$ Then
' IsNum% = TRUE
' Else
' IsNum% = FALSE
' End If
'End Function ' IsNum%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric.
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' Version 2 by madscijr
' Returns TRUE (-1) if string is an integer, FALSE (0) if not
' Version 1 by MWheatley
' Reply #18 on: January 01, 2019, 11:24:30 AM
' returns 1 if string is an integer, 0 if not
Function IsNumber% (OriginalString$)
Dim bResult%: bResult% = FALSE
Dim iLoop%
Dim TestString$
'Dim bNegative%
Dim iDecimalCount%
Dim sNextChar$
'THEY SHOULD TRIM OUTSIDE THE FUNCTION!
'TestString$ = _TRIM$(OriginalString$)
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = FALSE
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = TRUE
Else
TestString$ = OriginalString$
'bNegative% = FALSE
End If
If Len(TestString$) > 0 Then
bResult% = TRUE
iDecimalCount% = 0
For iLoop% = 1 To Len(TestString$)
sNextChar$ = Mid$(TestString$, iLoop%, 1)
If sNextChar$ = "." Then
iDecimalCount% = iDecimalCount% + 1
If iDecimalCount% > 1 Then
' TOO MANY DECIMAL POINTS, INVALID!
bResult% = FALSE
Exit For
End If
ElseIf Asc(sNextChar$) < 48 Or Asc(sNextChar$) > 57 Then
' NOT A NUMERAL OR A DECIMAL, INVALID!
bResult% = FALSE
Exit For
End If
Next iLoop%
End If
End If
IsNumber% = bResult%
End Function ' IsNumber%
' /////////////////////////////////////////////////////////////////////////////
'Sub IsNumberTest
' Dim in$
' Cls
' IsNumberTest1 "1"
' IsNumberTest1 "01"
' IsNumberTest1 "001"
' IsNumberTest1 "-1"
' IsNumberTest1 "-01"
' IsNumberTest1 "-001"
' IsNumberTest1 "+1"
' IsNumberTest1 "+01"
' IsNumberTest1 "+001"
' IsNumberTest1 ".1"
' IsNumberTest1 ".01"
' IsNumberTest1 ".001"
' IsNumberTest1 ".10"
' IsNumberTest1 ".100"
' IsNumberTest1 "..100"
' IsNumberTest1 "100."
' Input "PRESS ENTER TO CONTINUE TEST";in$
' Cls
' IsNumberTest1 "0.10"
' IsNumberTest1 "00.100"
' IsNumberTest1 "000.1000"
' IsNumberTest1 "000..1000"
' IsNumberTest1 "000.1000.00"
' IsNumberTest1 "+1.00"
' IsNumberTest1 "++1.00"
' IsNumberTest1 "+-1.00"
' IsNumberTest1 "-1.00"
' IsNumberTest1 "-+1.00"
' IsNumberTest1 " 1"
' IsNumberTest1 "1 "
' IsNumberTest1 "1. 01"
' IsNumberTest1 "+1 "
'End Sub ' IsNumberTest
'Sub IsNumberTest1(MyString As String)
' Const cWidth = 16
' Dim sInput As String : sInput = left$(Chr$(34) + MyString + Chr$(34) + String$(cWidth, " "), cWidth)
' Dim sResult As String : sResult = right$(String$(2, " ") + _Trim$(Str$(IsNumber%(MyString))), 2)
' Print "IsNumber%(" + sInput + ") returns " + sResult
'End Sub ' IsNumberTest1
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
Function join$ (in$(), delimiter$)
Dim result$
Dim i As Long
result$ = in$(LBound(in$))
For i = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(i)
Next i
join$ = result$
End Function ' join$
' /////////////////////////////////////////////////////////////////////////////
' ABS was returning strange values with type LONG
' so I created this which does not.
Function LongABS& (lngValue As Long)
If Sgn(lngValue) = -1 Then
LongABS& = 0 - lngValue
Else
LongABS& = lngValue
End If
End Function ' LongABS&
' /////////////////////////////////////////////////////////////////////////////
' remove scientific Notation to String (~40 LOC)
' SMcNeill Jan 7, 2020
' https://www.qb64.org/forum/index.php?topic=1555.msg112989#msg112989
' Last Function in code marked Best Answer (removed debug comments and
' blank lines added these 2 lines.)
Function N2S$ (EXP$)
ReDim t$, sign$, l$, r$, r&&
ReDim dp As Long, dm As Long, ep As Long, em As Long, check1 As Long, l As Long, i As Long
t$ = LTrim$(RTrim$(EXP$))
If Left$(t$, 1) = "-" Or Left$(t$, 1) = "N" Then sign$ = "-": t$ = Mid$(t$, 2)
dp = InStr(t$, "D+"): dm = InStr(t$, "D-")
ep = InStr(t$, "E+"): em = InStr(t$, "E-")
check1 = Sgn(dp) + Sgn(dm) + Sgn(ep) + Sgn(em)
If check1 < 1 Or check1 > 1 Then N2S = _Trim$(EXP$): Exit Function ' If no scientic notation is found, or if we find more than 1 type, it's not SN!
Select Case l ' l now tells us where the SN starts at.
Case Is < dp: l = dp
Case Is < dm: l = dm
Case Is < ep: l = ep
Case Is < em: l = em
End Select
l$ = Left$(t$, l - 1) ' The left of the SN
r$ = Mid$(t$, l + 1): r&& = Val(r$) ' The right of the SN, turned into a workable long
If InStr(l$, ".") Then ' Location of the decimal, if any
If r&& > 0 Then
r&& = r&& - Len(l$) + 2
Else
r&& = r&& + 1
End If
l$ = Left$(l$, 1) + Mid$(l$, 3)
End If
Select Case r&&
Case 0 ' what the heck? We solved it already?
' l$ = l$
Case Is < 0
For i = 1 To -r&&
l$ = "0" + l$
Next
l$ = "." + l$
Case Else
For i = 1 To r&&
l$ = l$ + "0"
Next
l$ = l$
End Select
N2S$ = sign$ + l$
End Function ' N2S$
' /////////////////////////////////////////////////////////////////////////////
' Pauses for iDS deciseconds (iDS * 100 ms)
Sub PauseDecisecond (iDS As Integer)
Dim iCount As Integer
iCount = 0
Do
iCount = iCount + 1
_Limit 10 ' run 10x every second
Loop Until iCount = iDS
End Sub ' PauseDecisecond
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if point (x1%, y1%) is adjacent to point (x2%, y2%)
Function PointsAreAdjacent% (x1%, y1%, x2%, y2%)
Dim bResult%: bResult% = FALSE
' x or y can be the same, but not both
If (x1% <> x2%) Or (y1% <> y2%) Then
If (x1% = x2%) Or ((x1% = (x2% + 1)) Or (x2% = (x1% + 1))) Then
If (y1% = y2%) Or ((y1% = (y2% + 1)) Or (y2% = (y1% + 1))) Then
bResult% = TRUE
End If
End If
End If
PointsAreAdjacent% = bResult%
End Function ' PointsAreAdjacent%
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
' Example:
' ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = ProgramPath$ + ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, FALSE)
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
If Len(sError) = 0 Then
If (bAppend = TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
End If
If Len(sError) = 0 Then
' NOTE: WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 0-based.
' See also: PrintString1
Sub PrintString (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * iCol
iY = _FontHeight * iRow ' (iRow + 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 1-based.
' See also: PrintString
Sub PrintString1 (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * (iCol - 1)
iY = _FontHeight * (iRow - 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString1
' /////////////////////////////////////////////////////////////////////////////
' Prints text character char$ at positoin x%,y% in color myColor&.
Sub PutCharXY (x%, y%, char$, myColor&)
Color myColor&
Locate y%, x%
Print char$;
End Sub ' PutCharXY
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
' SET RANDOM SEED
'Randomize ' Initialize random-number generator.
Randomize Timer
' GET RANDOM # Min%-Max%
'RandomNumber = Int((Max * Rnd) + Min) ' generate number
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub RandomNumberTest
' Dim iCols As Integer: iCols = 10
' Dim iRows As Integer: iRows = 20
' Dim iLoop As Integer
' Dim iX As Integer
' Dim iY As Integer
' Dim sError As String
' Dim sFileName As String
' Dim sText As String
' Dim bAppend As Integer
' Dim iMin As Integer
' Dim iMax As Integer
' Dim iNum As Integer
' Dim iErrorCount As Integer
' Dim sInput$
'
' sFileName = "c:\temp\maze_test_1.txt"
' sText = "Count" + Chr$(9) + "Min" + Chr$(9) + "Max" + Chr$(9) + "Random"
' bAppend = FALSE
' sError = PrintFile$(sFileName, sText, bAppend)
' If Len(sError) = 0 Then
' bAppend = TRUE
' iErrorCount = 0
'
' iMin = 0
' iMax = iCols - 1
' For iLoop = 1 To 100
' iNum = RandomNumber%(iMin, iMax)
' sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
' sError = PrintFile$(sFileName, sText, bAppend)
' If Len(sError) > 0 Then
' iErrorCount = iErrorCount + 1
' Print Str$(iLoop) + ". ERROR"
' Print " " + "iMin=" + Str$(iMin)
' Print " " + "iMax=" + Str$(iMax)
' Print " " + "iNum=" + Str$(iNum)
' Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
' Print " " + sError
' End If
' Next iLoop
'
' iMin = 0
' iMax = iRows - 1
' For iLoop = 1 To 100
' iNum = RandomNumber%(iMin, iMax)
' sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
' sError = PrintFile$(sFileName, sText, bAppend)
' If Len(sError) > 0 Then
' iErrorCount = iErrorCount + 1
' Print Str$(iLoop) + ". ERROR"
' Print " " + "iMin=" + Str$(iMin)
' Print " " + "iMax=" + Str$(iMax)
' Print " " + "iNum=" + Str$(iNum)
' Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
' Print " " + sError
' End If
' Next iLoop
'
' Print "Finished generating numbers. Errors: " + Str$(iErrorCount)
' Else
' Print "Error creating file " + Chr$(34) + sFileName + Chr$(34) + "."
' Print sError
' End If
'
' Input "Press <ENTER> to continue", sInput$
'End Sub ' RandomNumberTest
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub ReplaceTest
' Dim in$
'
' Print "-------------------------------------------------------------------------------"
' Print "ReplaceTest"
' Print
'
' Print "Original value"
' in$ = "Thiz iz a teZt."
' Print "in$ = " + Chr$(34) + in$ + Chr$(34)
' Print
'
' Print "Replacing lowercase " + Chr$(34) + "z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
' in$ = Replace$(in$, "z", "s")
' Print "in$ = " + Chr$(34) + in$ + Chr$(34)
' Print
'
' Print "Replacing uppercase " + Chr$(34) + "Z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
' in$ = Replace$(in$, "Z", "s")
' Print "in$ = " + Chr$(34) + in$ + Chr$(34)
' Print
'
' Print "ReplaceTest finished."
'End Sub ' ReplaceTest
' /////////////////////////////////////////////////////////////////////////////
' https://qb64phoenix.com/forum/showthread.php?tid=644
' From: bplus
' Date: 07-18-2022, 03:16 PM
' Here is a Round$ that acts the way you'd expect in under 100 LOC
' b = b + ...
Function Round$ (anyNumber, dp As Long)
' 5 and up at decimal place dp+1 > +1 at decimal place 4 and down > +0 at dp
' 2 1 0.-1 -2 -3 -4 ... pick dp like this for this Round$ Function
sn$ = N2S$(Str$(anyNumber + .5 * 10 ^ dp)) ' get rid of sci notation, steve trims it so next find dot
dot = InStr(sn$, ".")
If dot Then
predot = dot - 1
postdot = Len(sn$) - (dot + 1)
Else
predot = Len(sn$)
postdot = 0
End If
' xxx.yyyyyy dp = -2
' ^ dp
If dp >= 0 Then
Rtn$ = Mid$(sn$, 1, predot - dp) + String$(dp, "0")
Else
Rtn$ = Mid$(sn$, 1, predot) + "." + Mid$(sn$, dot + 1, -dp)
End If
If Rtn$ = "" Then
Round$ = "0"
Else
Round$ = Rtn$
End If
End Function ' Round$
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub RoundTest
' Print Round$(.15, 0) ' 0
' Print Round$(.15, -1) ' .2
' Print Round$(.15, -2) ' .15
' Print Round$(.15, -3) ' .150
' Print
' Print Round$(3555, 0) ' 3555
' Print Round$(3555, 1) ' 3560
' Print Round$(3555, 2) ' 3600 'good
' Print Round$(3555, 3) ' 4000
' Print
' Print Round$(23.149999, -1) ' 23.1
' Print Round$(23.149999, -2) ' 23.15
' Print Round$(23.149999, -3) ' 23.150
' Print Round$(23.149999, -4) ' 23.1500
' Print
' Print Round$(23.143335, -1) ' 23.1 OK?
' Print Round$(23.143335, -2) ' 23.14
' Print Round$(23.143335, -3) ' 23.143
' Print Round$(23.143335, -4) ' 23.1433
' Print Round$(23.143335, -5) ' 23.14334
' Print
' Dim float31 As _Float
' float31 = .310000000000009
' Print Round$(.31, -2) ' .31
' Print Round$(.31##, -2)
' Print Round$(float31, -2)
'End Sub ' RoundTest
' /////////////////////////////////////////////////////////////////////////////
' TODO: verify these work (function Round$ works)
' https://www.qb64.org/forum/index.php?topic=3605.0
' Quote from: SMcNeill on Today at 03:53:48 PM
'
' Sometimes, you guys make things entirely too complicated.
' There ya go! Three functions to either round naturally,
' always round down, or always round up, to whatever number of digits you desire.
' EDIT: Modified to add another option to round scientific,
' since you had it's description included in your example.
Function RoundNatural## (num##, digits%)
RoundNatural## = Int(num## * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUp## (num##, digits%)
RoundUp## = _Ceil(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDown## (num##, digits%)
RoundDown## = Int(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function Round_Scientific## (num##, digits%)
Round_Scientific## = _Round(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundUpDouble# (num#, digits%)
RoundUpDouble# = _Ceil(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundUpSingle! (num!, digits%)
RoundUpSingle! = _Ceil(num! * 10 ^ digits%) / 10 ^ digits%
End Function
' /////////////////////////////////////////////////////////////////////////////
' fantastically inefficient way to set a bit
' example use: arrMaze(iX, iY) = SetBit256%(arrMaze(iX, iY), cS, FALSE)
' See also: GetBit256%, SetBit256%
' newint=SetBit256%(oldint, int containing the bits we want to set, value to set them to)
Function SetBit256% (iNum1 As Integer, iBit1 As Integer, bVal1 As Integer)
Dim sNum As String
Dim sBit As String
Dim sVal As String
Dim iLoop As Integer
Dim strResult As String
Dim iResult As Integer
Dim iNum As Integer: iNum = iNum1
Dim iBit As Integer: iBit = iBit1
Dim bVal As Integer: bVal = bVal1
If iNum < 256 And iBit <= 128 Then
sNum = GetBinary$(iNum)
sBit = GetBinary$(iBit)
If bVal = TRUE Then
sVal = "1"
Else
sVal = "0"
End If
strResult = ""
For iLoop = 1 To 8
If Mid$(sBit, iLoop, 1) = "1" Then
strResult = strResult + sVal
Else
strResult = strResult + Mid$(sNum, iLoop, 1)
End If
Next iLoop
iResult = GetIntegerFromBinary%(strResult)
Else
iResult = iNum
End If
SetBit256% = iResult
End Function ' SetBit256%
' /////////////////////////////////////////////////////////////////////////////
' TODO: verify this works
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function SngToStr$ (n!)
value$ = UCase$(LTrim$(Str$(n!)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") 'only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-": valu$ = Mid$(value$, 2, Xpos% - 2)
Else valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, "."): L% = Len(valu$)
If expo% > 0 Then add$ = String$(expo% - (L% - dot%), "0")
If expo% < 0 Then min$ = String$(Abs(expo%) - (dot% - 1), "0"): DP$ = "."
For n = 1 To L%
If Mid$(valu$, n, 1) <> "." Then num$ = num$ + Mid$(valu$, n, 1)
Next
Else SngToStr$ = value$: Exit Function
End If
SngToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
End Function ' SngToStr$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub SplitTest
' Dim in$
' Dim delim$
' ReDim arrTest$(0)
' Dim iLoop%
'
' delim$ = Chr$(10)
' in$ = "this" + delim$ + "is" + delim$ + "a" + delim$ + "test"
' Print "in$ = " + Chr$(34) + in$ + Chr$(34)
' Print "delim$ = " + Chr$(34) + delim$ + Chr$(34)
' split in$, delim$, arrTest$()
'
' For iLoop% = LBound(arrTest$) To UBound(arrTest$)
' Print "arrTest$(" + LTrim$(RTrim$(Str$(iLoop%))) + ") = " + Chr$(34) + arrTest$(iLoop%) + Chr$(34)
' Next iLoop%
' Print
' Print "Split test finished."
'End Sub ' SplitTest
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub SplitAndReplaceTest
' Dim in$
' Dim out$
' Dim iLoop%
' ReDim arrTest$(0)
'
' Print "-------------------------------------------------------------------------------"
' Print "SplitAndReplaceTest"
' Print
'
' Print "Original value"
' in$ = "This line 1 " + Chr$(13) + Chr$(10) + "and line 2" + Chr$(10) + "and line 3 " + Chr$(13) + "finally THE END."
' out$ = in$
' out$ = Replace$(out$, Chr$(13), "\r")
' out$ = Replace$(out$, Chr$(10), "\n")
' out$ = Replace$(out$, Chr$(9), "\t")
' Print "in$ = " + Chr$(34) + out$ + Chr$(34)
' Print
'
' Print "Fixing linebreaks..."
' in$ = Replace$(in$, Chr$(13) + Chr$(10), Chr$(13))
' in$ = Replace$(in$, Chr$(10), Chr$(13))
' out$ = in$
' out$ = Replace$(out$, Chr$(13), "\r")
' out$ = Replace$(out$, Chr$(10), "\n")
' out$ = Replace$(out$, Chr$(9), "\t")
' Print "in$ = " + Chr$(34) + out$ + Chr$(34)
' Print
'
' Print "Splitting up..."
' split in$, Chr$(13), arrTest$()
'
' For iLoop% = LBound(arrTest$) To UBound(arrTest$)
' out$ = arrTest$(iLoop%)
' out$ = Replace$(out$, Chr$(13), "\r")
' out$ = Replace$(out$, Chr$(10), "\n")
' out$ = Replace$(out$, Chr$(9), "\t")
' Print "arrTest$(" + cstr$(iLoop%) + ") = " + Chr$(34) + out$ + Chr$(34)
' Next iLoop%
' Print
'
' Print "SplitAndReplaceTest finished."
'End Sub ' SplitAndReplaceTest
' /////////////////////////////////////////////////////////////////////////////
' Converts a chr$(13) delimited string
' into a 2-dimensional array.
' Usage:
' Dim StringArray(1 To 48, 1 To 128) As String
' StringTo2dArray StringArray(), GetMap$
' Version 2 with indexed array(row, columm)
' Renamed StringToArray to StringTo2dArray.
' See also: Array2dToString$
Sub StringTo2dArray (MyArray() As String, MyString As String)
Dim sDelim As String
ReDim arrLines(0) As String
Dim iRow As Integer
Dim iCol As Integer
Dim sChar As String
Dim iDim1 As Integer
Dim iDim2 As Integer
Dim iIndex1 As Integer
Dim iIndex2 As Integer
iDim1 = LBound(MyArray, 1)
iDim2 = LBound(MyArray, 2)
sDelim = Chr$(13)
split MyString, sDelim, arrLines()
For iRow = LBound(arrLines) To UBound(arrLines)
If iRow <= UBound(MyArray, 1) Then
For iCol = 1 To Len(arrLines(iRow))
If iCol <= UBound(MyArray, 2) Then
sChar = Mid$(arrLines(iRow), iCol, 1)
If Len(sChar) > 1 Then
sChar = Left$(sChar, 1)
Else
If Len(sChar) = 0 Then
sChar = "."
End If
End If
iIndex1 = iRow + iDim1
iIndex2 = (iCol - 1) + iDim2
MyArray(iIndex1, iIndex2) = sChar
'DebugPrint "MyArray(" + cstr$(iIndex1) + ", " + cstr$(iIndex2) + " = " + chr$(34) + sChar + chr$(34)
Else
' Exit if out of bounds
Exit For
End If
Next iCol
Else
' Exit if out of bounds
Exit For
End If
Next iRow
End Sub ' StringTo2dArray
' /////////////////////////////////////////////////////////////////////////////
Function StrPadLeft$ (sValue As String, iWidth As Integer)
StrPadLeft$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrPadLeft$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyRight$ (sValue As String, iWidth As Integer)
StrJustifyRight$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrJustifyRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrPadRight$ (sValue As String, iWidth As Integer)
StrPadRight$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrPadRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyLeft$ (sValue As String, iWidth As Integer)
StrJustifyLeft$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrJustifyLeft$
' /////////////////////////////////////////////////////////////////////////////
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
Function StrJustifyCenter$ (sValue As String, iWidth As Integer)
Dim iLen0 As Integer
Dim iLen1 As Integer
Dim iLen2 As Integer
Dim iExtra As Integer
iLen0 = Len(sValue)
If iWidth = iLen0 Then
' no extra space: return unchanged
StrJustifyCenter$ = sValue
ElseIf iWidth > iLen0 Then
If IsOdd%(iWidth) Then
iWidth = iWidth - 1
End If
' center
iExtra = iWidth - iLen0
iLen1 = iExtra \ 2
iLen2 = iLen1 + (iExtra Mod 2)
StrJustifyCenter$ = String$(iLen1, " ") + sValue + String$(iLen2, " ")
Else
' string is too long: truncate
StrJustifyCenter$ = Left$(sValue, iWidth)
End If
End Function ' StrJustifyCenter$
' /////////////////////////////////////////////////////////////////////////////
' Use to pretty print TRUE and FALSE values.
Function TrueFalse$ (myValue)
If myValue = TRUE Then
TrueFalse$ = "TRUE"
Else
TrueFalse$ = "FALSE"
End If
End Function ' TrueFalse$
' /////////////////////////////////////////////////////////////////////////////
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' #REFERENCE
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' @REFERENCE
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++RE: some date/time/timestamp functions revisited - mnrvovrfc - 03-02-2023
Nice work. One thing that I advise, though, is that instead of this line:
Code: (Select All)
Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0could put this at the top:
Code: (Select All)
$CONSOLE:ONLYSome of us are on "tiny" laptops with only 768 pixel rows, and 8x8 characters become unreadable.
However I noticed a function GetColorXY(). Does this program do any text highlighting?
RE: some date/time/timestamp functions revisited - mdijkens - 03-02-2023
I've written this a long time ago and still using it everywhere to handle/calculate with dates/times:
Code: (Select All)
Function timeStamp~&& (dt$)
year% = Val(Left$(dt$, 4)): month% = Val(Mid$(dt$, 6, 2)): day% = Val(Mid$(dt$, 9, 2))
hour% = Val(Mid$(dt$, 13, 2)): minute% = Val(Mid$(dt$, 16, 2)): second% = Val(Mid$(dt$, 19, 2))
timeStamp~&& = TIM.stamp(year%, month%, day%, hour%, minute%, second%)
End Function
Function timeString$ (dt~&&)
dt$ = TIM.dateTime$(dt~&&, year%, month%, day%, hour%, minute%, second%)
timeString$ = Left$(dt$, 4) + "-" + Mid$(dt$, 5, 2) + "-" + Mid$(dt$, 7, 2) + " " + Mid$(dt$, 9, 2) + ":" + Mid$(dt$, 11, 2) + ":" + Mid$(dt$, 13, 2)
End Function
Function TIM.now~&& ()
dat$ = Date$: tim~& = Timer
month% = Val(Left$(dat$, 2))
day% = Val(Mid$(dat$, 4, 2))
year% = Val(Mid$(dat$, 7, 4))
TIM.now~&& = TIM.days~&(year%, month%, day%) * 86400~&& + tim~&
End Function
Function TIM.utc~&& ()
Type UTCtype
year As Integer
month As Integer
weekday As Integer
day As Integer
hour As Integer
minute As Integer
second As Integer
millis As Integer
End Type
Declare Dynamic Library "Kernel32"
Sub GetUTC Alias GetSystemTime (lpSystemTime As UTCtype)
End Declare
Dim utc As UTCtype: GetUTC utc
TIM.utc~&& = TIM.stamp~&&(utc.year, utc.month, utc.day, utc.hour, utc.minute, utc.second)
End Function
Function TIM.stamp~&& (year%, month%, day%, hour%, minute%, second%)
TIM.stamp~&& = TIM.days~&(year%, month%, day%) * 86400~&& + TIM.seconds~&(hour%, minute%, second%)
End Function
Function TIM.days~& (year%, month%, day%)
leap% = TIM.leapYear(year%): prevYear% = year% - 1
dPrevYears& = ((((prevYear% * 365) + (prevYear% \ 4)) - (prevYear% \ 100)) + (prevYear% \ 400))
Select Case month%
Case 1: TIM.days~& = ((dPrevYears&) + day%) - 1
Case 2: TIM.days~& = ((dPrevYears& + 31) + day%) - 1
Case 3: TIM.days~& = ((dPrevYears& + 59 - leap%) + day%) - 1
Case 4: TIM.days~& = ((dPrevYears& + 90 - leap%) + day%) - 1
Case 5: TIM.days~& = ((dPrevYears& + 120 - leap%) + day%) - 1
Case 6: TIM.days~& = ((dPrevYears& + 151 - leap%) + day%) - 1
Case 7: TIM.days~& = ((dPrevYears& + 181 - leap%) + day%) - 1
Case 8: TIM.days~& = ((dPrevYears& + 212 - leap%) + day%) - 1
Case 9: TIM.days~& = ((dPrevYears& + 243 - leap%) + day%) - 1
Case 10: TIM.days~& = ((dPrevYears& + 273 - leap%) + day%) - 1
Case 11: TIM.days~& = ((dPrevYears& + 304 - leap%) + day%) - 1
Case 12: TIM.days~& = ((dPrevYears& + 334 - leap%) + day%) - 1
Case Else: TIM.days~& = 0
End Select
End Function
Function TIM.seconds~& (hour%, minute%, second%)
TIM.seconds~& = hour% * 3600 + minute% * 60 + second%
End Function
Function TIM.dateTime$ (timestmp~&&, year%, month%, day%, hour%, minute%, second%)
tdays~& = timestmp~&& \ 86400 + 306
secs~& = timestmp~&& Mod 86400
era% = tdays~& \ 146097
doe~& = tdays~& Mod 146097 ' [0, 146096]
yoe% = (doe~& - doe~& \ 1460 + doe~& \ 36524 - doe~& \ 146096) \ 365 ' [0, 399]
year% = yoe% + era% * 400
doy% = doe~& - (365 * yoe% + yoe% \ 4 - yoe% \ 100) ' [0, 365]
mp% = (5 * doy% + 2) \ 153 ' [0, 11]
day% = doy% - (153 * mp% + 2) \ 5 + 1 ' [1, 31]
If mp% < 10 Then month% = mp% + 3 Else month% = mp% - 9 ' [1, 12]
year% = year% - (month% <= 2)
dat$ = Right$("000" + LTrim$(Str$(year%)), 4) + _
Right$("0" + LTrim$(Str$(month%)), 2) + _
Right$("0" + LTrim$(Str$(day%)), 2)
hour% = secs~& \ 3600
minsec% = secs~& - (hour% * 3600)
minute% = minsec% \ 60
second% = minsec% - (minute% * 60)
TIM.dateTime$ = dat$ + _
Right$("0" + LTrim$(Str$(hour%)), 2) + _
Right$("0" + LTrim$(Str$(minute%)), 2) + _
Right$("0" + LTrim$(Str$(second%)), 2)
End Function
Function TIM.format$ (ts~&&)
dt$ = TIM.dateTime$(ts~&&, year, month, day, hour, minute, second)
dt2$ = Mid$("SuMoTuWeThFrSa", TIM.weekDay(ts~&&) * 2 + 1, 2)+" " + _
Mid$(dt$, 7, 2) + "-" + Mid$(dt$, 5, 2) + "-" + Mid$(dt$, 1, 4) + " " + _
Mid$(dt$, 9, 2) + ":" + Mid$(dt$, 11, 2) + ":" + Mid$(dt$, 13, 2)
TIM.format$ = dt2$
End Function
Function TIM.leapYear% (year%)
If (year% Mod 4) <> 0 Then
TIM.leapYear% = FALSE
ElseIf (year% Mod 100) = 0 Then
TIM.leapYear% = (year% Mod 400) = 0
Else
TIM.leapYear% = TRUE
End If
End Function
Function TIM.weekDay% (ts~&&)
tdays~& = ts~&& \ 86400
TIM.weekDay% = (tdays~& + 1) Mod 7
End FunctionRE: some date/time/timestamp functions revisited - mnrvovrfc - 03-02-2023
Well done but for Windows only. I made an attempt to fix the "TIM.UTC~&&()" function so it worked for Linux but was unsuccessful. Must instead use "gmtime()" or "mktime()" from C library and "struct tm" which is ordered a bit differently and doesn't offer milliseconds. The "mktime()" takes only one parameter of "struct tm" but goes on local time not UTC. The "gmtime()" however is more complicated to use, the first parameter is a structure with "calendar" time and the second parameter is the return value of type "struct tm". Is the "TIM.UTC~&&()" used to get today's date and current time? That's how I attempted to fix it.
This is the one function in mdijkens' code that I tried to fix:
Code: (Select All)
Function TIM.utc~&& ()
$IF WIN THEN
Type UTCtype
year As Integer
month As Integer
weekday As Integer
day As Integer
hour As Integer
minute As Integer
second As Integer
millis As Integer
End Type
Declare Dynamic Library "Kernel32"
Sub GetUTC Alias GetSystemTime (lpSystemTime As UTCtype)
End Declare
Dim utc As UTCtype: GetUTC utc
TIM.utc~&& = TIM.stamp~&&(utc.year, utc.month, utc.day, utc.hour, utc.minute, utc.second)
$ELSE
Type UTCtype
second as Integer
minute as Integer
hour as Integer
day as Integer
month as Integer
year as Integer
weekday as Integer
yearday as Integer
isdst as Integer
tmgmtoff as Long
tmzone as _Offset
End Type
Declare CustomType Library
Sub GetUTC Alias mktime (lpSystemTime As UTCtype)
End Declare
Dim utc As UTCtype: GetUTC utc
TIM.utc~&& = TIM.stamp~&&(utc.year, utc.month, utc.day, utc.hour, utc.minute, utc.second)
$END IF
End Functionand this is the "struct tm" definition and the two C functions:
Code: (Select All)
/* from "(include_path)/bits/types/struct_tm.h" */
struct tm
{
int tm_sec; /* Seconds. [0-60] (1 leap second) */
int tm_min; /* Minutes. [0-59] */
int tm_hour; /* Hours. [0-23] */
int tm_mday; /* Day. [1-31] */
int tm_mon; /* Month. [0-11] */
int tm_year; /* Year - 1900. */
int tm_wday; /* Day of week. [0-6] */
int tm_yday; /* Days in year.[0-365] */
int tm_isdst; /* DST. [-1/0/1]*/
# ifdef __USE_MISC
long int tm_gmtoff; /* Seconds east of UTC. */
const char *tm_zone; /* Timezone abbreviation. */
# else
long int __tm_gmtoff; /* Seconds east of UTC. */
const char *__tm_zone; /* Timezone abbreviation. */
# endif
};
/* from "(include_path)/time.h" */
extern struct tm *gmtime (const time_t *__timer) __THROW;
# ifdef __REDIRECT_NTH
extern struct tm*__REDIRECT_NTH (gmtime, (const time_t *__timer), __gmtime64);
# endif
extern time_t mktime (struct tm *__tp) __THROW;RE: some date/time/timestamp functions revisited - Kernelpanic - 03-02-2023
Quote:@mnrvovrfc - could put this at the top: $CONSOLE:ONLY
When using "$Console:only" an error occurs: The output remains empty!
![[Image: Timestamp-Console-Only.jpg]](https://i.ibb.co/CmT1m0j/Timestamp-Console-Only.jpg)
RE: some date/time/timestamp functions revisited - SpriggsySpriggs - 03-03-2023
@Kernelpanic
Comment out the SCREEN NEWIMAGE line when using $CONSOLE:ONLY
RE: some date/time/timestamp functions revisited - Kernelpanic - 03-04-2023
(03-03-2023, 03:02 PM)Balderdash Wrote: @Kernelpanic
Comment out the SCREEN NEWIMAGE line when using $CONSOLE:ONLY
Yes, that's how it works. Thanks!
RE: some date/time/timestamp functions revisited - mnrvovrfc - 03-13-2023
LOL at "SHE-IT BACKWARDS" and needing to look up a function that determines if an integer is odd or even...
There is a whole toolbox in this source code. But what are the chances that there could be at least one thing that isn't around in the code, such as "epoch to string"?
For many jobs to get a formatted date, the "strftime()" function from C library could be used. But there should be an intelligent format to cover the cryptic codes required by the C function because some people don't like typing in "%a" and "%M" and having to remember something alien to BASIC.
I don't know, something like:
Code: (Select All)
dow, mon day, yea at h24:min zonwhich returns:
Code: (Select All)
Monday, March 13, 2023 at 14:05 ESTDSTSearch for three-letter codes to convert into internal percent-codes for "strftime()". Any text not recognized is left alone. Or maybe preface the search tag with "squiggle" or some other character unlikely to be used in a normal communication.
These are just ideas. I'm proposing stuff without coding anything, see if somebody else does it.