Is there a menu function?

[bplus]

Code: (Select All)

Sub drwBtn (x, y, s$) '200 x 50
    Dim fc~&, bc~&
    Line (x, y)-Step(200, 50), _RGB32(0, 0, 0), BF
    Line (x, y)-Step(197, 47), _RGB32(255, 255, 255), BF
    Line (x + 1, y + 1)-Step(197, 47), &HFFBABABA, BF
    fc~& = _DefaultColor: bc~& = _BackgroundColor ' save color before we chnge
    Color _RGB32(0, 0, 0), &HFFBABABA
    _PrintString (x + 100 - 4 * Len(s$), y + 17), s$
    Color fc~&, bc~& ' restore color

    ''this works pretty good for a menu of buttons to get menu number
    'Function getButtonNumberChoice% (choice$())
    '    'this sub uses drwBtn
    '    ub = UBound(choice$)
    '    lb = LBound(choice$)
    '    For b = lb To ub '   drawing a column of buttons at _width - 210 starting at y = 10
    '        drwBtn _Width - 210, b * 60 + 10, choice$(b)
    '    Next
    '    Do
    '        While _MouseInput: Wend
    '        mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
    '        If mb Then
    '            _Delay .25 ' delay before exit to give user time to release mouse button
    '            If mx > _Width - 210 And mx <= _Width - 10 Then
    '                For b = lb To ub
    '                    If my >= b * 60 + 10 And my <= b * 60 + 60 Then
    '                        getButtonNumberChoice% = b: Exit Function
    '                    End If
    '                Next
    '                Beep
    '            Else
    '                Beep
    '            End If
    '        End If
    '        _Limit 60
    '    Loop
    'End Function

End Sub

I have a demo I will try and find.

Update:

Code: (Select All)

Option _Explicit
_Title "Get Button Menu" 'bplus 2021-03-11
' B+ 2021-03-11 Rewrite 191Brian list picker  https://www.qb64.org/forum/index.php?topic=3730.msg130862#msg130862
' assuming default font 8x16

'Globals here, Cap first letters
Type Button
    As Long x, y, w, h
    text As String
    As _Unsigned Long FC, BC
End Type

Screen _NewImage(800, 620, 32)
_Delay .25 'give screen time to load before
_ScreenMove _Middle

'locals for main event code, keep locals lowercase on first letter
ReDim As Long i, nMonths, nDays, nYears, mx, my, mb
ReDim monthNames$, monthPick$, years$, yearPick$, days$, dayPick$
ReDim months$(1 To 1) '<<<<<<<<<<<< don't need to know in advance the number of items in split sting  but good to start at 1
ReDim monthButtons(1 To 1) As Button
ReDim yearButtons(1 To 1) As Button
ReDim dayButtons(1 To 1) As Button
For i = 1 To 31 'create days and years strings
    If i = 1 Then years$ = TS$(2000 + i) Else years$ = years$ + "," + TS$(2000 + i)
    If i = 1 Then days$ = TS$(i) Else days$ = days$ + "," + TS$(i)
Next
monthNames$ = "January,February,March,April,May,June,July,August,September,October,November,December"
MakeButtons &HFFFF8888, &HFF880000, 300, 0, years$, yearButtons()
MakeButtons &HFF88FF88, &HFF008800, 369, (_Height - 12 * 25) / 2, monthNames$, monthButtons()
MakeButtons &HFF8888FF, &HFF0000FF, 478, 0, days$, dayButtons()
nYears = UBound(yearButtons)
nMonths = UBound(monthButtons)
nDays = UBound(dayButtons)

''check the making all good!
'For i = 1 To nMonths
'    Print MonthButtons(i).x, MonthButtons(i).y, MonthButtons(i).w, MonthButtons(i).h, MonthButtons(i).text
'Next
'End

Do
    Cls
    Print "Last Date Picked: " + yearPick$ + "-" + monthPick$ + "-" + dayPick$
    For i = 1 To nYears
        DrawButton yearButtons(i)
    Next
    For i = 1 To nMonths
        DrawButton monthButtons(i)
    Next
    For i = 1 To nDays
        DrawButton dayButtons(i)
    Next

    While _MouseInput: Wend ' might want mouse for other things besides checking a button click
    mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
    If mb Then
        For i = 1 To nYears
            If InBoxTF&(mx, my, yearButtons(i)) Then yearPick$ = yearButtons(i).text: GoTo continue
        Next
        For i = 1 To nMonths
            If InBoxTF&(mx, my, monthButtons(i)) Then monthPick$ = monthButtons(i).text: GoTo continue
        Next
        For i = 1 To nDays
            If InBoxTF&(mx, my, dayButtons(i)) Then dayPick$ = dayButtons(i).text: GoTo continue
        Next
    End If

    continue:
    _Display
    _Limit 60
