Is there a menu function?

[ahenry3068]

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.

Thanks I'll look at this.    I kept working in the mean time and I'm here: 

Code: (Select All)

Type BUTTONTYPE

    Height As Integer

    Width As Integer

    X As Integer

    Y As Integer

    Image As Long

    OldImage As Long

    CREATED As Integer

    ONSCREEN As Integer

End Type







Dim B(0 To 2) As BUTTONTYPE



Screen _NewImage(800, 600, 256)





MAKEBUTTON_LABELBTN 16, B(0), 8, "BUTTON 0"

MAKEBUTTON_LABELBTN 16, B(1), 8, "BUTTON 1"

MAKEBUTTON_LABELBTN 16, B(2), 8, "BUTTON 2"



BUTTONPUT_XY B(0), 10, 10

BUTTONPUT_XY B(1), 120, 120

BUTTONPUT_XY B(2), 310, 250



End



























Sub BUTTONPUT_XY (BTarget As BUTTONTYPE, X As Integer, Y As Integer)

    BTarget.X = X

    BTarget.Y = Y

    _PutImage (X, Y), BTarget.Image

    BTarget.ONSCREEN = _TRUE

End Sub





Sub MAKEBUTTON_LABELBTN (bFont As Long, NEWBUTTON As BUTTONTYPE, BorderWidth As Integer, Label As String)

    Dim CImage As Long

    Dim SaveHandle As Long

    Dim SavePMode As Integer

    Dim C As Integer

    Dim X As Integer

    Dim I As Integer

    Dim TWidth As Integer

    Dim THeight As Integer



    SaveHandle = _Font



    _Font bFont

    NEWBUTTON.Height = _FontHeight(bFont) + 8 + (BorderWidth * 2)

    NEWBUTTON.Width = _PrintWidth(Label) + 12 + (BorderWidth * 2)

    _Font SaveHandle

    SaveHandle = _Dest



    NEWBUTTON.Image = _NewImage(NEWBUTTON.Width, NEWBUTTON.Height, 256)

    NEWBUTTON.OldImage = _NewImage(NEWBUTTON.Width, NEWBUTTON.Height, 256)

    C = 0

    For I = 16 To 31

        Print I, C

        _PaletteColor I, _RGB32(C, C, C, 255), NEWBUTTON.Image

        C = C + 16

    Next



    _Dest NEWBUTTON.Image

    TWidth = NEWBUTTON.Width

    THeight = NEWBUTTON.Height

    X = 0

    Y = 0

    I = 1

    If BorderWidth > 0 Then

        C = &H11

        Do

            Line (X, Y)-(X + (TWidth - 1), Y + (THeight - 1)), C, BF

            C = C + 1

            I = I + 1

            TWidth = TWidth - 2

            THeight = THeight - 2

            X = X + 1

            Y = Y + 1

        Loop Until I = BorderWidth

    Else

        C = &H15

        Line (X, Y)-(X + (TWidth - 1), Y + (THeight - 1)), C, BF

    End If

    Color 15

    _Font bFont, NEWBUTTON.Image

    _PrintMode _KeepBackground , NEWBUTTON.Image

    _PrintString (0 + BorderWidth + 6, 0 + BorderWidth + 4), Label, NEWBUTTON.Image

    _Dest SaveHandle

End Sub