12-25-2024, 03:29 AM
Well unfinished, but it's Christmas Eve so I have to barbecue.
This code works but lacks some bells and whistles. It's part of a library build I'm making.
Multi drop-down menu demo...
So I also need to get caught up on these posts, but I did see Steve posted something about multi-menus. I'm guessing it is what I made here in graphics mode, but I'll hopefully get a chance to catch up Christmas morning when the rest of the family is sleeping in. We are waaaaaay past the getting up at dawn to unwrap presents. I do miss those days.
So Merry Christmas to all!
Pete
This code works but lacks some bells and whistles. It's part of a library build I'm making.
Multi drop-down menu demo...
Code: (Select All)
Dim Shared MenuBdrFg, MenubrdBg, MenuSdwFg, MenuSdwBg, MenuFg, MenuBg, MenuHlFg, MenuHlBg, pop
ReDim MapHeading$(1), a$(1): curstyle = 1
pop = 1
setup
a$ = " File Edit View Search": Locate 1, 1
map_heading a$, MapHeading$(), 0
a$ = "[F1] Help [Esc] Quit": Locate _Height, 1
map_heading a$, MapHeading$(), 1
menu_main MapHeading$(), curstyle
Sub User (selection)
Select Case selection
Case 1: Restore data1
Case 2: Restore data2
Case 3: Restore data4
Case 4: Restore data4
End Select
color_palette_data:
' MenuBdrFg, MenubrdBg, MenuSdwFg, MenuSdwBg, MenuFg, MenuBg, MenuHlFg, MenuHlBg
Data 1,-1,2,-1,3,-1,4,-1,5,-1,6,-1,7,63,8,-1,9,-1,10,-1,11,-1,12,-1,13,-1,14,-1,15,-1
Data 1,7,8,1,0,7,15,1
Data eof
data1:
Data New,Open,Save,Export,Exit
Data eof
data2:
Data Undo,Redo,Cut,Copy,Paste,Select All
Data eof
data3:
Data Subs...,Line Numbers,Compiler Warnings
Data eof
data4:
Data Find,Repeat Last Find,Change,Clear Search History,Quick Navigation,Go To Line
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
Color 15, 1
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
Select Case centering
Case 0: Print MapHeading$;
Case Else
Locate , _Width \ 2 - Len(MapHeading$) \ 2 + 1
Print MapHeading$;
End Select
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, oldmy, oldmx, mshow$, action$, dcnt, MenuWidth, MenuHeight, MenuTop, menuleft, spacing, mhl
Select Case MenuOpen
Case 0
j = 0: selection = 0
If Len(MapHeading$(my)) And MenuOpen = 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
Else
j = 0
If curstyle And mshow$ <> "DEFAULT" Then mshow$ = "DEFAULT": _MouseShow mshow$
End If
End If
If selection Then
Select Case my
Case 1
dcnt = 0: MenuWidth = 0
User selection
Do
Read dta$
If dta$ = "eof" Then Exit Do
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
ReDim a$(dcnt)
User selection
For i = 1 To dcnt
Read dta$
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
MenuHeight = dcnt * (spacing + 1) - spacing + 2
MenuTop = my + 1 + pop: Rem To center is _Height \ 2 - MenuHeight \ 2 + 1
menuleft = _InStrRev(" " + Mid$(MapHeading$(my), 1, mx), " ")
action$ = "": mhl = 0
MenuOpen = 1: PCopy 0, 1
center_menu pop, a$(), dcnt, MenuWidth, MenuHeight, MenuTop, menuleft, spacing
Case _Height
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$, ""
Case 2: System
End Select
End Select
End If
Case 1
If Len(b$) Then
action$ = "key"
ElseIf mw Then
action$ = "wheel"
ElseIf oldmy And my <> oldmy Or oldmy And mx <> oldmx 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"
If mhl + mw > 0 And mhl + mw <= UBound(a$) Then
j = mhl + mw
End If
Case "mouse-in"
j = (my - MenuTop + pop + spacing) / (spacing + 1)
Case "mouse-out"
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 PCopy 1, 0: MenuOpen = 0: If curstyle And mshow$ <> "DEFAULT" Then mshow$ = "DEFAULT": _MouseShow mshow$
End Select
If j And Int(j) = j Then
If j <> mhl 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 curstyle And mshow$ <> "LINK" Then mshow$ = "LINK": _MouseShow "LINK"
If lb = 2 Then
b$ = LTrim$(Str$(j))
PCopy 1, 0: MenuOpen = 0: If curstyle And mshow$ <> "DEFAULT" Then mshow$ = "DEFAULT": _MouseShow mshow$
_Title a$(j)
End If
Case "wheel", "key"
If curstyle And mshow$ <> "DEFAULT" Then mshow$ = "DEFAULT": _MouseShow mshow$
If mb = 2 Or lb = 2 Then
b$ = LTrim$(Str$(j))
PCopy 1, 0: MenuOpen = 0: If curstyle And mshow$ <> "DEFAULT" Then mshow$ = "DEFAULT": _MouseShow mshow$
_Title a$(j)
End If
End Select
End If
oldmy = my: oldmx = mx
End Select
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
Print a$(h);
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 SubSo I also need to get caught up on these posts, but I did see Steve posted something about multi-menus. I'm guessing it is what I made here in graphics mode, but I'll hopefully get a chance to catch up Christmas morning when the rest of the family is sleeping in. We are waaaaaay past the getting up at dawn to unwrap presents. I do miss those days.
So Merry Christmas to all!
Pete