modBasic.bas

Attribute VB_Name = "modBasic"
Option Explicit
Public Const Pi As Double = 3.14159265358979
Public Const Rad2Deg As Double = 180 / Pi

Public Function SetLen(str, num%)
    If num% > Len(CStr(str)) Then
        SetLen = Space(num% - Len(CStr(str)))
    End If
End Function
Public Function Bin(bina As String)
    Dim i As Integer
    Bin = 0
    For i = 1 To Len(bina)
        Bin = Bin + Abs(Mid$(bina, i, 1) = "1") * 2 ^ (Len(bina) - i)
    Next i
End Function
Public Function HSL(hue%, sat%, lum%)
    Dim red, green, blue
    
    If hue% >= 256 / 6 * 0 And hue% < 256 / 6 * 1 Then red = 1
    If hue% >= 256 / 6 * 1 And hue% < 256 / 6 * 2 Then red = 1 - (hue% - (256 / 6) * Int(hue / (256 / 6))) / (256 / 6)
    If hue% >= 256 / 6 * 2 And hue% < 256 / 6 * 3 Then red = 0
    If hue% >= 256 / 6 * 3 And hue% < 256 / 6 * 4 Then red = 0
    If hue% >= 256 / 6 * 4 And hue% < 256 / 6 * 5 Then red = (hue% - (256 / 6) * Int(hue / (256 / 6))) / (256 / 6)
    If hue% >= 256 / 6 * 5 And hue% < 256 / 6 * 6 Then red = 1
    
    If hue% >= 256 / 6 * 0 And hue% < 256 / 6 * 1 Then green = (hue% - (256 / 6) * Int(hue / (256 / 6))) / (256 / 6)
    If hue% >= 256 / 6 * 1 And hue% < 256 / 6 * 2 Then green = 1
    If hue% >= 256 / 6 * 2 And hue% < 256 / 6 * 3 Then green = 1
    If hue% >= 256 / 6 * 3 And hue% < 256 / 6 * 4 Then green = 1 - (hue% - (256 / 6) * Int(hue / (256 / 6))) / (256 / 6)
    If hue% >= 256 / 6 * 4 And hue% < 256 / 6 * 5 Then green = 0
    If hue% >= 256 / 6 * 5 And hue% < 256 / 6 * 6 Then green = 0
    
    If hue% >= 256 / 6 * 0 And hue% < 256 / 6 * 1 Then blue = 0
    If hue% >= 256 / 6 * 1 And hue% < 256 / 6 * 2 Then blue = 0
    If hue% >= 256 / 6 * 2 And hue% < 256 / 6 * 3 Then blue = (hue% - (256 / 6) * Int(hue / (256 / 6))) / (256 / 6)
    If hue% >= 256 / 6 * 3 And hue% < 256 / 6 * 4 Then blue = 1
    If hue% >= 256 / 6 * 4 And hue% < 256 / 6 * 5 Then blue = 1
    If hue% >= 256 / 6 * 5 And hue% < 256 / 6 * 6 Then blue = 1 - (hue% - (256 / 6) * Int(hue / (256 / 6))) / (256 / 6)
    
    red = 0.5 + (red - 0.5) * sat / 256
    blue = 0.5 + (blue - 0.5) * sat / 256
    green = 0.5 + (green - 0.5) * sat / 256
    
    If lum% < 128 Then red = red * lum / 128: green = green * lum / 128: blue = blue * lum / 128
    If lum% > 128 Then red = red + (lum - 128) / 128 * (1 - red): green = green + (lum - 128) / 128 * (1 - green): blue = blue + (lum - 128) / 128 * (1 - blue)
    
    
    
    If red > 1 Then red = 1
    If green > 1 Then green = 1
    If blue > 1 Then blue = 1
    
    HSL = RGB(red * 256, green * 256, blue * 256)
End Function
Public Function GetHue(colour)
    On Error GoTo err:
    Dim red, green, blue
    red = (colour - ((Int((colour - (Int(colour / 256 ^ 2)) * 256 ^ 2) / 256)) * 256) - (Int(colour / 256 ^ 2)) * 256 ^ 2)
    green = (Int((colour - (Int(colour / 256 ^ 2)) * 256 ^ 2) / 256))
    blue = (Int(colour / 256 ^ 2))
    
    red = (red - Min(red, green, blue)) / (Max(red, green, blue) - Min(red, green, blue))
    green = (green - Min(red, green, blue)) / (Max(red, green, blue) - Min(red, green, blue))
    blue = (blue - Min(red, green, blue)) / (Max(red, green, blue) - Min(red, green, blue))
    
    If red = 1 And green >= 0 And green <= 1 And blue = 0 Then GetHue = green * 256 / 6 * 1: Exit Function
    If red >= 0 And red <= 1 And green = 1 And blue = 0 Then: GetHue = (1 - red) * 256 / 6 + 256 / 6: Exit Function
    If red = 0 And green = 1 And blue >= 0 And blue <= 1 Then: GetHue = blue * 256 / 6 + 256 / 6 * 2: Exit Function
    If red = 0 And green >= 0 And green <= 1 And blue = 1 Then: GetHue = (1 - green) * 256 / 6 + 256 / 6 * 3: Exit Function
    If red >= 0 And red <= 1 And green = 0 And blue = 1 Then: GetHue = red * 256 / 6 + 256 / 6 * 4: Exit Function
    If red = 1 And green = 0 And blue <= 1 And blue >= 0 Then: GetHue = (1 - blue) * 256 / 6 + 256 / 6 * 5: Exit Function
