Quote:Also remember to put on the quirk that Dimster desires... the pulldown animation. 

Option _Explicit '                                            no typos for variables if you please

_Title "Drop Menu more 2 function test" '                                            b+ 2023-06-27

'                                                                      Instigated by Dimster here:

'                         https://qb64phoenix.com/forum/showthread.php?tid=1693&pid=17117#pid17117

'    More! = 1. Highlite mouse overs  2. Handle extra long menu descriptions up to .5 screen width

'               So sorry Ultraman, no tool tips but extra long descriptions is better than nutt'n.



Const ButtonW = 100, ButtonH = 20 '                   basic rectangle size for title of menu panel

Type BoxType '                                             to be used for MouseZone click checking

    As String Label '                                                                   menu title

    As Long LeftX, TopY, BoxW, BoxH '                  left most, top most , box width, box height

End Type



Dim Shared As Integer NBoxes '                                           setting up a demo in main

NBoxes = 72 '                                                     exorbinant amount of menu titles

Dim Shared Boxes(1 To NBoxes) As BoxType '                     data array for positions and labels

Dim As Integer i, x, y, mz, nItems, choice '         index, positions, menu count, choice selected

ReDim menu$(1 To 1) '                                     dynamic array to store quick menu's into

Dim s$ '                                                                         a string variable



Screen _NewImage(800, 600, 32) '                                                      screen stuff

_ScreenMove 250, 50 '   somewhere in middle of my laptop, you may prefer to change for your screen

_PrintMode _KeepBackground '                               preserve background when printing stuff

Cls '                                           so we have solid black background for image saving



x = 0: y = 0 '                         set up boxes                   x, y for top left box corner

For i = 1 To NBoxes

    Boxes(i).Label = "Box" + Str$(i) '                                            quick menu title

    Boxes(i).LeftX = x: Boxes(i).TopY = y '                                        top left corner

    Boxes(i).BoxW = ButtonW '                                        width to constant set for all

    Boxes(i).BoxH = ButtonH '                                       height to constant set for all

    If (x + 2 * ButtonW) > _Width Then '           spread out the menu titles left right, top down

        x = 0: y = y + ButtonH '                     next title didn't fit across so start new row

    Else

        x = x + ButtonW '                                                        fits going across

    End If

    DrawTitleBox i '                                                     draw the menu title panel

Next



Do

    mz = MouseZone% '                          reports which menu panel has been clicked and mouse

    If mz Then '                              quick make up a list of items for the menu title box

        nItems = Int(Rnd * 10) + 1 '                                 pick random 1 to 10 inclusive

        ReDim menu$(1 To nItems) '                                          resize menu$ by nItems

        For i = 1 To nItems '                                          menu option and description

            s$ = "Box" + Str$(mz) + " Menu Item:" + Str$(i) '               still needs to be less

            s$ = s$ + " with extra, extra, long description." '               than .5 screen width

            menu$(i) = s$ '                         item is described with fairly good width to it

        Next '                                                      his was alternate to tool tips

        choice = getButtonNumberChoice%(Boxes(mz).LeftX, Boxes(mz).TopY, menu$())

        If choice = 0 Then s$ = "You quit menu by clicking outside of it." Else s$ = menu$(choice)

        _MessageBox "Drop Menu Test", "Your Menu Choice was: " + s$, "info"

    End If

    _Limit 30

Loop Until _KeyDown(27)



Sub DrawTitleBox (i) '                 draw a box according to shared Boxes array then print label

    Line (Boxes(i).LeftX + 1, Boxes(i).TopY + 1)-Step(ButtonW - 2, ButtonH - 2), &HFF550088, BF

    Color &HFFFFFFFF

    _PrintString (Boxes(i).LeftX + (ButtonW - _PrintWidth(Boxes(i).Label)) / 2, _

    Boxes(i).TopY + ButtonH / 2 - 8), Boxes(i).Label

End Sub



Sub DrawChoiceBox (highliteTF%, leftX, topY, BoxW As Integer, S$) ' draw menu items for menu title

    If highliteTF% Then '                                reverse colors as mouse is over this item

        Line (leftX, topY)-Step(BoxW, ButtonH), &HFFAAAAAA, BF

        Color &HFF333333

        _PrintString (leftX + (BoxW - _PrintWidth(S$)) / 2, topY + ButtonH / 2 - 8), S$

    Else

        Line (leftX, topY)-Step(BoxW, ButtonH), &HFF333333, BF

        Color &HFFAAAAAA

        _PrintString (leftX + (BoxW - _PrintWidth(S$)) / 2, topY + ButtonH / 2 - 8), S$

    End If

    Line (leftX, topY)-Step(BoxW, ButtonH), &HFF000000, B '             draw black box around item

