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
b = b + ...