err:
    GetHue = 0
End Function
Public Function GetLum(colour)
    On Error GoTo err:
    Dim red, green, blue
    red = (colour - ((Int((colour - (Int(colour / 256 ^ 2)) * 256 ^ 2) / 256)) * 256) - (Int(colour / 256 ^ 2)) * 256 ^ 2) / 256
    green = (Int((colour - (Int(colour / 256 ^ 2)) * 256 ^ 2) / 256)) / 256
    blue = (Int(colour / 256 ^ 2)) / 256
    If red = 0 Or green = 0 Or blue = 0 Then
        GetLum = Max(red, green, blue) * 128
    Else
        GetLum = 128 + (Min(red, green, blue) - (1 - Max(red, green, blue))) * 128
    End If
    Exit Function
err:
    GetLum = 0
End Function
Public Function GetRed(colour As Long) As Byte
    GetRed = (colour - ((Int((colour - (Int(colour / 256 ^ 2)) * 256 ^ 2) / 256)) * 256) - (Int(colour / 256 ^ 2)) * 256 ^ 2)
End Function
Public Function GetBlue(colour As Long) As Byte
    GetBlue = (Int(colour / 256 ^ 2))
End Function
Public Function GetGreen(colour As Long) As Byte
    GetGreen = (Int((colour - (Int(colour / 256 ^ 2)) * 256 ^ 2) / 256))
End Function
Public Function GetSat(colour)
    On Error GoTo err:
    Dim red, green, blue
    red = (colour - ((Int((colour - (Int(colour / 256 ^ 2)) * 256 ^ 2) / 256)) * 256) - (Int(colour / 256 ^ 2)) * 256 ^ 2) / 256
    green = (Int((colour - (Int(colour / 256 ^ 2)) * 256 ^ 2) / 256)) / 256
    blue = (Int(colour / 256 ^ 2)) / 256
    If GetLum(colour) <= 128 Then
        GetSat = (Max(red, green, blue) / (GetLum(colour) / 128) - 0.5) * 512
    Else
        GetSat = ((GetLum(colour) - 128 - 128 * Max(red, green, blue)) / (GetLum(colour) - 256) - 0.5) * 512
    End If
    Exit Function
err:
    GetSat = 0
End Function
Public Function StrMax(ParamArray cases()) As String
    Dim i%
    StrMax = cases(0)
    For i = 1 To UBound(cases)
        If UCase$(cases(i)) > UCase$(StrMax) Then StrMax = cases(i)
    Next i
End Function
Public Function StrMin(ParamArray cases()) As String
    Dim i%
    StrMin = cases(0)
    For i = 1 To UBound(cases)
        If UCase$(cases(i)) < UCase$(StrMin) Then StrMin = cases(i)
    Next i
End Function
Public Function Max(ParamArray cases()) As Double
    Dim i%
    Max = CDbl(cases(0))
    For i = 1 To UBound(cases)
        If CDbl(cases(i)) > Max Then Max = CDbl(cases(i))
    Next i
End Function
Public Function Min(ParamArray cases()) As Double
    Dim i%
    Min = CDbl(cases(0))
    For i = 1 To UBound(cases)
        If CDbl(cases(i)) < Min Then Min = CDbl(cases(i))
    Next i
End Function
Public Function Fulltrim(str$)
    Dim count As Integer
    count = InStr(str$, " ")
    Do While count > 0
        str$ = Left$(str$, count - 1) & Mid$(str$, count + 1)
        count = InStr(count, str$, " ")
    Loop
    count = InStr(str$, vbCr)
    Do While count > 0
        str$ = Left$(str$, count - 1) & Mid$(str$, count + 1)
        count = InStr(count, str$, vbCr)
    Loop
    count = InStr(str$, vbLf)
    Do While count > 0
        str$ = Left$(str$, count - 1) & Mid$(str$, count + 1)
        count = InStr(count, str$, vbLf)
    Loop
    count = InStr(str$, vbTab)
    Do While count > 0
        str$ = Left$(str$, count - 1) & Mid$(str$, count + 1)
        count = InStr(count, str$, vbTab)
    Loop
    Fulltrim = str$
End Function
Public Function SpaceInStr(str$)
    Dim a%, b%, c%, d%, e%, f%, g%
    a = InStr(str$, " ")
    If a < SpaceInStr Then SpaceInStr = a
    SpaceInStr = InStr(str$, vbBack)
    If b < SpaceInStr Then SpaceInStr = b
    SpaceInStr = InStr(str$, vbCr)
    If c < SpaceInStr Then SpaceInStr = c
    SpaceInStr = InStr(str$, vbTab)
    If d < SpaceInStr Then SpaceInStr = d
    SpaceInStr = InStr(str$, vbLf)
    If e < SpaceInStr Then SpaceInStr = e
    SpaceInStr = InStr(str$, vbVerticalTab)
    If f < SpaceInStr Then SpaceInStr = f
    SpaceInStr = InStr(str$, vbFormFeed)
    If g < SpaceInStr Then SpaceInStr = g
