Posts: 4,023
Threads: 181
Joined: Apr 2022
Reputation:
227
Yesterday, 04:29 AM
(This post was last modified: Yesterday, 04:41 AM by bplus.)
From Prolific Programmers >> bplus >> b+ Beginners Corner page 6 reply #51
Code: (Select All)
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...7#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
b = b + ...
Posts: 2,266
Threads: 232
Joined: Apr 2022
Reputation:
114
Yesterday, 06:45 PM
(This post was last modified: Yesterday, 06:46 PM by Pete.)
@bplus
I like unwrapping presents Christmas morning!
Nice effects, even though it's not SCREEN 0.
Want to bullet proof it? What I mean is, as coded, it fails if you pick a box like 46 but hold the left mouse button down for a few seconds. It will issue a message you clicked outside the box because it thinks you are clicking still on box 46. When you click OK, all subsequent clicks will be met with repeated looping outside the box error messages.
Check out the slight mouse revisions (see ----) dashes and the (2) remarked 'REMOVE' statements needed to fix the mouse held down issue.
Triggers on left mouse button depressed. Change mb value to = 2 for trigger on left mouse click released.
Code: (Select All)
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...7#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
'------------------------
Do '<------
If mb > 0 Then
If mb = 1 Then
mb = -1
Else
mb = 0: Exit Do ' Mouse button cycle completed.
End If
End If
'------------------------
While _MouseInput: Wend ' poll mouse
' REMOVE mb = _MouseButton(1) ' looking for left click
'------------------------
If mb = -1 And _MouseButton(1) = 0 Then
mb = 2
End If
If _MouseButton(1) Then
If mb = 0 Then
mb = 1
End If
End If
If mb = 1 Then
'------------------------
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 ' REMOVE Exit Function ' yes a click in this box index
End If
End If
Next
End If
Loop '<------
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
Pete
Posts: 4,023
Threads: 181
Joined: Apr 2022
Reputation:
227
+1 @Pete
Wow! I never saw that happen before! If you click that like a normal person it worked fine BUT if for some reason you are extra slow on the release (and I guess we do get that way eventually) that becomes an app from HELL! After a long click the first message is correct BUT it just thinks you selected and clicked and selected and clicked over and over again, yikes!
So all that was changed was the MouseZone% Routine, you have to add a loop to that? I have to study that change, seems like there would be something simpler to fix that.
Thankyou for alerting me to this and providing a solution.
b = b + ...
Posts: 2,266
Threads: 232
Joined: Apr 2022
Reputation:
114
@TempoidBasic
@bplus
@SMcNeill
My friend ftom Italy made a graphics demo of what is known in HTML circles as a 'suckerfish' menu. I have used this in SCREEN 0 for 2 apps I created. Now reinventing that wheel in this 'libray to be' app.
Pete's SCREEN 0 Menus with suckerfish menus in the works. (Open 'File" menu and click on "Export" for example).
Code: (Select All)
Dim Shared MenuBdrFg, MenubrdBg, MenuSdwFg, MenuSdwBg, MenuFg, MenuBg, MenuHlFg, MenuHlBg, pop
ReDim MapHeading$(1), a$(1): curstyle = 1
pop = 1
setup
Color 1, 7
a$ = " File Edit View Search": Locate 1, 1
map_heading a$, MapHeading$(), 0
Color 7, 1
a$ = "[F1] Help [Esc] Quit": Locate _Height, 1
map_heading a$, MapHeading$(), 1
menu_main MapHeading$(), curstyle
End
erhandler_data:
Cls
Print "Sucker ="; sucker: Print
Print "Error: " + LTrim$(Str$(Err)) + " at line " + LTrim$(Str$(Erl)) + ". Incorrectly aligned data statements is the most likely cause."
End
Sub User (selection, sucker)
If sucker > 0 Then
Select Case sucker
Case 1: Restore suckerfish1
End Select
Else
Select Case selection
Case 1: Restore data1
Case 2: Restore data2
Case 3: Restore data4
Case 4: Restore data4
End Select
End If
color_palette_data:
' MenuBdrFg, MenubrdBg, MenuSdwFg, MenuSdwBg, MenuFg, MenuBg, MenuHlFg, MenuHlBg
Data 1,-1,2,-1,3,-1,4,-1,5,-1,6,63,7,-1,8,-1,9,-1,10,-1,11,-1,12,-1,13,-1,14,-1,15,-1
Data 1,6,8,1,0,6,15,1
Data eof
data1:
Data New,N,0,Open,O,0,Save,S,0,,Export,E,1,,Exit,x,0
Data eof
data2:
Data Undo,U,0,Redo,R,0,Cut,0,0,Copy,0,0,Paste,0,0,Select All,0,0
Data eof
data3:
Data Subs...,S,0,Line Numbers,L,0,Compiler Warnings,C,0
Data eof
data4:
Data Find,F,0,Repeat Last Find,R,0,Change,F,0,Clear Search History,C,0,Quick Navigation,Q,0,Go To Line,G,0
Data eof
suckerfish1:
Data Hypertext,H,Rich Text,R,Code Block,C
Data eof
help_data:
Data This demo includes this
Data handy dandy help window
Data where we simply add data
Data statements to produce
Data then help text displayed
Data in this pop-up window.
Data eof
End Sub
Sub setup
Restore color_palette_data
For i = 1 To 15
Read j, k
If k <> -1 Then Palette j, k
Next
For i = 1 To 8
Read j
Select Case i
Case 1: MenuBdrFg = j
Case 2: MenubrdBg = j
Case 3: MenuSdwFg = j
Case 4: MenuSdwBg = j
Case 5: MenuFg = j
Case 6: MenuBg = j
Case 7: MenuHlFg = j
Case 8: MenuHlBg = j
End Select
Next
bgc1 = 9: bgc2 = 1 ' Background appearance.
Color MenuHlFg, MenuHlBg
Cls
Color 14
Locate 2, 1: Print String$(80, 196);
Locate _Height - 1, 1: Print String$(80, 196);
Color bgc1, bgc2
For i = 3 To _Height - 2
Locate i, 1: Print String$(80, 176);
Next
End Sub
Sub menu_main (MapHeading$(), curstyle)
Do
_Limit 30
MyMouse_and_Keyboard lb, mb, rb, my, mx, mw, shift%, clkcnt, drag, b$
menu_selection selection, curstyle, my, mx, lb, mb, mw, b$, MapHeading$(), a$()
Loop
End Sub
Sub map_heading (MapHeading$, MapHeading$(), centering)
y = CsrLin: Locate y, 1: Print Space$(_Width);
Select Case centering
Case 0: Locate y, 1
Case Else: Locate y, _Width \ 2 - Len(MapHeading$) \ 2 + 1
End Select
Print MapHeading$;
f$ = "": Locate y, 1
For i = 1 To _Width
f$ = f$ + Chr$(Screen(y, i))
Next
temp$ = " ": j = 0
If InStr(f$, "[") Then ' Bracket format.
For i = 1 To Len(f$) ' Map mouse hot zones.
x$ = Mid$(f$, i, 1)
If hot Then
If Left$(LTrim$(Mid$(f$, i) + "["), 1) = "[" Then
hot = 1 - hot: temp$ = " "
End If
End If
If x$ <> Chr$(32) And hot = 0 Then
hot = 1 - hot: j = j + 1: temp$ = Chr$(96 + j)
End If
map$ = map$ + temp$
Next
Else ' Two-space format.
For i = 1 To Len(f$) ' Map mouse hot zones.
x$ = Mid$(f$, i, 1)
If hot Then
If Mid$(f$ + " ", i, 2) = " " Then
hot = 1 - hot: temp$ = " "
End If
End If
If x$ <> Chr$(32) And hot = 0 Then
hot = 1 - hot: j = j + 1: temp$ = Chr$(96 + j)
End If
map$ = map$ + temp$
Next
End If
If y > UBound(MapHeading$) Then ReDim _Preserve MapHeading$(y)
MapHeading$(y) = map$
End Sub
Sub menu_selection (selection, curstyle, my, mx, lb, mb, mw, b$, MapHeading$(), a$())
Static MenuOpen, abr$(), sf(), sucker, oldmy, oldmx, mshow$, action$, dcnt, MenuWidth, MenuHeight, MenuTop, MenuLeft, spacing, mhl
Static oldmhl, oldmenutop, oldMenuLeft, oldselection
If MenuOpen = 0 Then selection = 0
Select Case MenuOpen
Case 0
j = 0
If Len(MapHeading$(my)) And selection = 0 Then
j = Asc(Mid$(MapHeading$(my), mx, 1)) - 96
If j > 0 Then
If curstyle And mshow$ <> "LINK" Then mshow$ = "LINK": _MouseShow "LINK"
If lb = 2 Then
selection = j ' The menu selected to be opened.
MenuOpen = my ' The row the selected menu occupies.
End If
Else
j = 0
If curstyle And mshow$ <> "DEFAULT" Then mshow$ = "DEFAULT": _MouseShow mshow$
End If
Else
If curstyle And mshow$ <> "DEFAULT" Then mshow$ = "DEFAULT": _MouseShow mshow$
End If
101
If selection Then
If curstyle And mshow$ <> "DEFAULT" Then mshow$ = "DEFAULT": _MouseShow mshow$ ' Remove link mouse appearance.
Select Case my
Case 1 ' Top menu.
dcnt = 0: MenuWidth = 0
User selection, sucker
On Error GoTo erhandler_data
Do
Read dta$
If dta$ = "eof" Then Exit Do
If Len(dta$) Then
Read nul$, nul
If nul Then dta$ = dta$ + " " + Chr$(26) + " "
End If
If (_Height - 6 + pop) \ 2 <= (dcnt * (spacing + 1) + 1) \ 2 + pop Then Exit Do ' Data exceeds window max menu height.
dcnt = dcnt + 1
If Len(dta$) > MenuWidth - 4 Then
MenuWidth = Len(dta$) + 4
Rem MenuLeft = _Width \ 2 - Len(dta$) \ 2 - 2 + 1
End If
Loop
On Error GoTo 0
ReDim a$(dcnt), abr$(dcnt), sf(dcnt)
User selection, sucker
On Error GoTo erhandler_data
For i = 1 To dcnt
Read dta$
If Len(dta$) Then
Read abr$(i), nul
If nul Then dta$ = dta$ + " " + Chr$(26): sf(i) = nul
End If
a$(i) = Space$(MenuWidth - 4)
Select Case style
Case 0: j = 1
Case 1: j = (MenuWidth - 4) \ 2 - Len(dta$) \ 2 + 1
End Select
Mid$(a$(i), j) = dta$
Next
On Error GoTo 0
MenuHeight = dcnt * (spacing + 1) - spacing + 2
If sucker <> -1 Then
MenuTop = my + 1 + pop: Rem To center is _Height \ 2 - MenuHeight \ 2 + 1
MenuLeft = _InStrRev(" " + Mid$(MapHeading$(my), 1, mx), " ")
action$ = "": mhl = 0
PCopy 0, 1
center_menu pop, a$(), dcnt, MenuWidth, MenuHeight, MenuTop, MenuLeft, spacing
Else
sucker = 0
End If
Case _Height ' The footer menu.
Select Case selection
Case 1
Restore help_data
help$ = ""
Do
Read d$
If d$ = "eof" Then Exit Do
help$ = help$ + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10) + d$
Loop
_MessageBox " App Help", help$, ""
MenuOpen = 0: selection = 0 ' Needed to clear variables.
Case 2: System
End Select
End Select
End If
Case Else ' Menu is open.
If Len(MapHeading$(MenuOpen)) And my = MenuOpen Then ' Sliding mouse to open menus.
j = Asc(Mid$(MapHeading$(MenuOpen), mx, 1)) - 96
If j > 0 And j <> selection Then
selection = j ' Leave MenuOpen as is.
If sucker Then sucker = 0
PCopy 1, 0
GoTo 101
End If
End If
If j = selection And lb = 2 Then
action$ = "toggle-shut"
ElseIf Len(b$) Then
action$ = "key"
ElseIf mw Then
action$ = "wheel"
ElseIf oldmy And my <> oldmy And action$ <> "toggle-shut" Or oldmy And mx <> oldmx And action$ <> "toggle-shut" Then
If my > MenuTop - pop And my < MenuTop - pop + MenuHeight - 1 And mx > MenuLeft - pop + 1 And mx < MenuLeft - pop + MenuWidth - 2 Then
action$ = "mouse-in"
Else
If action$ <> "wheel" And action$ <> "key" Then
action$ = "mouse-out"
End If
End If
End If
j = 0
Select Case action$
Case "wheel", "key"
Select Case b$
Case Chr$(0) + "H"
mw = -1: b$ = ""
Case Chr$(0) + "P"
mw = 1: b$ = ""
End Select
If mhl + mw > 0 And mhl + mw <= UBound(a$) Then
j = mhl
Do
j = j + mw: If j > UBound(a$) Then Exit Do
Loop Until Len(LTrim$(a$(j)))
End If
Case "mouse-in"
j = (my - MenuTop + pop + spacing) / (spacing + 1)
Case "mouse-out", "toggle-shut"
If curstyle And mshow$ <> "DEFAULT" Then mshow$ = "DEFAULT": _MouseShow mshow$
If mhl Then
s1 = CsrLin: s2 = Pos(0): c1 = _DefaultColor: c2 = _BackgroundColor
Locate MenuTop - pop + mhl + (mhl - 1) * spacing, MenuLeft - pop + 2 - 1: Color MenuFg, MenuBg: Print " " + a$(mhl) + " "; ' Unhighlight.
mhl = 0
End If
If lb = 2 Then
If sucker = 1 Then ' Closes suckerfish menu. Keeps parent menu open.
sucker = -1: PCopy 2, 0
MenuLeft = oldMenuLeft
MenuTop = oldmenutop
mhl = oldmhl: selection = oldselection
my = 1 '''' Need to address this issue.
GoTo 101
Else
PCopy 1, 0: MenuOpen = 0: Exit Sub
End If
End If
End Select
If j And Int(j) = j Then
If j <> mhl And Len(LTrim$(a$(j))) Then
s1 = CsrLin: s2 = Pos(0): c1 = _DefaultColor: c2 = _BackgroundColor
If mhl Then Locate MenuTop - pop + mhl + (mhl - 1) * spacing, MenuLeft - pop + 2 - 1: Color MenuFg, MenuBg: Print " " + a$(mhl) + " "; ' Unhighlight former.
Locate MenuTop - pop + j + (j - 1) * spacing, MenuLeft - pop + 2 - 1: Color MenuHlFg, MenuHlBg: Print " " + a$(j) + " ";: Locate s1, s2: Color c1, c2: mhl = j ' Highlight current.
End If
Select Case action$
Case "mouse-in"
If lb = 2 Then
If sf(j) Then ' Open suckerfish menu.
oldmhl = mhl: oldmenutop = MenuTop: oldMenuLeft = MenuLeft: oldselection = selection
dcnt = 0
sucker = 1: User selection, sucker
On Error GoTo erhandler_data
Do
Read dta$
If dta$ = "eof" Then Exit Do
If Len(dta$) Then Read nul$
If (_Height - 6 + pop) \ 2 <= (dcnt * (spacing + 1) + 1) \ 2 + pop Then Exit Do ' Data exceeds window max menu height.
dcnt = dcnt + 1
If Len(dta$) > MenuWidth - 4 Then
MenuWidth = Len(dta$) + 4
Rem MenuLeft = _Width \ 2 - Len(dta$) \ 2 - 2 + 1
End If
Loop
On Error GoTo 0
ReDim a$(dcnt), abr$(dcnt)
sucker = 1: User selection, sucker
On Error GoTo erhandler_data
For i = 1 To dcnt
Read dta$
If Len(dta$) Then Read abr$(i)
a$(i) = Space$(MenuWidth - 4)
Select Case style
Case 0: j = 1
Case 1: j = (MenuWidth - 4) \ 2 - Len(dta$) \ 2 + 1
End Select
Mid$(a$(i), j) = dta$
Next
On Error GoTo 0
MenuTop = my ''' This will need to be hanged.
MenuHeight = dcnt * (spacing + 1) - spacing + 2
MenuLeft = MenuLeft + MenuWidth - 2
action$ = "": mhl = 0
PCopy 0, 2
center_menu pop, a$(), dcnt, MenuWidth, MenuHeight, MenuTop, MenuLeft, spacing
Else ' Regular non-suckerfish menu choice.
b$ = LTrim$(Str$(j))
PCopy 1, 0: MenuOpen = 0: selection = 0
If sucker Then sucker = 0
If curstyle And mshow$ <> "DEFAULT" Then mshow$ = "DEFAULT": _MouseShow mshow$
_Title a$(j)
End If
Else
If curstyle And mshow$ <> "LINK" Then mshow$ = "LINK": _MouseShow "LINK"
End If
Case "wheel", "key"
If curstyle And mshow$ <> "DEFAULT" Then mshow$ = "DEFAULT": _MouseShow mshow$
If mb = 2 Or lb = 2 Or b$ = Chr$(13) Then
b$ = LTrim$(Str$(j))
If sucker Then sucker = 0
PCopy 1, 0: MenuOpen = 0: selection = 0
_Title a$(j)
End If
End Select
End If
End Select
oldmy = my: oldmx = mx
End Sub
Sub center_menu (pop, a$(), dcnt, MenuWidth, MenuHeight, MenuTop, MenuLeft, spacing)
' Centers height evenly for odd window heights and 1-space towards top for even.
Locate MenuTop - pop, MenuLeft - pop
For h = 1 To dcnt
If h = 1 Then
Color MenuBdrFg, MenubrdBg
Print Chr$(218) + String$(MenuWidth - 2, 196) + Chr$(191)
j = CsrLin
For i = 1 To MenuHeight - 2
If CsrLin < _Height Then Locate j, MenuLeft - pop Else Locate , MenuLeft - pop
Color MenuBdrFg, MenubrdBg: Print Chr$(179);
Color MenuBdrFg, MenubrdBg: Print Space$(MenuWidth - 2);
Color MenuBdrFg, MenubrdBg: Print Chr$(179);
j = j + 1
Next
Locate j, MenuLeft - pop
Color MenuBdrFg, MenubrdBg: Print Chr$(192) + String$(MenuWidth - 2, 196) + Chr$(217);
If pop Then ' Shadow effect.
Color MenuSdwFg, MenuSdwBg ' Shadow below.
Locate CsrLin + 1, MenuLeft - pop + 2
For i = 1 To MenuWidth
j = Screen(CsrLin, Pos(0))
Print Chr$(j);
Next
Locate MenuTop - pop + 1 ' Shadow to the right.
For i = 1 To MenuHeight - 1
Locate , MenuLeft - pop + MenuWidth
j = Screen(CsrLin, Pos(0))
Print Chr$(j);
j = Screen(CsrLin, Pos(0))
Print Chr$(j)
Next
End If
End If
Color MenuFg, MenuBg
Locate MenuTop - pop + h + (h - 1) * spacing, MenuLeft - pop + 2
If Len(LTrim$(a$(h))) Then
Print a$(h);
Else
Color MenuBdrFg, MenubrdBg
Locate , Pos(0) - 2: Print Chr$(195);
Print String$(MenuWidth - 2, Chr$(196)) + Chr$(180);
End If
Next h
End Sub
Sub MyMouse_and_Keyboard (lb, mb, rb, my, mx, mw, shift%, clkcnt, drag, b$)
Static oldmy, oldmx, z1, hover, mwy, oldmwy
If Len(autokey$) Then
b$ = Mid$(autokey$, 1, InStr(autokey$ + ",", ",") - 1)
autokey$ = Mid$(autokey$, InStr(autokey$ + ",", ",") + 1)
Else
b$ = InKey$
End If
If z1 Then If Abs(Timer - z1) > .3 Then z1 = 0: clkcnt = 0
If lb > 0 Then
If lb = 1 Then
lb = -1
Else
lb = 0
End If
End If
If rb > 0 Then If rb = 1 Then rb = -1 Else rb = 0
If mb > 0 Then If mb = 1 Then mb = -1 Else mb = 0
While _MouseInput
mwy = mwy + _MouseWheel
Wend
my = _MouseY
mx = _MouseX
b_hover = 0
For i = 1 To nob ' number of buttons.
If my >= y_btl(i) And my <= y_bbr(i) And mx >= x_btl(i) And mx <= x_bbr(i) Then
b_hover = i
Exit For
End If
Next
If lb = -1 Then
If oldmy And oldmx <> mx Or oldmy And oldmy <> my Then
If mx <> oldmx Then drag = Sgn(mx - oldmx) ' Prevent zero which can occur if mouse moves off row when being dragged horizontally.
End If
End If
If drag = 0 Then
If mwy <> oldmw Then
mw = Sgn(mwy - oldmwy): mwy = 0
Else
mw = 0
End If
oldmwy = mwy
If _KeyDown(100303) Or _KeyDown(100304) Then shift% = -1 Else If shift% Then shift% = 0
End If
If lb = -1 And _MouseButton(1) = 0 Then
lb = 2: drag = 0: hover = 0
ElseIf rb = -1 And _MouseButton(2) = 0 Then
rb = 2
ElseIf mb = -1 And _MouseButton(3) = 0 Then
mb = 2
End If
If _MouseButton(1) Then
If lb = 0 Then
lb = 1
If z1 = 0 Then
z1 = Timer ' Let first click go through.
Else
clkcnt = clkcnt + 1
End If
End If
ElseIf _MouseButton(2) And rb = 0 Then
rb = 1
ElseIf _MouseButton(3) And mb = 0 Then
mb = 1
End If
oldmy = my: oldmx = mx
End Sub
Also, Mark, glad I could help. The DO/LOOP is self-exiting after a mouse cycle is completd. It is required to measure all states: 1 = Depress, -1 = Held Down, 2 = Released, 0 = Cycle completed. Yes, you could construct another method to achieve the same results but I'm not sure it would be simpiler and universally applicable.
Pete
Shoot first and shoot people who ask questions, later.
|