End Sub



Function MouseZone% '                   returns the Shared Boxes() index clicked or 0 none clicked

    '                      Set the following up in your Main code of app

    'Type BoxType '                                         to be used for mouse click checking

    '   As Long LeftX, TopY, BoxW, BoxH '            left most, top most, box width, box height

    'End Type

    'Dim Shared As Integer NBoxes

    'Dim Shared Boxes(1 To NBoxes) As BoxType



    Dim As Integer i, mb, mx, my



    While _MouseInput: Wend '                                                           poll mouse

    mb = _MouseButton(1) '                                                  looking for left click

    If mb Then

        _Delay .25

        mx = _MouseX: my = _MouseY '                                        get the mouse position

        For i = 1 To NBoxes '        see if its in a menu tile box from data in Shared Boxes array

            If mx > Boxes(i).LeftX And mx < Boxes(i).LeftX + Boxes(i).BoxW Then

                If my > Boxes(i).TopY And my < Boxes(i).TopY + Boxes(i).BoxH Then

                    MouseZone% = i: Exit Function '                  yes a click in this box index

                End If

            End If

        Next

    End If

End Function



Function getButtonNumberChoice% (BoxX As Integer, BoxY As Integer, choice$())

    '           This fucion uses Sub DrawChoiceBox (highliteTF%, leftX, topY, BoxW As Integer, S$)

    '                                     BoxX, BoxY are top left corner from the Menu Title Panel

    '                                           We will be drawing our Menu Items below that panel

    Dim As Integer ub, lb, b '          choice$() boundaries and an index, b, to run through items

    Dim As Integer longest '                             find the longest string length in choices

    Dim As Integer menuW, menuX '  use menuWidth and menuX start box side so long menu strings fit

    Dim As Integer mx, my, mb '                           mouse status of position and left button

    Dim As Long save '       we are saving the whole screen before drop down to redraw after click

    Dim As Long drawerDown '           save drawer down after animate dropping drawers for Dimster



    ub = UBound(choice$): lb = LBound(choice$) '                                  array boundaries

    For b = lb To ub '                                               find longest string in choice

        If Len(choice$(b)) > longest Then longest = Len(choice$(b))

    Next

    If (longest + 2) * 8 > ButtonW Then '           don't use default button Width string too long

        menuW = (longest + 2) * 8 '             calculate the needed width, up to half screen fits

        If BoxX < _Width / 2 - 3 Then '          -3 ?? wouldn't work right until took 3 off middle

            menuX = BoxX '                                  use the same left side of box to start

        Else

            menuX = BoxX + ButtonW - menuW '   right side box align minus menu width = x start box

        End If

    Else

        menuW = ButtonW '                 use default sizes that fit nicely under menu title panel

        menuX = BoxX

    End If

    save = _NewImage(_Width, _Height, 32) '         save our beautiful screen before dropping menu

    _PutImage , 0, save



    '                                                         Animate dropping drawers for Dimster

    For b = lb To ub ' clear any previous highlites

        DrawChoiceBox 0, menuX, BoxY + b * ButtonH, menuW, choice$(b)

        _Display

        _Limit 5

    Next

    drawerDown = _NewImage(_Width, _Height, 32) '    save our beautiful screen after dropping menu

    _PutImage , 0, drawerDown



    Do '                                                                until a mouse click occurs

        _PutImage , drawerDown, 0 '             actually this is better to clear screen with image

        While _MouseInput: Wend '                                                       poll mouse

        mx = _MouseX: my = _MouseY: mb = _MouseButton(1)

        For b = lb To ub '                scan through the box dimension to see if mouse is in one

            If mx > menuX And mx <= menuX + menuW Then

                If my >= BoxY + b * ButtonH And my <= BoxY + b * ButtonH + ButtonH Then

                    If mb Then '                                                  item is clicked!

                        _PutImage , save, 0 '                             put image of screen back

                        _FreeImage save '                 throw out screen image so no memory leak

                        _FreeImage drawerDown

                        '              delay before exit to give user time to release mouse button

                        '                               set function, restore autodisplay and exit

                        getButtonNumberChoice% = b: _Delay .25: _AutoDisplay: Exit Function

                    Else

                        '           indicate mouse over this menu item! draw highlight in box = -1

                        DrawChoiceBox -1, menuX, BoxY + b * ButtonH, menuW, choice$(b)

                        _Display

                    End If

                End If

            End If

        Next

        If mb Then '                                   there was a click outside the menu = cancel

            _PutImage , save, 0 '                           put image before dropdown draw back up

            _FreeImage save '                            leaving sub avoid memory leak, dump image

            _FreeImage drawerDown

            '                          delay before exit to give user time to release mouse button

            '                                           set function, restore autodisplay and exit

            getButtonNumberChoice% = 0: _Delay .25: _AutoDisplay: Exit Function

        End If

        _Display '     display was needed here to avoid blinking when redrawing the highlited item

        '_Limit 60

    Loop '                                                              until a mouse click occurs