End Function
Public Function Getbin(v As Double)
    Dim i, i2
    For i = 0 To 50
        If 2 ^ i - 1 >= v Then Exit For
    Next i
'    Debug.Print i & " bit..."
    For i2 = i - 1 To 0 Step -1
        If v >= 2 ^ i2 Then
            Getbin = Getbin & "1"
            v = v - 2 ^ i2
'            Debug.Print 2 ^ i2;
        Else
            Getbin = Getbin & "0"
        End If
    Next i2
'    Debug.Print
End Function
Public Function ExecFile$(filename$)
    On Error GoTo err:
    Dim theline$
    If filename$ = "" Or filename$ = Null Then ExecFile$ = "": Exit Function
    Open filename$ For Input As 1
        Do While Not EOF(1) ' Loop until end of file.
            Input #1, theline$
            ExecFile$ = ExecFile$ & theline$ & vbCr & vbLf
        Loop
    Close 1
    Exit Function
err:
End Function
Public Function VarVal(str$) As Single
    Dim var1$, var2$, a%, b%, count%
    If InStr(str$, "(") > 0 And InStr(str$, ")") > 0 Then
        count = 0
        For a = InStr(str, "(") To Len(str)
            If Mid$(str, a, 1) = "(" Then count = count + 1
            If Mid$(str, a, 1) = ")" Then count = count - 1
            If count = 0 Then b = a: Exit For
        Next a
        a = InStr(str, "(")
        var1 = Left$(str, a - 1)
        var2 = Mid$(str, b + 1)
        str = Mid$(str, a + 1, b - (a + 1))
        str = CStr(VarVal(VarStr(str)))
        VarVal = VarVal(var1 & str & var2)
    ElseIf InStr(str$, "+") > 0 Then
        var1$ = Left$(str$, InStr(str$, "+") - 1)
        var2$ = Mid$(str$, InStr(str$, "+") + 1)
        VarVal = VarVal(var1$) + VarVal(var2$)
    ElseIf InStr(str$, "*") > 0 Then
        var1$ = Left$(str$, InStr(str$, "*") - 1)
        var2$ = Mid$(str$, InStr(str$, "*") + 1)
        VarVal = VarVal(var1$) * VarVal(var2$)
    ElseIf InStr(str$, "/") > 0 Then
        var1$ = Left$(str$, InStr(str$, "/") - 1)
        var2$ = Mid$(str$, InStr(str$, "/") + 1)
        VarVal = VarVal(var1$) / VarVal(var2$)
    ElseIf InStr(str$, "^") > 0 Then
        var1$ = Left$(str$, InStr(str$, "^") - 1)
        var2$ = Mid$(str$, InStr(str$, "^") + 1)
        VarVal = VarVal(var1$) ^ VarVal(var2$)
    Else
        VarVal = Val(str$)
    End If
End Function
Public Function VarStr(str$) As String
    Dim var1$, var2$, a%, b%, count%, func$
    If InStr(str, "[") > 0 And InStr(str, "]") > 0 Then
        For a = InStr(str, "[") To Len(str)
            If Mid$(str, a, 1) = "[" Then count = count + 1
            If Mid$(str, a, 1) = "]" Then count = count - 1
            If count = 0 Then b = a: Exit For
        Next a
        a = InStr(str, "[")
        func = Mid$(str, a - 3, 3)
        var1 = Left$(str, a - 4)
        var2 = Mid$(str, b + 1)
        str = Mid$(str, a + 1, b - (a + 1))
        Select Case UCase$(func)
        Case "RND"
            str = CStr(Rnd(1) * VarVal(VarStr(str)))
        Case "NUM"
            str = CStr(VarVal(VarStr(str)))
        Case "INT"
            str = CStr(Int(VarVal(VarStr(str))))
        Case "ABS"
            str = CStr(Abs(VarVal(VarStr(str))))
        Case "SRT"
            str = CStr((VarVal(VarStr(str))) ^ 0.5)
        Case "SIN"
            str = CStr(Sin(VarVal(VarStr(str)) / Rad2Deg))
        Case "COS"
            str = CStr(Cos(VarVal(VarStr(str)) / Rad2Deg))
        Case "TAN"
            str = CStr(Tan(VarVal(VarStr(str)) / Rad2Deg))
        End Select
        VarStr = VarStr(var1 & str & var2)
    Else
        VarStr = str
    End If
    
End Function
Public Function FACT(num%) As Long
    Dim i%
    If num >= 0 Then
        FACT = 1
        For i = 1 To num
            FACT = FACT * i
        Next i
    End If
End Function
Public Function Round(place%, num As Double) As Double
    Round = Int(num * 10 ^ place + 0.5) / 10 ^ place
End Function