05-23-2025, 10:16 PM
(05-23-2025, 11:22 AM)bplus Wrote: Here is 34 very handy Functions in less than 300 LOC
Code: (Select All)' ======================================================================= IFFs of a Type 2023-11-03
Function IfS$ (Bool&, tru$, fals$) ' IF Boolean Return True$ else False$
If Bool& Then IfS$ = tru$ Else IfS$ = fals$
End Function
Function IfL& (Bool&, tru&, fals&) ' IF Boolean Return True& else False&
If Bool& Then IfL& = tru& Else IfL& = fals&
End Function
Function IfD# (Bool&, tru#, fals#) ' IF Boolean Return True# else False#
If Bool& Then IfD# = tru# Else IfD# = fals#
End Function
Function IfUL~& (Bool&, tru~&, fals~&) ' IF Boolean Return True~& else False~&
If Bool& Then IfUL~& = tru~& Else IfUL~& = fals~&
End Function
' ===================================================================================== Random stuff
Function rndI& (n1 As Long, n2 As Long) 'return an integer between 2 numbers
Dim As Long l, h
If n1 > n2 Then l = n2: h = n1 Else l = n1: h = n2
rndI& = Int(Rnd * (h - l + 1)) + l
End Function
Function rndR (n1, n2) 'return real number (_single, double, _float depending on default / define setup)
rndR = (n2 - n1) * Rnd + n1
End Function
Function rndCWI (center, range) 'center +/-range weights to center
Dim As Long halfRange, c
halfRange = Int(range) + 1 'for INT(Rnd) round range in case not integer
c = Int(center + .5)
rndCWI = c + Int(Rnd * (halfRange)) - Int(Rnd * (halfRange))
End Function
' 2023-01-20 tested
Function rndCW (C As Single, range As Single) 'center +/-range weights to center
rndCW = C + Rnd * range - Rnd * range
End Function
Function rdir% ()
If Rnd < .5 Then rdir% = -1 Else rdir% = 1
End Function
'===================================================================================== Handy numbers
Function dist# (x1%, y1%, x2%, y2%) ' hypot might be better
dist# = ((x1% - x2%) ^ 2 + (y1% - y2%) ^ 2) ^ .5
End Function
Function min (a, b)
min = -a * (a < b) - b * (b <= a)
End Function
Function max (a, b)
max = -a * (a > b) - b * (b >= a)
End Function
Function map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
End Function
'======================================================================================= Color stuff
Function qb~& (n As Long)
Select Case n
Case 0: qb~& = &HFF000000
Case 1: qb~& = &HFF000088
Case 2: qb~& = &HFF008800
Case 3: qb~& = &HFF008888
Case 4: qb~& = &HFF880000
Case 5: qb~& = &HFF880088
Case 6: qb~& = &HFF888800
Case 7: qb~& = &HFFCCCCCC
Case 8: qb~& = &HFF888888
Case 9: qb~& = &HFF0000FF
Case 10: qb~& = &HFF00FF00
Case 11: qb~& = &HFF00FFFF
Case 12: qb~& = &HFFFF0000
Case 13: qb~& = &HFFFF00FF
Case 14: qb~& = &HFFFFFF00
Case 15: qb~& = &HFFFFFFFF
End Select
End Function
Function rclr~& ()
rclr~& = _RGB32(rndI(64, 255), rndI(64, 255), rndI(64, 255), rndI(0, 255))
End Function
Function Plasma~& ()
cN = cN + 1 ''Dim Shared cN, pR, pG, pB
Plasma~& = _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
End Function
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function
' ===================================================================================== String Stuff
Function LeftOf$ (source$, of$)
If InStr(source$, of$) > 0 Then
LeftOf$ = Mid$(source$, 1, InStr(source$, of$) - 1)
Else
LeftOf$ = source$
End If
End Function
' update these 2 in case of$ is not found! 2021-02-13
Function RightOf$ (source$, of$)
If InStr(source$, of$) > 0 Then
RightOf$ = Mid$(source$, InStr(source$, of$) + Len(of$))
Else
RightOf$ = ""
End If
End Function
Function strReplace$ (s$, replace$, new$) 'case sensitive 2020-07-28 version
Dim p As Long, sCopy$, LR As Long, lNew As Long
If Len(s$) = 0 Or Len(replace$) = 0 Then
strReplace$ = s$: Exit Function
Else
LR = Len(replace$): lNew = Len(new$)
End If
sCopy$ = s$ ' otherwise s$ would get changed
p = InStr(sCopy$, replace$)
While p
sCopy$ = Mid$(sCopy$, 1, p - 1) + new$ + Mid$(sCopy$, p + LR)
p = InStr(p + lNew, sCopy$, replace$)
Wend
strReplace$ = sCopy$
End Function
Function strEnclose$ (s$, str1or2$)
If Len(str1or2$) = 2 Then
strEnclose$ = Left$(str1or2$, 1) + s$ + Right$(str1or2$, 1)
ElseIf Len(str1or2$) = 1 Then
strEnclose$ = str1or2$ + s$ + str1or2$
Else
Beep
End If
End Function
Function StrCopies$ (NumberOfCopies&, S$) ' modified 2021-02-19 to match STRING$ args and for SUB AStringInsertAtNthPlace
Dim i&, b$
For i& = 1 To NumberOfCopies&
b$ = b$ + S$
Next
StrCopies$ = b$
End Function
'Description: Use Item$() Function to treat strings like arrays without having to use an array structure.
' This function does not throw a fit if you ask for an item number (index) it does not have, it just returns an empty string.
' In QB64, Functions can't return arrays through the function name, but they can return strings that the Item$() function can
' translate like an an array index. nItem numbers are the same as Counting numbers positive integers starting at 1.
' eg Item7$ = Item$(CommaDelimitedString$, 7, ",") 'get 7th Item in string
Function Item$ (s$, nItem As Long, delimiter$)
Dim c As Long, d As Long, lastd As Long
If Len(s$) = 0 Then Item$ = "": Exit Function
lastd = 1: d = InStr(lastd, s$, delimiter$)
While d > 0
c = c + 1
If c = nItem Then
Item$ = Mid$(s$, lastd, d - lastd): Exit Function
Else
lastd = d + 1: d = InStr(lastd, s$, delimiter$)
End If
Wend
c = c + 1
If c <> nItem Then Item$ = "" Else Item$ = Mid$(s$, lastd, Len(s$))
End Function
Function format$ (template As String, Source As String)
Dim d, s, n, i, t$
d = _Dest: s = _Source
n = _NewImage(80, 80, 0)
_Dest n: _Source n
Print Using template; Val(Source)
For i = 1 To 79
t$ = t$ + Chr$(Screen(1, i))
Next
If Left$(t$, 1) = "%" Then t$ = Mid$(t$, 2)
format$ = _Trim$(t$)
_Dest d: _Source s
_FreeImage n
End Function
Function xDP$ (x, DP)
Dim test$, p As Long
test$ = _Trim$(Str$(Int(x * 10 ^ DP) / 10 ^ DP))
p = InStr(test$, ".")
If p = 0 And DP <> 0 Then test$ = test$ + "." + String$(DP, "0")
If p And DP = 0 Then test$ = Left$(test$, Len(test$) - 1)
xDP$ = test$
End Function
Function commaD$ (n#, nDecPlaces%) 'only works right for double# type
Dim place As Long, s$, front$, back$, func$
func$ = _Trim$(Str$(n#))
If Left$(func$, 1) = "-" Then s$ = "-": func$ = Mid$(func$, 2) Else s$ = ""
place = InStr(func$, ".")
If place = 0 Then place = Len(func$) + 1
While place > 4
func$ = Mid$(func$, 1, place - 4) + "," + Mid$(func$, place - 3)
place = InStr(func$, ",")
Wend
'fix to nDecPlaces
place = InStr(func$, ".")
If nDecPlaces% Then
If place Then
front$ = Mid$(func$, 1, place)
back$ = Mid$(func$, place + 1)
If Len(back$) > nDecPlaces% Then func$ = front$ + Left$(back$, nDecPlaces%)
If Len(back$) < nDecPlaces% Then func$ = front$ + Left$(back$ + String$(nDecPlaces%, "0"), nDecPlaces%)
Else
func$ = func$ + "." + String$(nDecPlaces%, "0")
End If
Else
If place Then func$ = Mid$(func$, 1, place - 1)
End If
commaD$ = s$ + func$
End Function
'this might make a nice Money format
Function money$ (n#) 'only works right for double# type
Dim place As Long, s$, front$, back$, b$
b$ = _Trim$(Str$(n#))
If Left$(b$, 1) = "-" Then s$ = "-": b$ = Mid$(b$, 2) Else s$ = ""
place = InStr(b$, ".")
If place = 0 Then place = Len(b$) + 1
While place > 4
b$ = Mid$(b$, 1, place - 4) + "," + Mid$(b$, place - 3)
place = InStr(b$, ",")
Wend
'fix this for 2 places after decimal
place = InStr(b$, ".")
If place Then
front$ = Mid$(b$, 1, place)
back$ = Mid$(b$, place + 1)
If Len(back$) > 2 Then b$ = front$ + Left$(back$, 2)
If Len(back$) < 2 Then b$ = front$ + Left$(back$ + "00", 2)
Else
b$ = b$ + ".00"
End If
money$ = "$" + s$ + b$
End Function
Function DateTimeStamp$
DateTimeStamp$ = Mid$(Date$, 7) + "-" + Mid$(Date$, 1, 2) + "-" + Mid$(Date$, 4, 2) + "_" + Mid$(Time$, 1, 2)
End Function
Function xStr$ (x, strng$) ' make x copies of string
Dim i As Long, b$
For i = 1 To x
b$ = b$ + strng$
Next
xStr$ = b$
End Function
Function timeStr2Secs! (timeStr$)
Dim hh As Long, mm As Long, s!
hh = Val(Mid$(timeStr$, 1, 2))
mm = Val(Mid$(timeStr$, 4, 2))
s! = Val(Mid$(timeStr$, 7, 5))
timeStr2Secs! = hh * 60 * 60 + mm * 60 + s!
End Function
Function secs2TimeStr$ (secs!)
Dim hh As Long, mm As Long, s!, h$, m$, s$
hh = secs! \ 3600
mm = (secs! - hh * 3600) \ 60
s! = (secs! - hh * 3600 - mm * 60)
s! = Int(s! * 100) / 100
h$ = Right$("00" + LTrim$(Str$(hh)), 2)
m$ = Right$("00" + LTrim$(Str$(mm)), 2)
s$ = Right$("00000" + LTrim$(Str$(s!)), 5)
secs2TimeStr$ = h$ + ":" + m$ + ":" + s$
End Function
'load a file into a string from GUI Tools 1 TxtBoxes 2019-09-30
Function fileStr$ (txtFile$)
Dim b$
If _FileExists(txtFile$) Then
Open txtFile$ For Binary As #1
b$ = Space$(LOF(1))
Get #1, , b$
Close #1
fileStr$ = b$
End If
End Function
Function Join$ (arr() As String, delimiter$)
Dim i As Long, b$
For i = LBound(arr) To UBound(arr)
If i = LBound(arr) Then b$ = arr(LBound(arr)) Else b$ = b$ + delimiter$ + arr(i)
Next
Join$ = b$
End Function
Wow, thanks bplus!
I'll work my way through these (over a few days), to see what I can absorb, and which functions I may be able to adapt for my use.
But I'm still of the mind that I'll give prefrerence to Subs where I have a choice - they seem more intuitive, and I'm much more familiar with them.
Thanks for all your work and help.
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, Western Australia.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/