Loop Until _KeyDown(27)

Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
    Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
    curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
    dpos = InStr(curpos, SplitMeString, delim)
    Do Until dpos = 0
        loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
        arrpos = arrpos + 1
        If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
        curpos = dpos + LD
        dpos = InStr(curpos, SplitMeString, delim)
    Loop
    loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
    ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
End Sub

Function InBoxTF& (x, y, b As Button)
    If x >= b.x And x <= b.x + b.w Then
        If y >= b.y And y <= b.y + b.h Then InBoxTF& = -1
    End If
End Function

Sub DrawButton (b As Button)
    ReDim As _Unsigned Long FC, BC
    Line (b.x, b.y)-Step(b.w, b.h), b.BC, BF
    Line (b.x, b.y)-Step(b.w, b.h), b.FC, B
    FC = _DefaultColor: BC = _BackgroundColor
    Color b.FC, b.BC
    _PrintString ((b.x + (b.w - 8 * Len(b.text)) / 2), b.y + (b.h - 16) / 2), b.text
    Color FC, BC
End Sub

Sub MakeButtons (fore As _Unsigned Long, back As _Unsigned Long, X As Long, Y As Long, CommaDelimitedList$, arr() As Button)
    ReDim As Long items, i, lngItem
    ReDim list$(1 To 1)
    Split CommaDelimitedList$, ",", list$()
    items = UBound(list$)

    'what's longest item?
    For i = 1 To items
        If Len(list$(i)) > lngItem Then lngItem = Len(list$(i))
    Next
    ReDim arr(1 To items) As Button ' make month buttons
    For i = 1 To items
        arr(i).x = X
        arr(i).y = Y + 20 * (i - 1)
        arr(i).w = 8 * (lngItem + 4)
        arr(i).h = 18 'assuming default font
        arr(i).text = list$(i)
        arr(i).FC = fore
        arr(i).BC = back
    Next
End Sub

Function TS$ (n As Long)
    TS$ = _Trim$(Str$(n))
End Function

NOT the one I was remembering but this is interesting.

Oh here is the code I was thinking of, it is a demo of the routine in first code window above. I started getting fancy with 2nd code window.

Code: (Select All)

_Title "Quick Menu" ' b+ 2024-12-20
Screen _NewImage(800, 600, 32): _ScreenMove 250, 60
Dim menu$(1 To 4)
menu$(1) = "Help": menu$(2) = "Save": menu$(3) = "Laugh at Pete's joke": menu$(4) = "Quit"
Cls , &HFF000088: _PrintMode _KeepBackground
Do
    sel = getButtonNumberChoice%(menu$())
    Print "You picked: "; menu$(sel)
Loop Until sel = 4

Sub drwBtn (x, y, s$) '200 x 50
    Dim fc~&, bc~&
    Line (x, y)-Step(200, 50), _RGB32(0, 0, 0), BF
    Line (x, y)-Step(197, 47), _RGB32(255, 255, 255), BF
    Line (x + 1, y + 1)-Step(197, 47), &HFFBABABA, BF
    fc~& = _DefaultColor: bc~& = _BackgroundColor ' save color before we chnge
    Color _RGB32(0, 0, 0), &HFFBABABA
    _PrintString (x + 100 - 4 * Len(s$), y + 17), s$
    Color fc~&, bc~& ' restore color
End Sub

'this works pretty good for a menu of buttons to get menu number
Function getButtonNumberChoice% (choice$()) 'this sub uses drwBtn
    ub = UBound(choice$): lb = LBound(choice$)
    For b = lb To ub '   drawing a column of buttons at _width - 210 starting at y = 10
        drwBtn _Width - 210, b * 60 + 10, choice$(b)
    Next
    Do
        While _MouseInput: Wend
        mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
        If mb Then
            _Delay .25 ' delay before exit to give user time to release mouse button
            If mx > _Width - 210 And mx <= _Width - 10 Then
                For b = lb To ub
                    If my >= b * 60 + 10 And my <= b * 60 + 60 Then
                        getButtonNumberChoice% = b: Exit Function
                    End If
                Next
                Beep
            Else
                Beep
            End If
        End If
        _Limit 60
    Loop
End Function