End Function

(06-04-2024, 01:17 AM)bplus Wrote:

Drawing Numbers without Repetition

Code: (Select All)

_Title "Drawing numbers without repetitions" 'b+ 2024-06-03

DefLng A-Z ' all variables are long
Randomize Timer

highest = 50 ' draw numbers from 1 to 50
drawNumber = 10 ' how many numbers to draw

restart:
ReDim deckOfNumbers(1 To highest) ' long also

' load the deck with numbers
For i = 1 To highest
    deckOfNumbers(i) = i ' so the deck so far is very orderly
Next

' here is Fisher - Yates shuffle routine the most efficient known to mathematicians
For i = highest To 2 Step -1
    Swap deckOfNumbers(i), deckOfNumbers(Int(Rnd * i) + 1) ' swap i with 1 to i
Next

'      now the deck is shuffled !!! check it out
For i = 1 To drawNumber
    Print deckOfNumbers(i);
Next
Print

' now maybe we want to list numbers in order
ReDim order(1 To highest)
For i = 1 To drawNumber
    order(deckOfNumbers(i)) = 1 ' mark the numbers in order
Next
For i = 1 To highest
    If order(i) Then Print i;
Next
Print
Print "... that should show:"; drawNumber; "numbers between 1 and"; highest; ", in order, no repeats."
Print: Print
Input " Please enter Highest number "; highest
Input "    Please enter Draw number "; drawNumber
If highest <> 0 And drawNumber < highest Then GoTo restart

 

REM My Greek Letters

SCREEN _NEWIMAGE(800, 600, 32) ' Create new screen



' Load a font that supports Greek characters

fontfile$ = "C:\windows\fonts\lucon.ttf"

f& = _LOADFONT(fontfile$, 20, "MONOSPACE")

_FONT f&



PRINT "Αν δεν θες να περιμένεις πάτα ένα πλήκτρο"

PRINT "If you don't want to wait pushing a button."

sleep 10



GreekChange



PRINT "Αν δεν θες να περιμένεις πάτα ένα πλήκτρο"

PRINT "If you don't want to wait pushing a button."



sleep 10

EnglChange



PRINT "Αν δεν θες να περιμένεις πάτα ένα πλήκτρο"

PRINT "If you don't want to wait pushing a button."



sleep 10

EXODOS:

SYSTEM



SUB GreekChange

    RESTORE GreekUnicodeMap

    FOR ASCIIcode = 128 TO 255

        READ unicode

        _MAPUNICODE unicode TO ASCIIcode

    NEXT



    GreekUnicodeMap:

    'Microsoft_windows_cp1253

    DATA 8364,0,8218,402,8222,8230,8224,8225,0,8240,0,8249,0,0,0,0

    DATA 0,8216,8217,8220,8221,8226,8211,8212,0,8482,0,8250,0,0,0,0

    DATA 160,901,902,163,164,165,166,167,168,169,0,171,172,173,174,8213

    DATA 176,177,178,179,900,181,182,183,904,905,906,187,908,189,910,911

    DATA 912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927

    DATA 928,929,0,931,932,933,934,935,936,937,938,939,940,941,942,943

    DATA 944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959

    DATA 960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,0



END SUB

SUB EnglChange



    RESTORE EnglUnicodeMap

    FOR ASCIIcode = 128 TO 255

        READ unicode

        _MAPUNICODE unicode TO ASCIIcode

    NEXT



    EnglUnicodeMap:

    'Microsoft_pc_cp437

    DATA 199,252,233,226,228,224,229,231,234,235,232,239,238,236,196,197

    DATA 201,230,198,244,246,242,251,249,255,214,220,162,163,165,8359,402

    DATA 225,237,243,250,241,209,170,186,191,8976,172,189,188,161,171,187

    DATA 9617,9618,9619,9474,9508,9569,9570,9558,9557,9571,9553,9559,9565,9564,9563,9488

    DATA 9492,9524,9516,9500,9472,9532,9566,9567,9562,9556,9577,9574,9568,9552,9580,9575

    DATA 9576,9572,9573,9561,9560,9554,9555,9579,9578,9496,9484,9608,9604,9612,9616,9600

    DATA 945,223,915,960,931,963,181,964,934,920,937,948,8734,966,949,8745

    DATA 8801,177,8805,8804,8992,8993,247,8776,176,8729,183,8730,8319,178,9632,160



END SUB