Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
12-24-2025, 01:44 AM
(This post was last modified: 12-26-2025, 11:06 PM by Pete.)
Since I keep messing around with different combinations and using those to build up libraries, I'd thought I just post and update the popup menu stuff here.
Code: (Select All)
Width 90, 35: _Font 16
_ScreenMove 200, 20
Dim Shared MenuModel: MenuModel = 1
Type TextVar
HardwareMenus As Integer ' 0 or 1.
FormStyle As Integer
InptMthd As Integer ' 2 is for creating an input field when csrlin is activated by mouse or keyboard.
mt As Integer
mr As Integer
mb As Integer
ml As Integer
bsTop As Integer
bsRight As Integer
bsBottom As Integer
bsLeft As Integer
noe As Integer
nol As Integer
scr As Integer
oldscr As Integer
wide As Integer
tall As Integer
fw As Integer
fh As Integer
redisplay As Integer
hl As Integer
HlFind As Integer
ScreenEstablished As Integer
ScrnResize As Integer
ScrnResizeW As Integer
ScrnResizeH As Integer
ScrnResizeInputRow As Integer
ScrnResizeInputCol As Integer
RollupEvent As Integer
RollupStatus As Integer
HoldScr As Integer
persistency As Integer ' 1 or 0
UseDefaultDisplay As Integer ' 1 or 0
InputActive As Integer ' Records cursor row.
FieldIndent As Integer ' 0 whole text. 1 Input field only for text after prefix (Ex URL:_________).
redo As Integer
undo As Integer
RedoText As String
UndoText As String
MarkerOn As Integer
marker As Integer
EncodeOn As Integer
remakeIDX As Integer
hideshow As String
AddDelete As Integer ' 1 Add, -1 Delete, or 0 inactive.
OpenInput As Integer ' 1 Open input line pase colon or 2 Open entire input line.
hgltPos1 As Integer
hwUnderlineShow As Integer
hwUnderlineImage As Long
End Type
Dim t As TextVar
Type InputVar
CurStyle As Integer
CurShow As Integer
fld As Integer
mtop As Integer
mleft As Integer
myclose As Integer
mxclose As Integer
hwFieldPresent As Integer
hwFieldFront As Long
hwFieldBack As Long
hwFieldHlMargin As Long
End Type
Dim in As InputVar
Type PopupVar
ForceInitiate As Integer
Show As Integer ' 0 or 1.
hwWindow As Long
mwidth As Integer
mheight As Integer
FixMenuT As Integer
FixMenuL As Integer
MenuT As Integer
MenuB As Integer
MenuL As Integer
MenuR As Integer
MenuHL As Integer
MarginRt As Integer
BoundsLt As Integer
BoundsRt As Integer
Shadow As Integer ' 0 or 1.
VSpacing As Integer
Choice As Integer
End Type
Dim pop As PopupVar
Type MouseVar
x As Integer
y As Integer
lb As Integer
rb As Integer
mb As Integer
mw As Integer
clkcnt As Integer
caps As Integer
shift As Integer
ctrl As Integer
alt As Integer
prevx As Integer
prevy As Integer
drag As Integer
sbar As Integer
sbRow As Integer
oldsbRow As Integer
ThumbTop As Integer
ThumbSize As Integer
ThumbDrag As Integer
autokey As String
End Type
Dim m As MouseVar
Type ColorVar
pal1 As Integer
pal2 As Integer
pal3 As Integer
pal4 As Integer
PageColor As Integer
SkinFrg As Integer
SkinBkg As Integer
InputFrg As Integer
InputFrg2 As Integer
InputBkg As Integer
InputHl As Integer
InputH2 As Integer
SkinShadowFrg As Integer
SkinShadowBkg As Integer
PopupFrg As Integer
PopupBkg As Integer
PopupUnavail As Integer
PopupShadowFrg As Integer
PopupShadowBkg As Integer
End Type
Dim c As ColorVar
Color 7, 1: Cls
User_Defined_Variables t, pop, c
GoSub Menu
Do
_Limit 60
If m.rb = -1 Then pop.Show = 1: MenuModel = -1: getmenu = 1
Mouse_Keyboard m, b$
If Len(b$) Then
If Mid$(b$, 2, 1) >= Chr$(59) And Mid$(b$, 2, 1) <= Chr$(66) Then getmenu = 1: MenuModel = 1 Else getmenu = 0
Select Case b$
Case Chr$(0) + Chr$(59): t.HardwareMenus = 0: pop.VSpacing = -1
Case Chr$(0) + Chr$(60): t.HardwareMenus = 0: pop.VSpacing = -2
Case Chr$(0) + Chr$(61): t.HardwareMenus = 0: pop.VSpacing = 1
Case Chr$(0) + Chr$(62): t.HardwareMenus = 0: pop.VSpacing = 2
Case Chr$(0) + Chr$(63): t.HardwareMenus = 1: pop.VSpacing = -1
Case Chr$(0) + Chr$(64): t.HardwareMenus = 1: pop.VSpacing = -2
Case Chr$(0) + Chr$(65): t.HardwareMenus = 1: pop.VSpacing = 1
Case Chr$(0) + Chr$(66): t.HardwareMenus = 1: pop.VSpacing = 2
Case Chr$(27): System
End Select
End If
If getmenu Then getmenu = 0: pop.Show = -1: GoSub Menu: pop.ForceInitiate = 1
Popup_Menu t, in, pop, m, c, b$
_Display
Loop
Menu:
Color 15, 1: Cls
Locate 2, 2
Print "Press F1 for a Single-Spaced No Lines Popup Menu"
Locate 3, 2
Print "Press F2 for a Double-Spaced No Lines Popup Menu"
Locate 4, 2
Print "Press F3 for a Single-Spaced Lined Popup Menu"
Locate 5, 2
Print "Press F4 for a Double-Spaced Lined Popup Menu"
Locate 6, 2
Print "Press F5 for a Single-Spaced No Lines Hardware Popup Menu"
Locate 7, 2
Print "Press F6 for a Double-Spaced No Lines Hardware Popup Menu"
Locate 8, 2
Print "Press F7 for a Single-Spaced Lined Hardware Popup Menu"
Locate 9, 2
Print "Press F8 for a Double-Spaced Lined Hardware Popup Menu"
Print
Color 1, 3
For i = 1 To 22
Print String$(_Width, Chr$(177))
Next
Color 15, 1
Return
Sub User_Defined_Variables (t As TextVar, pop As PopupVar, c As ColorVar)
t.ml = 1: t.mr = _Width: t.mt = 1: t.mb = _Height
t.HardwareMenus = 1 ' Hardware Acceleration On. Used for Menus and requires _DISPLAY to be placed in calling loop.
pop.FixMenuT = 13
pop.FixMenuL = 10
pop.MarginRt = 4 ' Margin from right side if popup. Popup elements will be limited to this point of indentation.
pop.BoundsLt = 0 ' Popup will not appear further left than this indent value measured as the distance away from the left border of the parent window.
pop.BoundsRt = 0 ' Popup and shadow, if present, will not appear further right than this indent value measured as the distance away from the right border of the parent window.
pop.VSpacing = 2 ' 1 single space with dividers (if harware images on), -1 single space no dividers, 2 double space with dividers, -2 double space no dividers.
pop.Shadow = 1 ' 1 for present or 0 for absent.
c.PageColor = 5 ' _BackgroundColor
c.SkinFrg = 3
c.SkinBkg = 5
c.SkinShadowFrg = 8
c.SkinShadowBkg = 0
c.InputFrg = 0 ' Use 15 for bright white if a black input field background is wanted.
c.InputFrg2 = 6
c.InputBkg = c.PageColor ' Same as page color. Use with hardware highlighting, otherwise use 0 to create a black input field.
c.InputHl = 15
c.InputH2 = 6
c.PopupFrg = 0 ' Available menu item.
c.PopupBkg = 5 ' Popup background. (Same as c.SkinBkg)
c.PopupUnavail = 7 ' Unavailable menu item.
c.PopupShadowBkg = 2 ' Shadow. (Ignore if not present).
c.PopupShadowFrg = 7 ' Characters under shadow.
c.pal1 = 34
c.pal2 = 17
c.pal3 = 63
c.pal4 = 56
Palette c.InputFrg2, c.pal2
Palette c.SkinBkg, c.pal3
Palette c.PopupShadowBkg, c.pal4
MyFormData: ' Name column, name, input row, input column, input length, max length, initial text. Note eof must be lowercase.
Data 3,"Field 1:",2,12,44,250,""
Data 3,"Field 2:",5,12,44,250,""
Data eof
PopupMenuData: ' eof must be lowercase.
Data Pete's tremendous! While Steve's just amazing.
Data Four score and 7 years ago was a good time to get out of Germany.
Data The rain in Spain falls mainly on the Hispanic People.
Data "The rain in California falls mainy on the Hispanic people, too."
Data You can't make Halloween fun without breaking a few eggs.
Data What do you get when you cross an elephant with a rhino? Elephino!
Data "When life gives you lemons, make lemonaid."
Data "When life gives you crap, does juicing it really help?"
Data eof
End Sub
Sub Mouse_Keyboard (m As MouseVar, b$)
Static z1
If Len(m.autokey) Then
b$ = Mid$(m.autokey + ",", 1, InStr(m.autokey$ + ",", ",") - 1)
m.autokey = Mid$(m.autokey, InStr(m.autokey$ + ",", ",") + 1) ' Don't add "," tomid$() portion or the last key will always be a comma.
Else
b$ = InKey$
End If
m.prevx = m.x: m.prevy = m.y
If m.mw Then m.mw = 0
While _MouseInput
m.mw = m.mw + _MouseWheel: If m.mw Then m.mw = m.mw \ Abs(m.mw) ' Limit to 1 or -1 for up or down.
Wend
m.x = _MouseX
m.y = _MouseY
If z1 Then If Abs(Timer - z1) > .25 Then z1 = 0: m.clkcnt = 0
Select Case m.lb
Case 2: m.lb = 0 ' Click cycle completed.
Case 1: If _MouseButton(1) = 0 Then m.lb = 2: m.drag = 0: m.ThumbDrag = 0 ' Button released.
Case -1: m.lb = 1 ' Button held down.
Case 0: m.lb = _MouseButton(1)
End Select
Select Case m.rb
Case 2: m.rb = 0 ' Click cycle completed.
Case 1: If _MouseButton(2) = 0 Then m.rb = 2 ' Button released.
Case -1: m.rb = 1 ' Button held down.
Case 0: m.rb = _MouseButton(2)
End Select
Select Case m.mb
Case 2: m.mb = 0 ' Click cycle completed.
Case 1: If _MouseButton(3) = 0 Then m.mb = 2 ' Button released.
Case -1: m.mb = 1 ' Button held down.
Case 0: m.mb = _MouseButton(3)
End Select
If Abs(m.lb) = 1 Then
If m.lb = -1 Then z1 = Timer: m.clkcnt = m.clkcnt + 1
If m.prevx And m.prevx <> m.x Or m.prevy And m.prevy <> m.y Then
If m.x <> m.prevx Then m.drag = Sgn(m.x - m.prevx) ' Prevent zero which can occur if mouse moves off row when being draged horizontally.
End If
End If
If _KeyDown(100301) Then m.caps = -1 Else If m.caps Then m.caps = 0
If _KeyDown(100303) Or _KeyDown(100304) Then m.shift = -1 Else If m.shift Then m.shift = 0
If _KeyDown(100305) Or _KeyDown(100306) Then m.ctrl = -1 Else If m.ctrl Then m.ctrl = 0
If _KeyDown(100307) Or _KeyDown(100308) Then m.alt = -1 Else If m.alt Then m.alt = 0
End Sub
Sub Popup_Menu (t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$)
If pop.Show = 0 Then Exit Sub '===================>
Static initiate, nomi, oldmy, myalt
Static menu$(), menu_restrict(), y, x, atmp As String
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If pop.ForceInitiate Then initiate = 0
If initiate = 0 Then
If t.ml = 0 Or t.mr = 0 Or t.mt = 0 Or t.mb = 0 Then
_MessageBox "Configuration Error", "The required variables (t.mt, t.mr, t.mb, and t.ml must be set and passed to this routine to open the popup window.", "error"
System
End If
initiate = 1
in.CurShow = 0: Locate , , in.CurShow ' Hide cursor
nomi = 0: oldmy = 0: myalt = 0: pop.MenuHL = 0
pop.hwWindow = 0: pop.Show = 0
If t.fw = 0 Then t.fw = _FontWidth: t.fh = _FontHeight
Restore PopupMenuData
Do
Read tmp$
If tmp$ = "eof" Then Exit Do
nomi = nomi + 1
ReDim _Preserve menu$(nomi)
menu$(nomi) = tmp$
ReDim menu_restrict(nomi) ' Restrictions.
y = CsrLin: x = Pos(0)
Loop
End If
Do
If t.ScrnResize Then Exit Do ' Force popup to close when resizing app.
mxalt = 0
If b$ = Chr$(0) + "H" Or m.mw = -1 Then
If (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing) > 1 Then
myalt = pop.MenuHL - Abs(pop.VSpacing): mxalt = -1
End If
ElseIf b$ = Chr$(0) + "P" Or m.mw = 1 Then
If pop.MenuHL = 0 Then
myalt = pop.MenuT + 1: mxalt = -1
Else
If (pop.MenuHL - pop.MenuT + 1) \ Abs(pop.VSpacing) < nomi + Abs(Abs(pop.VSpacing) - 2) Then
myalt = pop.MenuHL + Abs(pop.VSpacing): mxalt = -1
End If
End If
ElseIf b$ = Chr$(13) And pop.MenuHL Or m.mb = 2 Then
If menu_restrict((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) = 0 Then
pop.Choice = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
Exit Do
End If
End If
Select Case pop.Show
Case 0, -1 ' Open popup. Note: -1 is used when call comes outside mousebutton event. If inside, just call this sub and zero opens popup.
For i = 1 To nomi
j = Len(menu$(i))
If j > k Then k = j
Next
pop.mwidth = k + pop.MarginRt ' Variable to determine margin spaces from the right of menu.
pop.mheight = nomi * Abs(pop.VSpacing) + 1 ' Add one for the separate border element.
Select Case MenuModel
Case Is > 0 ' Fixed menu to left.
pop.MenuT = pop.FixMenuT: pop.MenuL = pop.FixMenuL: pop.MenuR = pop.MenuL + pop.mwidth: pop.MenuB = pop.MenuT + pop.mheight
Case Is < 0 ' Movable menu.
While _MouseInput: Wend
pop.MenuT = _MouseY + 1 ' One below input line.
pop.MenuL = _MouseX
If pop.MenuT + pop.mheight >= _Height Then pop.MenuT = _Height - pop.mheight - pop.Shadow
If pop.MenuL + pop.mwidth >= t.mr - pop.Shadow Then
pop.MenuL = t.mr - pop.mwidth - pop.BoundsRt - pop.Shadow
ElseIf pop.MenuL <= pop.BoundsLt Then
pop.MenuL = t.ml - 1 + pop.BoundsLt
End If
pop.MenuR = pop.MenuL + pop.mwidth: pop.MenuB = pop.MenuT + pop.mheight
End Select
pop.Show = 1 ' Identifies the menu is open.
PCopy 0, 1
If t.HardwareMenus Then
If pop.hwWindow = 0 Then
vs = (Abs(Abs(pop.VSpacing) - 2)) ' Equals 1 for single space and 0 for double space.
hWth = t.fw \ 2
hHgt = t.fh \ 2
t1 = _NewImage((pop.mwidth + 2) * t.fw, nomi * 3 * t.fh, 32)
_Dest t1
' top bottom left right (mask)
Line (hWth + 1, 0)-(pop.mwidth * t.fw - hWth, hHgt), _RGB32(255, 255, 255), BF
Line (hWth + 1, (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + hHgt - t.fh)-(pop.mwidth * t.fw - hWth, ((i - 1 + vs) * Abs(pop.VSpacing) * t.fh + hHgt - t.fh + hHgt)), _RGB32(255, 255, 255), BF
Line (hWth + 1, 0)-(t.fw, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh), _RGB32(255, 255, 255), BF
Line (pop.mwidth * t.fw - hWth, 0)-(pop.mwidth * t.fw - t.fw, (pop.MenuB - pop.MenuT - (Abs(pop.VSpacing) - 1)) * t.fh), _RGB32(255, 255, 255), BF
If pop.VSpacing > 0 Then
For i = 0 To nomi
If i > 0 And i < nomi Or vs Then
Line (hWth, (i + .5 * vs) * Abs(pop.VSpacing) * t.fh)-(pop.mwidth * t.fw - hWth, (i + .5 * vs) * Abs(pop.VSpacing) * t.fh), _RGB32(0, 0, 0, 32), B
End If
Next
End If
If vs And pop.VSpacing = 1 Then ' Redo right and left mask over divider lines so they do not extend to the edges.
Line (hWth + 1, 0)-(t.fw, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh), _RGB32(255, 255, 255), BF
Line (pop.mwidth * t.fw - hWth, 0)-(pop.mwidth * t.fw - t.fw, (pop.MenuB - pop.MenuT - (Abs(pop.VSpacing) - 1)) * t.fh), _RGB32(255, 255, 255), BF
End If
' top bottom left right (outer border)
Line (hWth, 0)-(pop.mwidth * t.fw - hWth, 0), _RGB32(0, 0, 0, 32), B
Line (t.fw * .5, (i - 1 + vs) * Abs(pop.VSpacing) * t.fh)-((pop.mwidth * t.fw - hWth), (i - 1 + vs) * Abs(pop.VSpacing) * t.fh), _RGB32(0, 0, 0, 32), B
Line (hWth, 0)-(hWth, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh), _RGB32(0, 0, 0, 32), B
Line (pop.mwidth * t.fw - hWth, 0)-(pop.mwidth * t.fw - hWth, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh), _RGB32(0, 0, 0, 32), B
j = 2 ' Make shadow 2 units smaller than font height and width.
Line (pop.mwidth * t.fw - hWth + 1, hHgt)-((pop.mwidth) * t.fw + hWth - j, (pop.MenuB - pop.MenuT + vs) * t.fh - hHgt - j), _RGB32(0, 0, 0, 128), BF
Line (t.fw * 1.5, (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + 1)-((pop.mwidth * t.fw - hWth), (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + hHgt - j), _RGB32(0, 0, 0, 128), BF
pop.hwWindow = _CopyImage(t1, 33)
_FreeImage t1
_Dest 0
End If
Locate pop.MenuT + 1, pop.MenuL
For i = 1 To pop.mheight - 2
Color c.PopupFrg, c.PopupBkg: Locate , pop.MenuL + 1
Print Space$(pop.mwidth - 2)
Next
Else
Locate pop.MenuT, pop.MenuL
Color c.PopupFrg, c.PopupBkg
Print Chr$(218) + String$(pop.mwidth - 2, 196) + Chr$(191)
For i = 1 To pop.mheight - Abs(pop.VSpacing)
Color c.PopupFrg, c.PopupBkg: Locate , pop.MenuL
Print Chr$(179); Space$(pop.mwidth - 2) + Chr$(179);
Color c.PopupShadowBkg, c.PopupShadowFrg: Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Next
Color c.PopupFrg, c.PopupBkg: Locate , pop.MenuL
Print Chr$(192) + String$(pop.mwidth - 2, 196) + Chr$(217);
Color c.PopupShadowBkg, c.PopupShadowFrg: Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Locate , pop.MenuL + 2
For i = 1 To pop.mwidth
Print Chr$(Screen(CsrLin, Pos(0)));
Next
End If
Locate pop.MenuT + 2, pop.MenuL + 2
For i = 0 To nomi - 1
Locate pop.MenuT + 1 + i * Abs(pop.VSpacing), pop.MenuL + 1
If menu_restrict(i + 1) Then Color c.PopupUnavail, c.PopupBkg Else Color c.PopupFrg, c.PopupBkg
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 2) = menu$(i + 1)
Print atmp
Color c.PopupFrg, c.PopupBkg
Locate , pop.MenuL
If t.HardwareMenus = 0 And pop.VSpacing = 2 Then
If i + 1 < nomi Then Print "Ã" + String$(pop.mwidth - 2, Chr$(196)) + "´";
End If
Next
Case 1 ' Popup is present.
If m.rb = -1 Then
If m.y < pop.MenuT Or m.y > pop.MenuB Or m.x < pop.MenuL Or m.x > pop.MenuR Then
Exit Do ' Right click outside popup reopens and moves popup on next sub call when right button = 2.
End If
End If
If mxalt = 0 Then myalt = m.y: mxalt = m.x
i = myalt > pop.MenuT And myalt < pop.MenuB And mxalt > pop.MenuL And mxalt < pop.MenuR
If i Or mxalt = -1 Then
Select Case Abs(pop.VSpacing)
Case 1
i = myalt <> oldmy
Case 2
i = (myalt - pop.MenuT) \ Abs(pop.VSpacing) <> (myalt - pop.MenuT) / Abs(pop.VSpacing) And myalt <> oldmy
End Select
If i Or mxalt = -1 Then ' Works for odd or even number top margins.
If pop.MenuHL Then ' Remove highlighting from previous hover.
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 2, Len(menu$((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)))) = menu$((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing))
Locate pop.MenuHL, pop.MenuL + 2 - 1
If menu_restrict((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) Then Color c.PopupUnavail, c.PopupBkg Else Color c.PopupFrg, c.PopupBkg
Print atmp
End If
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 2, Len(menu$((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)))) = menu$((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing))
Locate myalt, pop.MenuL + 2 - 1
If menu_restrict((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) Then Color c.PopupBkg, c.PopupUnavail Else Color c.PopupBkg, c.PopupFrg
Print atmp;
Color c.PopupFrg, c.PopupBkg
pop.MenuHL = myalt
oldmy = m.y
End If
If m.lb = 2 Then
If menu_restrict((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) = 0 Then
pop.Choice = (myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
Exit Do
End If
End If
Else
' Toggle close popup menu.
If m.lb = 1 Then
If m.y > pop.MenuT Or m.y < pop.MenuB Or m.x > pop.MenuR Or m.x < pop.MenuL Then Exit Do
End If
End If
If Len(b$) Then
'-----------------------------------------------------------------------------------------------------------
' Valid menu shortcut key list here.
Select Case b$
Case Chr$(0) + "S", Chr$(22), Chr$(24), Chr$(1), Chr$(3): m.autokey = b$: b$ = "": Exit Do
Case Chr$(27): pop.Show = 0: b$ = "": Exit Do ' Simply close popup.
End Select
End If
End Select
If t.HardwareMenus Then _PutImage ((pop.MenuL - 1) * t.fw, (pop.MenuT - 1) * t.fh + t.fh \ 2), pop.hwWindow
pop.ForceInitiate = 0
Locate y, x
Exit Sub ' -------------------------------------------------------->
Loop ' Loop is exited when popup is closed; otherwise we exit the sub from the statement above.
pop.Show = 0
PCopy 1, 0
Color restore_color1, restore_color2
Locate y, x
If b$ = Chr$(27) Then b$ = "" ' Negate b$ so an esc routine will not be preformed in the next subroutine before relooping to the mouse call.
_KeyClear
initiate = 0
Locate _Height - 1, 1: Color 15, 1: Print Space$(_Width);
Locate _Height - 1, 2: Print menu$(pop.Choice);
End Sub
Menu restrictions are a little harder to make universal, so I took them out for know. By restrictions I mean like the kind I use of a right click cut/copy/paste menu mutes the features that are not available like cut when nothing is highlighted, etc.
For this demo use the function keys to view the different examples and if you pick one, you can also right click the menu around the screen, just like to popups that use cut/copy/paste etc. in Windows apps.
The neat part is that it's very customizable. YOU can keep the shadow, ditch the shadow, change the colors, etc. all by changing the values in the User Defined Variables sub.
Hell, for fun I might even make an all graphics version. It all depends on how spiked the eggnog gets this season. Ho, ho, friggin' ho.
MAGA Christmas... and a G.O.P. Year!
Pete
Posts: 53
Threads: 11
Joined: Jun 2024
Reputation:
3
Wow, Pete,
you're a true QB64 specialist!
Merry Christmas and a Happy New Year!
Rudy
Posts: 495
Threads: 41
Joined: Apr 2022
Reputation:
41
very nice @Pete
if you press F1 and then the return key you get
Code: (Select All) ---------------------------
Unhandled Error #9 - Menu Demo to be Expanded.exe
---------------------------
Line: 333 (in main module)
Subscript out of range
Continue?
---------------------------
Yes No
---------------------------
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
12-26-2025, 11:07 PM
(This post was last modified: 12-26-2025, 11:08 PM by Pete.)
@Jack
Nice catch. It needed and additional condition added... And pop.MenuHL (Post #1 edited).
That way, it will ignore an Enter key press if a menu item was not highlighted.
Thanks! +1
Pete 
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
Okay, I added a way to get more than one menu in the demo. As written, it could handle up to 9 different menus.
Code: (Select All)
Width 90, 36: _Font 16
_ScreenMove 200, 20
Dim Shared MenuModel: MenuModel = 1
Type TextVar
HardwareMenus As Integer ' 0 or 1.
FormStyle As Integer
InptMthd As Integer ' 2 is for creating an input field when csrlin is activated by mouse or keyboard.
mt As Integer
mr As Integer
mb As Integer
ml As Integer
bsTop As Integer
bsRight As Integer
bsBottom As Integer
bsLeft As Integer
noe As Integer
nol As Integer
scr As Integer
oldscr As Integer
wide As Integer
tall As Integer
fw As Integer
fh As Integer
redisplay As Integer
hl As Integer
HlFind As Integer
ScreenEstablished As Integer
ScrnResize As Integer
ScrnResizeW As Integer
ScrnResizeH As Integer
ScrnResizeInputRow As Integer
ScrnResizeInputCol As Integer
RollupEvent As Integer
RollupStatus As Integer
HoldScr As Integer
persistency As Integer ' 1 or 0
UseDefaultDisplay As Integer ' 1 or 0
InputActive As Integer ' Records cursor row.
FieldIndent As Integer ' 0 whole text. 1 Input field only for text after prefix (Ex URL:_________).
redo As Integer
undo As Integer
RedoText As String
UndoText As String
MarkerOn As Integer
marker As Integer
EncodeOn As Integer
remakeIDX As Integer
hideshow As String
AddDelete As Integer ' 1 Add, -1 Delete, or 0 inactive.
OpenInput As Integer ' 1 Open input line pase colon or 2 Open entire input line.
hgltPos1 As Integer
hwUnderlineShow As Integer
hwUnderlineImage As Long
End Type
Dim t As TextVar
Type InputVar
CurStyle As Integer
CurShow As Integer
fld As Integer
mtop As Integer
mleft As Integer
myclose As Integer
mxclose As Integer
hwFieldPresent As Integer
hwFieldFront As Long
hwFieldBack As Long
hwFieldHlMargin As Long
End Type
Dim in As InputVar
Type PopupVar
ForceInitiate As Integer
Show As Integer ' 0 or 1.
hwWindow As Long
MenuID As Integer
mwidth As Integer
mheight As Integer
FixMenuT As Integer
FixMenuL As Integer
MenuT As Integer
MenuB As Integer
MenuL As Integer
MenuR As Integer
MenuHL As Integer
MarginRt As Integer
BoundsLt As Integer
BoundsRt As Integer
Shadow As Integer ' 0 or 1.
VSpacing As Integer
Choice As Integer
End Type
Dim pop As PopupVar
Type MouseVar
x As Integer
y As Integer
lb As Integer
rb As Integer
mb As Integer
mw As Integer
clkcnt As Integer
caps As Integer
shift As Integer
ctrl As Integer
alt As Integer
prevx As Integer
prevy As Integer
drag As Integer
sbar As Integer
sbRow As Integer
oldsbRow As Integer
ThumbTop As Integer
ThumbSize As Integer
ThumbDrag As Integer
autokey As String
End Type
Dim m As MouseVar
Type ColorVar
pal1 As Integer
pal2 As Integer
pal3 As Integer
pal4 As Integer
PageColor As Integer
SkinFrg As Integer
SkinBkg As Integer
InputFrg As Integer
InputFrg2 As Integer
InputBkg As Integer
InputHl As Integer
InputH2 As Integer
SkinShadowFrg As Integer
SkinShadowBkg As Integer
PopupFrg As Integer
PopupBkg As Integer
PopupUnavail As Integer
PopupShadowFrg As Integer
PopupShadowBkg As Integer
End Type
Dim c As ColorVar
Color 7, 1: Cls
User_Defined_Variables t, pop, c
GoSub Menu
Do
_Limit 60
If m.rb = -1 Then pop.Show = 1: MenuModel = -1: getmenu = 1
Mouse_Keyboard m, b$
If Len(b$) Then
If Mid$(b$, 2, 1) >= Chr$(59) And Mid$(b$, 2, 1) <= Chr$(66) Or b$ = Chr$(9) Then getmenu = 1: MenuModel = 1 Else getmenu = 0
Select Case b$
Case Chr$(0) + Chr$(59): t.HardwareMenus = 0: pop.VSpacing = -1
Case Chr$(0) + Chr$(60): t.HardwareMenus = 0: pop.VSpacing = -2
Case Chr$(0) + Chr$(61): t.HardwareMenus = 0: pop.VSpacing = 1
Case Chr$(0) + Chr$(62): t.HardwareMenus = 0: pop.VSpacing = 2
Case Chr$(0) + Chr$(63): t.HardwareMenus = 1: pop.VSpacing = -1
Case Chr$(0) + Chr$(64): t.HardwareMenus = 1: pop.VSpacing = -2
Case Chr$(0) + Chr$(65): t.HardwareMenus = 1: pop.VSpacing = 1
Case Chr$(0) + Chr$(66): t.HardwareMenus = 1: pop.VSpacing = 2
Case Chr$(27): System
Case Chr$(9): If pop.MenuID = 2 Then pop.MenuID = 1 Else pop.MenuID = 2
End Select
End If
If getmenu Then getmenu = 0: pop.Show = -1: GoSub Menu: pop.ForceInitiate = 1
Popup_Menu t, in, pop, m, c, b$
_Display
Loop
Menu:
Color 15, 1: Cls
Locate 3, 2
Print "Press F1 for a Single-Spaced No Lines Popup Menu"
Locate , 2
Print "Press F2 for a Double-Spaced No Lines Popup Menu"
Locate , 2
Print "Press F3 for a Single-Spaced Lined Popup Menu"
Locate , 2
Print "Press F4 for a Double-Spaced Lined Popup Menu"
Locate , 2
Print "Press F5 for a Single-Spaced No Lines Hardware Popup Menu"
Locate , 2
Print "Press F6 for a Double-Spaced No Lines Hardware Popup Menu"
Locate , 2
Print "Press F7 for a Single-Spaced Lined Hardware Popup Menu"
Locate , 2
Print "Press F8 for a Double-Spaced Lined Hardware Popup Menu"
Print
Locate , 2
Print "Press Tab to Switch to a Different Menu"
Print
Color 1, 3
For i = 1 To 20
Print String$(_Width, Chr$(177))
Next
Color 15, 1
Return
Sub User_Defined_Variables (t As TextVar, pop As PopupVar, c As ColorVar)
t.ml = 1: t.mr = _Width: t.mt = 1: t.mb = _Height
t.HardwareMenus = 1 ' Hardware Acceleration On. Used for Menus and requires _DISPLAY to be placed in calling loop.
pop.FixMenuT = 13
pop.FixMenuL = 10
pop.MarginRt = 4 ' Margin from right side if popup. Popup elements will be limited to this point of indentation.
pop.BoundsLt = 0 ' Popup will not appear further left than this indent value measured as the distance away from the left border of the parent window.
pop.BoundsRt = 0 ' Popup and shadow, if present, will not appear further right than this indent value measured as the distance away from the right border of the parent window.
pop.VSpacing = 2 ' 1 single space with dividers (if harware images on), -1 single space no dividers, 2 double space with dividers, -2 double space no dividers.
pop.Shadow = 1 ' 1 for present or 0 for absent.
c.PageColor = 5 ' _BackgroundColor
c.SkinFrg = 3
c.SkinBkg = 5
c.SkinShadowFrg = 8
c.SkinShadowBkg = 0
c.InputFrg = 0 ' Use 15 for bright white if a black input field background is wanted.
c.InputFrg2 = 6
c.InputBkg = c.PageColor ' Same as page color. Use with hardware highlighting, otherwise use 0 to create a black input field.
c.InputHl = 15
c.InputH2 = 6
c.PopupFrg = 0 ' Available menu item.
c.PopupBkg = 5 ' Popup background. (Same as c.SkinBkg)
c.PopupUnavail = 7 ' Unavailable menu item.
c.PopupShadowBkg = 2 ' Shadow. (Ignore if not present).
c.PopupShadowFrg = 7 ' Characters under shadow.
c.pal1 = 34
c.pal2 = 17
c.pal3 = 63
c.pal4 = 56
Palette c.InputFrg2, c.pal2
Palette c.SkinBkg, c.pal3
Palette c.PopupShadowBkg, c.pal4
MyFormData: ' Name column, name, input row, input column, input length, max length, initial text. Note eof must be lowercase.
Data 3,"Field 1:",2,12,44,250,""
Data 3,"Field 2:",5,12,44,250,""
Data eof
PopupMenuData1: ' eof must be lowercase.
Data Cut.........Ctrl+X,Copy........Ctrl+C,Paste.......Ctrl+V,Clear..........Del,Select All..Ctrl+A
Data Close..........Esc,eof
PopupMenuData2: ' eof must be lowercase.
Data Pete's tremendous! While Steve's just amazing.
Data Four score and 7 years ago was a good time to get out of Germany.
Data The rain in Spain falls mainly on the Hispanic People.
Data "The rain in California falls mainy on the Hispanic people, too."
Data You can't make Halloween fun without breaking a few eggs.
Data What do you get when you cross an elephant with a rhino? Elephino!
Data "When life gives you lemons, make lemonaid."
Data "When life gives you crap, does juicing it really help?"
Data eof
PopupMenuData3:
Data eof
PopupMenuData4:
Data eof
PopupMenuData5:
Data eof
PopupMenuData6:
Data eof
PopupMenuData7:
Data eof
PopupMenuData8:
Data eof
PopupMenuData9:
Data eof
End Sub
Sub Mouse_Keyboard (m As MouseVar, b$)
Static z1
If Len(m.autokey) Then
b$ = Mid$(m.autokey + ",", 1, InStr(m.autokey$ + ",", ",") - 1)
m.autokey = Mid$(m.autokey, InStr(m.autokey$ + ",", ",") + 1) ' Don't add "," tomid$() portion or the last key will always be a comma.
Else
b$ = InKey$
End If
m.prevx = m.x: m.prevy = m.y
If m.mw Then m.mw = 0
While _MouseInput
m.mw = m.mw + _MouseWheel: If m.mw Then m.mw = m.mw \ Abs(m.mw) ' Limit to 1 or -1 for up or down.
Wend
m.x = _MouseX
m.y = _MouseY
If z1 Then If Abs(Timer - z1) > .25 Then z1 = 0: m.clkcnt = 0
Select Case m.lb
Case 2: m.lb = 0 ' Click cycle completed.
Case 1: If _MouseButton(1) = 0 Then m.lb = 2: m.drag = 0: m.ThumbDrag = 0 ' Button released.
Case -1: m.lb = 1 ' Button held down.
Case 0: m.lb = _MouseButton(1)
End Select
Select Case m.rb
Case 2: m.rb = 0 ' Click cycle completed.
Case 1: If _MouseButton(2) = 0 Then m.rb = 2 ' Button released.
Case -1: m.rb = 1 ' Button held down.
Case 0: m.rb = _MouseButton(2)
End Select
Select Case m.mb
Case 2: m.mb = 0 ' Click cycle completed.
Case 1: If _MouseButton(3) = 0 Then m.mb = 2 ' Button released.
Case -1: m.mb = 1 ' Button held down.
Case 0: m.mb = _MouseButton(3)
End Select
If Abs(m.lb) = 1 Then
If m.lb = -1 Then z1 = Timer: m.clkcnt = m.clkcnt + 1
If m.prevx And m.prevx <> m.x Or m.prevy And m.prevy <> m.y Then
If m.x <> m.prevx Then m.drag = Sgn(m.x - m.prevx) ' Prevent zero which can occur if mouse moves off row when being draged horizontally.
End If
End If
If _KeyDown(100301) Then m.caps = -1 Else If m.caps Then m.caps = 0
If _KeyDown(100303) Or _KeyDown(100304) Then m.shift = -1 Else If m.shift Then m.shift = 0
If _KeyDown(100305) Or _KeyDown(100306) Then m.ctrl = -1 Else If m.ctrl Then m.ctrl = 0
If _KeyDown(100307) Or _KeyDown(100308) Then m.alt = -1 Else If m.alt Then m.alt = 0
End Sub
Sub Popup_Menu (t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$)
If pop.Show = 0 Then Exit Sub '===================>
Static initiate, nomi, oldmy, oldmx, myalt
Static menu$(), menu_restrict(), y, x, atmp As String
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If pop.ForceInitiate Then initiate = 0
If initiate = 0 Then
If t.ml = 0 Or t.mr = 0 Or t.mt = 0 Or t.mb = 0 Then
_MessageBox "Configuration Error", "The required variables (t.mt, t.mr, t.mb, and t.ml must be set and passed to this routine to open the popup window.", "error"
System
End If
initiate = 1
in.CurShow = 0: Locate , , in.CurShow ' Hide cursor
nomi = 0: oldmy = 0: oldmx = 0: myalt = 0: pop.MenuHL = 0
pop.hwWindow = 0: pop.Show = 0: pop.Choice = 0
If pop.MenuID = 0 Then pop.MenuID = 1 ' Default.
If t.fw = 0 Then t.fw = _FontWidth: t.fh = _FontHeight
Select Case pop.MenuID
Case 1: Restore PopupMenuData1
Case 2: Restore PopupMenuData2
Case 3: Restore PopupMenuData3
Case 4: Restore PopupMenuData4
Case 5: Restore PopupMenuData5
Case 6: Restore PopupMenuData6
Case 7: Restore PopupMenuData7
Case 8: Restore PopupMenuData8
Case 9: Restore PopupMenuData9
End Select
Do
Read tmp$
If tmp$ = "eof" Then Exit Do
nomi = nomi + 1
ReDim _Preserve menu$(nomi)
menu$(nomi) = tmp$
ReDim menu_restrict(nomi) ' Restrictions.
y = CsrLin: x = Pos(0)
Loop
End If
Do
If t.ScrnResize Then Exit Do ' Force popup to close when resizing app.
mxalt = 0
If b$ = Chr$(0) + "H" Or m.mw = -1 Then
If (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing) > 1 Then
myalt = pop.MenuHL - Abs(pop.VSpacing): mxalt = -1
End If
ElseIf b$ = Chr$(0) + "P" Or m.mw = 1 Then
If pop.MenuHL = 0 Then
myalt = pop.MenuT + 1: mxalt = -1
Else
If (pop.MenuHL - pop.MenuT + 1) \ Abs(pop.VSpacing) < nomi + Abs(Abs(pop.VSpacing) - 2) Then
myalt = pop.MenuHL + Abs(pop.VSpacing): mxalt = -1
End If
End If
ElseIf b$ = Chr$(13) And pop.MenuHL Or m.mb = 2 Then
If menu_restrict((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) = 0 Then
pop.Choice = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
Exit Do
End If
End If
Select Case pop.Show
Case 0, -1 ' Open popup. Note: -1 is used when call comes outside mousebutton event. If inside, just call this sub and zero opens popup.
For i = 1 To nomi
j = Len(menu$(i))
If j > k Then k = j
Next
pop.mwidth = k + pop.MarginRt ' Variable to determine margin spaces from the right of menu.
pop.mheight = nomi * Abs(pop.VSpacing) + 1 ' Add one for the separate border element.
Select Case MenuModel
Case Is > 0 ' Fixed menu to left.
pop.MenuT = pop.FixMenuT: pop.MenuL = pop.FixMenuL: pop.MenuR = pop.MenuL + pop.mwidth: pop.MenuB = pop.MenuT + pop.mheight
Case Is < 0 ' Movable menu.
While _MouseInput: Wend
pop.MenuT = _MouseY + 1 ' One below input line.
pop.MenuL = _MouseX
If pop.MenuT + pop.mheight >= _Height Then pop.MenuT = _Height - pop.mheight - pop.Shadow
If pop.MenuL + pop.mwidth >= t.mr - pop.Shadow Then
pop.MenuL = t.mr - pop.mwidth - pop.BoundsRt - pop.Shadow
ElseIf pop.MenuL <= pop.BoundsLt Then
pop.MenuL = t.ml - 1 + pop.BoundsLt
End If
pop.MenuR = pop.MenuL + pop.mwidth: pop.MenuB = pop.MenuT + pop.mheight
End Select
pop.Show = 1 ' Identifies the menu is open.
PCopy 0, 1
If t.HardwareMenus Then
If pop.hwWindow = 0 Then
vs = (Abs(Abs(pop.VSpacing) - 2)) ' Equals 1 for single space and 0 for double space.
hWth = t.fw \ 2
hHgt = t.fh \ 2
t1 = _NewImage((pop.mwidth + 2) * t.fw, nomi * 3 * t.fh, 32)
_Dest t1
' top bottom left right (mask)
Line (hWth + 1, 0)-(pop.mwidth * t.fw - hWth, hHgt), _RGB32(255, 255, 255), BF
Line (hWth + 1, (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + hHgt - t.fh)-(pop.mwidth * t.fw - hWth, ((i - 1 + vs) * Abs(pop.VSpacing) * t.fh + hHgt - t.fh + hHgt)), _RGB32(255, 255, 255), BF
Line (hWth + 1, 0)-(t.fw, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh), _RGB32(255, 255, 255), BF
Line (pop.mwidth * t.fw - hWth, 0)-(pop.mwidth * t.fw - t.fw, (pop.MenuB - pop.MenuT - (Abs(pop.VSpacing) - 1)) * t.fh), _RGB32(255, 255, 255), BF
If pop.VSpacing > 0 Then
For i = 0 To nomi
If i > 0 And i < nomi Or vs Then
Line (hWth, (i + .5 * vs) * Abs(pop.VSpacing) * t.fh)-(pop.mwidth * t.fw - hWth, (i + .5 * vs) * Abs(pop.VSpacing) * t.fh), _RGB32(0, 0, 0, 32), B
End If
Next
End If
If vs And pop.VSpacing = 1 Then ' Redo right and left mask over divider lines so they do not extend to the edges.
Line (hWth + 1, 0)-(t.fw, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh), _RGB32(255, 255, 255), BF
Line (pop.mwidth * t.fw - hWth, 0)-(pop.mwidth * t.fw - t.fw, (pop.MenuB - pop.MenuT - (Abs(pop.VSpacing) - 1)) * t.fh), _RGB32(255, 255, 255), BF
End If
' top bottom left right (outer border)
Line (hWth, 0)-(pop.mwidth * t.fw - hWth, 0), _RGB32(0, 0, 0, 32), B
Line (t.fw * .5, (i - 1 + vs) * Abs(pop.VSpacing) * t.fh)-((pop.mwidth * t.fw - hWth), (i - 1 + vs) * Abs(pop.VSpacing) * t.fh), _RGB32(0, 0, 0, 32), B
Line (hWth, 0)-(hWth, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh), _RGB32(0, 0, 0, 32), B
Line (pop.mwidth * t.fw - hWth, 0)-(pop.mwidth * t.fw - hWth, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh), _RGB32(0, 0, 0, 32), B
j = 2 ' Make shadow 2 units smaller than font height and width.
Line (pop.mwidth * t.fw - hWth + 1, hHgt)-((pop.mwidth) * t.fw + hWth - j, (pop.MenuB - pop.MenuT + vs) * t.fh - hHgt - j), _RGB32(0, 0, 0, 128), BF
Line (t.fw * 1.5, (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + 1)-((pop.mwidth * t.fw - hWth), (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + hHgt - j), _RGB32(0, 0, 0, 128), BF
pop.hwWindow = _CopyImage(t1, 33)
_FreeImage t1
_Dest 0
End If
Locate pop.MenuT + 1, pop.MenuL
For i = 1 To pop.mheight - 2
Color c.PopupFrg, c.PopupBkg: Locate , pop.MenuL + 1
Print Space$(pop.mwidth - 2)
Next
Else
Locate pop.MenuT, pop.MenuL
Color c.PopupFrg, c.PopupBkg
Print Chr$(218) + String$(pop.mwidth - 2, 196) + Chr$(191)
For i = 1 To pop.mheight - Abs(pop.VSpacing)
Color c.PopupFrg, c.PopupBkg: Locate , pop.MenuL
Print Chr$(179); Space$(pop.mwidth - 2) + Chr$(179);
Color c.PopupShadowBkg, c.PopupShadowFrg: Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Next
Color c.PopupFrg, c.PopupBkg: Locate , pop.MenuL
Print Chr$(192) + String$(pop.mwidth - 2, 196) + Chr$(217);
Color c.PopupShadowBkg, c.PopupShadowFrg: Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Locate , pop.MenuL + 2
For i = 1 To pop.mwidth
Print Chr$(Screen(CsrLin, Pos(0)));
Next
End If
Locate pop.MenuT + 2, pop.MenuL + 2
For i = 0 To nomi - 1
Locate pop.MenuT + 1 + i * Abs(pop.VSpacing), pop.MenuL + 1
If menu_restrict(i + 1) Then Color c.PopupUnavail, c.PopupBkg Else Color c.PopupFrg, c.PopupBkg
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 2) = menu$(i + 1)
Print atmp
Color c.PopupFrg, c.PopupBkg
Locate , pop.MenuL
If t.HardwareMenus = 0 And pop.VSpacing = 2 Then
If i + 1 < nomi Then Print "Ã" + String$(pop.mwidth - 2, Chr$(196)) + "´";
End If
Next
Case 1 ' Popup is present.
If m.rb = -1 Then
If m.y < pop.MenuT Or m.y > pop.MenuB Or m.x < pop.MenuL Or m.x > pop.MenuR Then
Exit Do ' Right click outside popup reopens and moves popup on next sub call when right button = 2.
End If
End If
If mxalt = 0 Then myalt = m.y: mxalt = m.x
If m.y = oldmy And m.x = oldmx And m.lb = 0 Or oldmy = 0 And m.lb = 0 Then
i = 0 ' Prevents mouse on menu that was just opened from highlighting an entry.
Else
i = myalt > pop.MenuT And myalt < pop.MenuB And mxalt > pop.MenuL And mxalt < pop.MenuR
End If
If i Or mxalt = -1 Then
Select Case Abs(pop.VSpacing)
Case 1
i = myalt <> oldmy Or myalt = oldmy And m.x <> oldmx Or pop.MenuHL And m.lb = 2
Case 2
j = (myalt - pop.MenuT) \ Abs(pop.VSpacing): k = (myalt - pop.MenuT) / Abs(pop.VSpacing)
i = j <> k And myalt <> oldmy Or j <> k And myalt = oldmy And m.x <> oldmx Or pop.MenuHL And m.lb = 2
End Select
If i Or mxalt = -1 Then ' Works for odd or even number top margins.
If pop.MenuHL Then ' Remove highlighting from previous hover.
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 2, Len(menu$((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)))) = menu$((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing))
Locate pop.MenuHL, pop.MenuL + 2 - 1
If menu_restrict((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) Then Color c.PopupUnavail, c.PopupBkg Else Color c.PopupFrg, c.PopupBkg
Print atmp
End If
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 2, Len(menu$((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)))) = menu$((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing))
Locate myalt, pop.MenuL + 2 - 1
If menu_restrict((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) Then Color c.PopupBkg, c.PopupUnavail Else Color c.PopupBkg, c.PopupFrg
Print atmp;
Color c.PopupFrg, c.PopupBkg
pop.MenuHL = myalt
End If
If m.lb = 2 Then
If menu_restrict((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) = 0 Then
pop.Choice = (myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
Exit Do
End If
End If
Else
' Toggle close popup menu.
If m.lb = 1 Then
If m.y > pop.MenuT Or m.y < pop.MenuB Or m.x > pop.MenuR Or m.x < pop.MenuL Then Exit Do
End If
End If
If Len(b$) Then
'-----------------------------------------------------------------------------------------------------------
' Valid menu shortcut key list here.
Select Case b$
Case Chr$(0) + "S", Chr$(22), Chr$(24), Chr$(1), Chr$(3): m.autokey = b$: b$ = "": Exit Do
Case Chr$(27): pop.Show = 0: b$ = "": Exit Do ' Simply close popup.
End Select
End If
End Select
If t.HardwareMenus Then _PutImage ((pop.MenuL - 1) * t.fw, (pop.MenuT - 1) * t.fh + t.fh \ 2), pop.hwWindow
pop.ForceInitiate = 0
oldmy = m.y: oldmx = m.x
Locate y, x
Exit Sub ' -------------------------------------------------------->
Loop ' Loop is exited when popup is closed; otherwise we exit the sub from the statement above.
pop.Show = 0
PCopy 1, 0
Color restore_color1, restore_color2
If pop.Choice Then
Locate _Height - 1, 1: Color 15, 1: Print Space$(_Width);
Locate _Height - 1, 2: Print menu$(pop.Choice);
End If
Locate y, x
If b$ = Chr$(27) Then b$ = "" ' Negate b$ so an esc routine will not be preformed in the next subroutine before relooping to the mouse call.
_KeyClear
initiate = 0
End Sub
As time permits, I look forward to adding a fixed menu option.
Pete
Posts: 42
Threads: 7
Joined: Mar 2025
Reputation:
3
12-29-2025, 01:56 AM
(This post was last modified: 12-29-2025, 01:57 AM by CMR.)
Nice work. The F4 menu seems a little janky on my machine, but that could be a linux thing.
![[Image: Screenshot-from-2025-12-28-19-52-01.png]](https://i.ibb.co/Q3639Rqj/Screenshot-from-2025-12-28-19-52-01.png)
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
01-02-2026, 05:50 PM
(This post was last modified: 01-02-2026, 05:52 PM by Pete.)
The Next Installment is here!!!
Okay, I added a fixed menu system, including menu bar choices at the top.
Mouse selection added to the F1-F8 menu choices, too.
Code: (Select All)
Width 90, 36: _Font 16
_ScreenMove 200, 20
Type TextVar
HardwareMenus As Integer ' 0 or 1.
FormStyle As Integer
InptMthd As Integer ' 2 is for creating an input field when csrlin is activated by mouse or keyboard.
mt As Integer
mr As Integer
mb As Integer
ml As Integer
bsTop As Integer
bsRight As Integer
bsBottom As Integer
bsLeft As Integer
noe As Integer
nol As Integer
scr As Integer
oldscr As Integer
wide As Integer
tall As Integer
fw As Integer
fh As Integer
redisplay As Integer
hl As Integer
HlFind As Integer
ScreenEstablished As Integer
ScrnResize As Integer
ScrnResizeW As Integer
ScrnResizeH As Integer
ScrnResizeInputRow As Integer
ScrnResizeInputCol As Integer
RollupEvent As Integer
RollupStatus As Integer
HoldScr As Integer
persistency As Integer ' 1 or 0
UseDefaultDisplay As Integer ' 1 or 0
InputActive As Integer ' Records cursor row.
FieldIndent As Integer ' 0 whole text. 1 Input field only for text after prefix (Ex URL:_________).
redo As Integer
undo As Integer
RedoText As String
UndoText As String
MarkerOn As Integer
marker As Integer
EncodeOn As Integer
remakeIDX As Integer
hideshow As String
AddDelete As Integer ' 1 Add, -1 Delete, or 0 inactive.
OpenInput As Integer ' 1 Open input line pase colon or 2 Open entire input line.
hgltPos1 As Integer
hwUnderlineShow As Integer
hwUnderlineImage As Long
End Type
Dim t As TextVar
Type InputVar
CurStyle As Integer
CurShow As Integer
fld As Integer
mtop As Integer
mleft As Integer
myclose As Integer
mxclose As Integer
hwFieldPresent As Integer
hwFieldFront As Long
hwFieldBack As Long
hwFieldHlMargin As Long
End Type
Dim in As InputVar
Type PopupVar
ForceInitiate As Integer
Show As Integer ' Number of window to show.
CloseReOpen As Integer ' Number of window to show after previous window gets closed.
hwWindow As Long
mwidth As Integer
mheight As Integer
FixMenuT As Integer
FixMenuL As Integer
MenuT As Integer
MenuB As Integer
MenuL As Integer
MenuR As Integer
MenuHL As Integer
MarginRt As Integer
BoundsLt As Integer
BoundsRt As Integer
Shadow As Integer ' 0 or 1.
VSpacing As Integer
Choice As Integer
ChoiceName As String
MenuBar As String
MenuBarLt As String
MenuBarRt As String
MenuBarRow As Integer
MenuModel As Integer
MenuUpdate As Integer
End Type
Dim pop As PopupVar
Type MouseVar
x As Integer
y As Integer
lb As Integer
rb As Integer
mb As Integer
mw As Integer
clkcnt As Integer
caps As Integer
shift As Integer
ctrl As Integer
alt As Integer
prevx As Integer
prevy As Integer
drag As Integer
sbar As Integer
sbRow As Integer
oldsbRow As Integer
ThumbTop As Integer
ThumbSize As Integer
ThumbDrag As Integer
autokey As String
End Type
Dim m As MouseVar
Type ColorVar
pal1 As Integer
pal2 As Integer
pal3 As Integer
pal4 As Integer
PageColor As Integer
SkinFrg As Integer
SkinBkg As Integer
InputFrg As Integer
InputFrg2 As Integer
InputBkg As Integer
InputHl As Integer
InputH2 As Integer
SkinShadowFrg As Integer
SkinShadowBkg As Integer
PopupFrg As Integer
PopupBkg As Integer
PopupUnavail As Integer
PopupShadowFrg As Integer
PopupShadowBkg As Integer
PopupMenuBarFrg As Integer
PopupMenuBarBkg As Integer
FixedMenuFrg As Integer
FixedMenuBkg As Integer
FixedMenuHlFrg As Integer
FixedMenuHlBkg As Integer
FixedMenuScFrg As Integer
End Type
Dim c As ColorVar
Color 7, 1: Cls
User_Defined_Variables t, pop, c
GoSub Menu: MenuID = 1
Do
_Limit 60
If m.rb = -1 And pop.MenuModel = 0 Then getmenu = 1
Mouse_Keyboard m, b$
If m.y >= 3 And m.y <= 8 + 3 Then
If m.lb = -1 Then b$ = Chr$(0) + Chr$(59 + m.y - 3)
End If
If Mid$(b$, 2, 1) >= Chr$(59) And Mid$(b$, 2, 1) <= Chr$(66) Then
If pop.MenuModel = 2 And pop.Show Then
Else
getmenu = 2
Select Case b$
Case Chr$(0) + Chr$(59): t.HardwareMenus = 0: pop.VSpacing = -1: mc = 1
Case Chr$(0) + Chr$(60): t.HardwareMenus = 0: pop.VSpacing = -2: mc = 2
Case Chr$(0) + Chr$(61): t.HardwareMenus = 0: pop.VSpacing = 1: mc = 3
Case Chr$(0) + Chr$(62): t.HardwareMenus = 0: pop.VSpacing = 2: mc = 4
Case Chr$(0) + Chr$(63): t.HardwareMenus = 1: pop.VSpacing = -1: mc = 5
Case Chr$(0) + Chr$(64): t.HardwareMenus = 1: pop.VSpacing = -2: mc = 6
Case Chr$(0) + Chr$(65): t.HardwareMenus = 1: pop.VSpacing = 1: mc = 7
Case Chr$(0) + Chr$(66): t.HardwareMenus = 1: pop.VSpacing = 2: mc = 8
Case Else
If Len(b$) Then Cls: Print Len(b$), b$: End
End Select
End If
End If
Menu_Bar pop, m, c, b$
If getmenu Then
If getmenu = 1 Then
pop.Show = 1: pop.MenuModel = -1
Else
pop.Show = 2: pop.MenuModel = 1: pop.ForceInitiate = 1
End If
getmenu = 0
GoSub Menu
End If
Popup_Menu t, in, pop, m, c, b$
If pop.Choice Then
Sound 1000, .1
Locate _Height - 1, 1: Color 15, 1: Print Space$(_Width);
Locate _Height - 1, 2: Print pop.ChoiceName;
End If
_Display
Loop Until b$ = Chr$(27)
System
Menu:
Color 15, 1: View Print 3 To _Height: Cls 2: View Print
Locate 3, 2
Print "Press F1 for a Single-Spaced No Lines Popup Menu"
Locate , 2
Print "Press F2 for a Double-Spaced No Lines Popup Menu"
Locate , 2
Print "Press F3 for a Single-Spaced Lined Popup Menu"
Locate , 2
Print "Press F4 for a Double-Spaced Lined Popup Menu"
Locate , 2
Print "Press F5 for a Single-Spaced No Lines Hardware Popup Menu"
Locate , 2
Print "Press F6 for a Double-Spaced No Lines Hardware Popup Menu"
Locate , 2
Print "Press F7 for a Single-Spaced Lined Hardware Popup Menu"
Locate , 2
Print "Press F8 for a Double-Spaced Lined Hardware Popup Menu"
Print
Locate , 2
a$ = "Current Menu Type: "
q1 = CsrLin: q2 = Len(a$)
Print a$;
Select Case mc
Case 1: a$ = "Single-Spaced No Lines Popup Menu"
Case 2: a$ = "Double-Spaced No Lines Popup Menu"
Case 3: a$ = "Single-Spaced Lined Popup Menu"
Case 4: a$ = "Double-Spaced Lined Popup Men"
Case 5: a$ = "Single-Spaced No Lines Hardware Popup Menu"
Case 6: a$ = "Double-Spaced No Lines Hardware Popup Menu"
Case 7: a$ = "Single-Spaced Lined Hardware Popup Menu"
Case 0, 8: a$ = "Double-Spaced Lined Hardware Popup Menu"
End Select
Color 14, 1
Print a$ + Space$(14)
Print
Color 1, 3
For i = 1 To 20
Print String$(_Width, Chr$(177))
Next
Color 15, 1
Return
Sub User_Defined_Variables (t As TextVar, pop As PopupVar, c As ColorVar)
t.ml = 1: t.mr = _Width: t.mt = 1: t.mb = _Height
t.HardwareMenus = 1 ' Hardware Acceleration On. Used for Menus and requires _DISPLAY to be placed in calling loop.
pop.MenuBarRow = 1
pop.MenuBarLt = " File Edit View Search"
pop.MenuBarRt = "Help "
c.PopupMenuBarFrg = 0
c.PopupMenuBarBkg = 7
pop.FixMenuT = 15
pop.FixMenuL = 11
pop.MarginRt = 4 ' Margin from right side if popup. Popup elements will be limited to this point of indentation.
pop.BoundsLt = 0 ' Popup will not appear further left than this indent value measured as the distance away from the left border of the parent window.
pop.BoundsRt = 0 ' Popup and shadow, if present, will not appear further right than this indent value measured as the distance away from the right border of the parent window.
pop.VSpacing = 2 ' 1 single space with dividers (if harware images on), -1 single space no dividers, 2 double space with dividers, -2 double space no dividers.
pop.Shadow = 1 ' 1 for present or 0 for absent.
c.PageColor = 1 ' Background color of the page.
c.SkinFrg = 3
c.SkinBkg = 5
c.SkinShadowFrg = 8
c.SkinShadowBkg = 0
c.InputFrg = 0 ' Use 15 for bright white if a black input field background is wanted.
c.InputFrg2 = 6
c.InputBkg = c.PageColor ' Same as page color. Use with hardware highlighting, otherwise use 0 to create a black input field.
c.InputHl = 15
c.InputH2 = 6
c.PopupFrg = 0 ' Available menu item.
c.PopupBkg = 5 ' Popup background. (Same as c.SkinBkg)
c.PopupUnavail = 7 ' Unavailable menu item.
c.PopupShadowBkg = 2 ' Shadow. (Ignore if not present).
c.PopupShadowFrg = 7 ' Characters under shadow.
c.FixedMenuFrg = 0
c.FixedMenuBkg = 7
c.FixedMenuHlFrg = 7
c.FixedMenuHlBkg = 0
c.FixedMenuScFrg = 15
c.pal1 = 34
c.pal2 = 17
c.pal3 = 63
c.pal4 = 56
Palette c.InputFrg2, c.pal2
Palette c.SkinBkg, c.pal3
Palette c.PopupShadowBkg, c.pal4
MyFormData: ' Name column, name, input row, input column, input length, max length, initial text. Note eof must be lowercase.
Data 3,"Field 1:",2,12,44,250,""
Data 3,"Field 2:",5,12,44,250,""
Data eof
RtClkPopupData1: ' eof must be lowercase.
Data Cut.........Ctrl+X,Copy........Ctrl+C,Paste.......Ctrl+V,Clear..........Del,Select All..Ctrl+A
Data Close..........Esc,eof
RtClkPopupData2: ' eof must be lowercase.
Data Pete's tremendous! While Steve's just amazing.
Data Four score and 7 years ago was a good time to get out of Germany.
Data The rain in Spain falls mainly on the Hispanic People.
Data "The rain in California falls mainy on the Hispanic people, too."
Data You can't make Halloween fun without breaking a few eggs.
Data What do you get when you cross an elephant with a rhino? Elephino!
Data "When life gives you lemons, make lemonaid."
Data "When life gives you crap, does juicing it really help?"
Data eof
PopupMenuBarData1:
Data Open......Ctrl+O
Data Save......Ctrl+S
Data Save As...Ctrl+A
Data Exit
Data eof
PopupMenuBarData2:
Data Cut.........Ctrl+X,Copy........Ctrl+C,Paste.......Ctrl+V,Clear..........Del,Select All..Ctrl+A
Data Close..........Esc,eof
Data eof
PopupMenuBarData3:
Data Subs....................F2
Data Line Numbers............F4
Data Compiler Warnings...Ctrl+W
Data eof
PopupMenuBarData4:
Data Find...................Ctrl+F3
Data Repeat Last Find......Shift+F3
Data Change..................Alt+F3
Data Clear Search History....Alt+Lt
Data Add / Remove Bookmark...Alt+Rt
Data Previous Bookmark.......Alt+Dn
Data Go To Line..............Ctrl+G
Data eof
PopupMenuBarData5:
Data View...Shift+F1
Data About...Shift+A
Data eof
PopupMenuBarData6:
Data eof
PopupMenuBarData7:
Data eof
PopupMenuBarData8:
Data eof
PopupMenuBarData9:
Data eof
End Sub
Sub Mouse_Keyboard (m As MouseVar, b$)
Static z1
If Len(m.autokey) Then
b$ = Mid$(m.autokey + ",", 1, InStr(m.autokey$ + ",", ",") - 1)
m.autokey = Mid$(m.autokey, InStr(m.autokey$ + ",", ",") + 1) ' Don't add "," tomid$() portion or the last key will always be a comma.
Else
b$ = InKey$
End If
m.prevx = m.x: m.prevy = m.y
If m.mw Then m.mw = 0
While _MouseInput
m.mw = m.mw + _MouseWheel: If m.mw Then m.mw = m.mw \ Abs(m.mw) ' Limit to 1 or -1 for up or down.
Wend
m.x = _MouseX
m.y = _MouseY
If z1 Then If Abs(Timer - z1) > .25 Then z1 = 0: m.clkcnt = 0
Select Case m.lb
Case 2: m.lb = 0 ' Click cycle completed.
Case 1: If _MouseButton(1) = 0 Then m.lb = 2: m.drag = 0: m.ThumbDrag = 0 ' Button released.
Case -1: m.lb = 1 ' Button held down.
Case 0: m.lb = _MouseButton(1)
End Select
Select Case m.rb
Case 2: m.rb = 0 ' Click cycle completed.
Case 1: If _MouseButton(2) = 0 Then m.rb = 2 ' Button released.
Case -1: m.rb = 1 ' Button held down.
Case 0: m.rb = _MouseButton(2)
End Select
Select Case m.mb
Case 2: m.mb = 0 ' Click cycle completed.
Case 1: If _MouseButton(3) = 0 Then m.mb = 2 ' Button released.
Case -1: m.mb = 1 ' Button held down.
Case 0: m.mb = _MouseButton(3)
End Select
If Abs(m.lb) = 1 Then
If m.lb = -1 Then z1 = Timer: m.clkcnt = m.clkcnt + 1
If m.prevx And m.prevx <> m.x Or m.prevy And m.prevy <> m.y Then
If m.x <> m.prevx Then m.drag = Sgn(m.x - m.prevx) ' Prevent zero which can occur if mouse moves off row when being draged horizontally.
End If
End If
If _KeyDown(100301) Then m.caps = -1 Else If m.caps Then m.caps = 0
If _KeyDown(100303) Or _KeyDown(100304) Then m.shift = -1 Else If m.shift Then m.shift = 0
If _KeyDown(100305) Or _KeyDown(100306) Then m.ctrl = -1 Else If m.ctrl Then m.ctrl = 0
If _KeyDown(100307) Or _KeyDown(100308) Then m.alt = -1 Else If m.alt Then m.alt = 0
End Sub
Sub Menu_Bar (pop As PopupVar, m As MouseVar, c As ColorVar, b$)
If Len(pop.MenuBarLt) + Len(pop.MenuBarRt) = 0 Then Exit Sub
temp& = _Resize
Static initiate, AltSwitch, altmx, oldmy, oldmx, map$, shortcut$
y = CsrLin: x = Pos(0)
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If initiate = 0 Or temp& Then
If _Width <> _ResizeWidth \ _FontWidth And initiate Then
Width _ResizeWidth \ _FontWidth, _ResizeHeight \ _FontHeight: _Font 16
Color , c.PageColor: Cls
End If
initiate = 1
If pop.MenuBarRow = 0 Then pop.MenuBarRow = 1 ' Default
Color c.PopupMenuBarFrg, c.PopupMenuBarBkg
Locate pop.MenuBarRow, 1: Print Space$(_Width);
Locate pop.MenuBarRow, 1
pop.MenuBar = Space$(_Width)
Mid$(pop.MenuBar, 1) = pop.MenuBarLt
If _Width > Len(RTrim$(pop.MenuBar)) + 3 + Len(pop.MenuBarRt) Then Mid$(pop.MenuBar, Len(pop.MenuBar) - Len(pop.MenuBarRt)) = pop.MenuBarRt
Print pop.MenuBar;
map$ = ""
For i = 1 To _Width
If Mid$(pop.MenuBar, i, 1) <> " " Then
If k = 0 Then shortcut$ = shortcut$ + Mid$(pop.MenuBar, i, 1)
n$ = LTrim$(Str$(j + 1)): k = 1
Else
If k Then j = j + 1: k = 0
n$ = " "
End If
map$ = map$ + n$
Next
oldmy = m.y: oldmx = m.x ' Set so never zero.
Locate y, x
End If
If pop.Choice Then altmx = 0: AltSwitch = 0: pop.Choice = 0
If pop.MenuUpdate Then
pop.MenuUpdate = 0
GoSub Update_Menubar
End If
i = 0
If m.alt And AltSwitch = 0 Then ' Initial alt press.
AltSwitch = 1
If altmx = 0 Then altmx = InStr(map$, "1") Else If pop.Show Then GoSub Close_Pseudo_Menu
b$ = "Menu"
ElseIf m.alt = 0 And AltSwitch = 1 Then AltSwitch = 2 ' Initial alt release. Menu bar is highlighted.
ElseIf m.alt And AltSwitch = 2 Then ' Alt press on highlighted menu bar.
If altmx < 0 Then ' Alt pressed while menu open. Close menu and keep menu bar highlighted.
GoSub Close_Pseudo_Menu
altmx = Abs(altmx): i = altmx
AltSwitch = 1
Else
AltSwitch = 3 ' Advance switch
End If
ElseIf m.alt = 0 And AltSwitch = 3 Then GoSub Redo_Menu_Bar: altmx = 0: AltSwitch = 0 ' Menu bar highlighting is removed whn alt key is released.
End If
If Len(b$) Then
If Len(b$) = 2 And m.alt Then GoSub converter
If InStr(UCase$(shortcut$), UCase$(b$)) Then ' Shortcut key to open menu.
If AltSwitch And AltSwitch <= 2 And altmx > -1 Then ' Menu bar is highlghted without popup menu.
j = InStr(UCase$(shortcut$), UCase$(b$))
altmx = -InStr(map$, Chr$(j + 48))
i = altmx
popit = Abs(i) ' Open popup menu.
End If
ElseIf b$ = Chr$(0) + "M" And altmx Then
j = Asc(Mid$(map$, Abs(altmx), 1)) - 48 + 1
If altmx < 0 Then i = -1 Else i = 1
altmx = InStr(map$, LTrim$(Str$(j))) * i
If altmx = 0 Then altmx = InStr(map$, "1") * i
i = altmx
If altmx < 0 Then popit = Abs(i)
ElseIf b$ = Chr$(0) + "K" And altmx Then
j = Asc(Mid$(map$, Abs(altmx), 1)) - 48 - 1
If altmx < 0 Then i = -1 Else i = 1
altmx = InStr(map$, LTrim$(Str$(j))) * i
If altmx = 0 Then altmx = InStr(map$, Mid$(map$, Len(RTrim$(map$)), 1)) * i
i = altmx
If altmx < 0 Then popit = Abs(i)
ElseIf b$ = Chr$(13) And altmx > 0 Or b$ = Chr$(0) + "P" And altmx > 0 Then
altmx = -altmx: popit = Abs(altmx)
ElseIf b$ = Chr$(27) And altmx Then ' Esc with highlighted menu bar with or without a popup menu open.
b$ = "" ' Negate b$ so it won't affect other sub routines or the main.
If altmx < 0 Then ' Close the popup menu.
GoSub Redo_Menu_Bar: altmx = 0: AltSwitch = 0
GoSub Close_Pseudo_Menu
Else
GoSub Redo_Menu_Bar: altmx = 0: AltSwitch = 0 ' Remove the menu bar highlighting.
End If
End If
End If
Select Case m.lb
Case -1
If m.y = pop.MenuBarRow And Mid$(map$, m.x, 1) <> " " Then
If altmx < 0 Then
GoSub Redo_Menu_Bar: altmx = 0: AltSwitch = 0
GoSub Close_Pseudo_Menu
Else
i = -m.x: popit = -m.x ' Must be negative to allow for m.x location in Open_Menu gosub routine.
End If
End If
Case 0
If altmx Then
If Len(b$) Then
If b$ = "Menu" Then i = altmx
ElseIf m.y = pop.MenuBarRow Then
If oldmx <> m.x Or oldmy <> m.y Then
x$ = Mid$(map$, m.x, 1)
If x$ <> " " And InStr(map$, x$) <> Abs(altmx) Then
i = m.x ' Slide menu bar highlighting.
If altmx < 0 Then i = -i: popit = i ' A popup menu is open so slide it with the bar.
End If
End If
End If
End If
End Select
If i Then
x$ = Mid$(map$, Abs(i), 1)
j = InStr(map$, RTrim$(x$))
k = _InStrRev(map$, x$) + 1 - j
If j <> Abs(altmx) Or m.lb = -1 Or Len(b$) Then
GoSub Redo_Menu_Bar
Color c.FixedMenuHlFrg, c.FixedMenuHlBkg
Locate pop.MenuBarRow, j - 1
Print " " + Mid$(pop.MenuBar, j, k); " ";
If AltSwitch And m.lb = 0 Then
For h = 1 To Len(shortcut$)
a$ = Mid$(shortcut$, h, 1)
If h = Asc(x$) - 48 Then Color c.FixedMenuScFrg, c.FixedMenuHlBkg Else Color c.FixedMenuScFrg, c.FixedMenuBkg
Locate pop.MenuBarRow, InStr(pop.MenuBar, a$)
Print Mid$(shortcut$, h, 1);
Next
End If
altmx = j
If i < 0 Then altmx = -altmx
End If
End If
If popit Then GoSub open_menu
Color restore_color1, restore_color2
Locate y, x
oldmy = m.y: oldmx = m.x
Exit Sub '---------------------------------->
Redo_Menu_Bar:
Color c.PopupMenuBarFrg, c.PopupMenuBarBkg: Locate pop.MenuBarRow, 1: Print pop.MenuBar;
Return
Update_Menubar:
GoSub Redo_Menu_Bar
j = Abs(altmx)
If j Then
x$ = Mid$(map$, j, 1): k = _InStrRev(map$, x$) + 1 - j
Color c.FixedMenuHlFrg, c.FixedMenuHlBkg
Locate pop.MenuBarRow, j - 1
Print " " + Mid$(pop.MenuBar, j, k); " ";
End If
If AltSwitch And m.lb = 0 Then
For h = 1 To Len(shortcut$)
a$ = Mid$(shortcut$, h, 1)
If h = Asc(x$) - 48 Then Color c.FixedMenuScFrg, c.FixedMenuHlBkg Else Color c.FixedMenuScFrg, c.FixedMenuBkg
Locate pop.MenuBarRow, InStr(pop.MenuBar, a$)
Print Mid$(shortcut$, h, 1);
Next
End If
Return
open_menu:
GoSub Redo_Menu_Bar
pop.MenuModel = 2
If popit > 0 Then g = popit Else g = m.x
x$ = Mid$(map$, g, 1)
h = InStr(map$, RTrim$(x$))
pop.Show = Asc(x$) - 48
pop.CloseReOpen = pop.Show
pop.MenuL = Abs(h) - 2
popit = 0
Return
Close_Pseudo_Menu:
pop.Show = -1
Return
converter:
Select Case Asc(Mid$(b$, 2, 1))
Case 30: b$ = "A"
Case 48: b$ = "B"
Case 46: b$ = "C"
Case 32: b$ = "D"
Case 18: b$ = "E"
Case 33: b$ = "F"
Case 34: b$ = "G"
Case 35: b$ = "H"
Case 23: b$ = "I"
Case 36: b$ = "J"
Case 37: b$ = "K"
Case 38: b$ = "L"
Case 50: b$ = "M"
Case 49: b$ = "N"
Case 24: b$ = "O"
Case 25: b$ = "P"
Case 16: b$ = "Q"
Case 19: b$ = "R"
Case 31: b$ = "S"
Case 20: b$ = "T"
Case 22: b$ = "U"
Case 47: b$ = "V"
Case 17: b$ = "W"
Case 45: b$ = "X"
Case 21: b$ = "Y"
Case 44: b$ = "Z"
End Select
Return
End Sub
Sub Popup_Menu (t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$)
Static initiate, nomi, oldmy, oldmx, myalt
Static menu$(), menu_restrict(), y, x, atmp As String
If pop.Show Then
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
y = CsrLin: x = Pos(0)
While -1
If pop.ForceInitiate Then initiate = 0
If initiate = 0 And pop.Show > 0 Then
If t.ml = 0 Or t.mr = 0 Or t.mt = 0 Or t.mb = 0 Then
_MessageBox "Configuration Error", "The required variables (t.mt, t.mr, t.mb, and t.ml must be set and passed to this routine to open the popup window.", "error"
System
End If
initiate = 1
in.CurShow = 0: Locate , , in.CurShow ' Hide cursor
nomi = 0: oldmy = 0: oldmx = 0: myalt = 0: pop.MenuHL = 0
pop.hwWindow = 0: pop.Choice = 0: pop.ChoiceName = ""
If t.fw = 0 Then t.fw = _FontWidth: t.fh = _FontHeight
Select Case pop.MenuModel
Case -1, 1
Select Case pop.Show
Case 1: Restore RtClkPopupData1
Case 2: Restore RtClkPopupData2
End Select
Case 2
Select Case pop.Show
Case 1: Restore PopupMenuBarData1
Case 2: Restore PopupMenuBarData2
Case 3: Restore PopupMenuBarData3
Case 4: Restore PopupMenuBarData4
Case 5: Restore PopupMenuBarData5
Case 6: Restore PopupMenuBarData6
Case 7: Restore PopupMenuBarData7
Case 8: Restore PopupMenuBarData8
Case 9: Restore PopupMenuBarData9
End Select
End Select
Do
Read tmp$
If tmp$ = "eof" Then Exit Do
nomi = nomi + 1
ReDim _Preserve menu$(nomi)
menu$(nomi) = tmp$
ReDim menu_restrict(nomi) ' Restrictions.
Loop
' Open popup.
PCopy 0, 1
For i = 1 To nomi
j = Len(menu$(i))
If j > k Then k = j
Next
pop.mwidth = k + pop.MarginRt ' Variable to determine margin spaces from the right of menu.
pop.mheight = nomi * Abs(pop.VSpacing) + 1 ' Add one for the separate border element.
Select Case pop.MenuModel
Case 2 ' Menu Bar.
pop.MenuT = pop.MenuBarRow + 1
pop.MenuR = pop.MenuL + pop.mwidth: pop.MenuB = pop.MenuT + pop.mheight
If pop.MenuL + pop.mwidth >= t.mr - pop.Shadow Then
pop.MenuL = t.mr - pop.mwidth - pop.BoundsRt - pop.Shadow
ElseIf pop.MenuL <= pop.BoundsLt Then
pop.MenuL = t.ml - 1 + pop.BoundsLt
End If
Case 1 ' Fixed menu to left.
pop.MenuT = pop.FixMenuT: pop.MenuL = pop.FixMenuL: pop.MenuR = pop.MenuL + pop.mwidth: pop.MenuB = pop.MenuT + pop.mheight
Case -1 ' Movable menu.
pop.MenuT = m.y + 1 ' One below input line.
pop.MenuL = m.x
If pop.MenuT + pop.mheight >= _Height Then pop.MenuT = _Height - pop.mheight - pop.Shadow
If pop.MenuL + pop.mwidth >= t.mr - pop.Shadow Then
pop.MenuL = t.mr - pop.mwidth - pop.BoundsRt - pop.Shadow
ElseIf pop.MenuL <= pop.BoundsLt Then
pop.MenuL = t.ml - 1 + pop.BoundsLt
End If
pop.MenuR = pop.MenuL + pop.mwidth: pop.MenuB = pop.MenuT + pop.mheight
End Select
If t.HardwareMenus Then
If pop.hwWindow = 0 Then
vs = (Abs(Abs(pop.VSpacing) - 2)) ' Equals 1 for single space and 0 for double space.
hWth = t.fw \ 2
hHgt = t.fh \ 2
t1 = _NewImage((pop.mwidth + 2) * t.fw, nomi * 3 * t.fh, 32)
_Dest t1
M2adj = t.fh \ 2
If pop.MenuModel = 2 Then
Line (hWth + 1, 0)-(pop.mwidth * t.fw - hWth, t.fh), _RGB32(255, 255, 255), BF
End If
' top bottom left right (mask)
Line (hWth + 1, 0 + M2adj)-(pop.mwidth * t.fw - hWth, hHgt + M2adj), _RGB32(255, 255, 255), BF
Line (hWth + 1, (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + hHgt - t.fh + M2adj)-(pop.mwidth * t.fw - hWth, ((i - 1 + vs) * Abs(pop.VSpacing) * t.fh + hHgt - t.fh + hHgt + M2adj)), _RGB32(255, 255, 255), BF
Line (hWth + 1, 0 + M2adj)-(t.fw, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh + M2adj), _RGB32(255, 255, 255), BF
Line (pop.mwidth * t.fw - hWth, 0 + M2adj)-(pop.mwidth * t.fw - t.fw, (pop.MenuB - pop.MenuT - (Abs(pop.VSpacing) - 1)) * t.fh + M2adj), _RGB32(255, 255, 255), BF
If pop.VSpacing > 0 Then
For i = 0 To nomi
If i > 0 And i < nomi Or vs Then
Line (hWth, (i + .5 * vs) * Abs(pop.VSpacing) * t.fh + M2adj)-(pop.mwidth * t.fw - hWth, (i + .5 * vs) * Abs(pop.VSpacing) * t.fh + M2adj), _RGB32(0, 0, 0, 32), B
End If
Next
End If
If vs And pop.VSpacing = 1 Then ' Redo right and left mask over divider lines so they do not extend to the edges.
Line (hWth + 1, 0 + M2adj)-(t.fw, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh + M2adj), _RGB32(255, 255, 255), BF
Line (pop.mwidth * t.fw - hWth, 0 + M2adj)-(pop.mwidth * t.fw - t.fw, (pop.MenuB - pop.MenuT - (Abs(pop.VSpacing) - 1)) * t.fh + M2adj), _RGB32(255, 255, 255), BF
End If
' top bottom left right (outer border)
If pop.MenuModel <> 2 Then Line (hWth, 0 + M2adj)-(pop.mwidth * t.fw - hWth, 0 + M2adj), _RGB32(0, 0, 0, 32), B
Line (t.fw * .5, (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + M2adj)-((pop.mwidth * t.fw - hWth), (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + M2adj), _RGB32(0, 0, 0, 32), B
Line (hWth, 0 + M2adj)-(hWth, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh + M2adj), _RGB32(0, 0, 0, 32), B
Line (pop.mwidth * t.fw - hWth, 0 + M2adj)-(pop.mwidth * t.fw - hWth, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh + M2adj), _RGB32(0, 0, 0, 32), B
j = 2 ' Make shadow 2 units smaller than font height and width.
Line (pop.mwidth * t.fw - hWth + 1, hHgt)-((pop.mwidth) * t.fw + hWth - j, (pop.MenuB - pop.MenuT + vs) * t.fh - hHgt - j + M2adj), _RGB32(0, 0, 0, 128), BF
Line (t.fw * 1.5, (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + 1 + M2adj)-((pop.mwidth * t.fw - hWth), (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + hHgt - j + M2adj), _RGB32(0, 0, 0, 128), BF
pop.hwWindow = _CopyImage(t1, 33)
_FreeImage t1
_Dest 0
End If
Locate pop.MenuT + 1, pop.MenuL
For i = 1 To pop.mheight - 2
Color c.PopupFrg, c.PopupBkg: Locate , pop.MenuL + 1
Print Space$(pop.mwidth - 2)
Next
Else
Locate pop.MenuT, pop.MenuL
Color c.PopupFrg, c.PopupBkg
Print Chr$(218) + String$(pop.mwidth - 2, 196) + Chr$(191)
For i = 1 To pop.mheight - Abs(pop.VSpacing)
Color c.PopupFrg, c.PopupBkg: Locate , pop.MenuL
Print Chr$(179); Space$(pop.mwidth - 2) + Chr$(179);
Color c.PopupShadowBkg, c.PopupShadowFrg: Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Next
Color c.PopupFrg, c.PopupBkg: Locate , pop.MenuL
Print Chr$(192) + String$(pop.mwidth - 2, 196) + Chr$(217);
Color c.PopupShadowBkg, c.PopupShadowFrg: Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Locate , pop.MenuL + 2
For i = 1 To pop.mwidth
Print Chr$(Screen(CsrLin, Pos(0)));
Next
End If
Locate pop.MenuT + 2, pop.MenuL + 2
For i = 0 To nomi - 1
Locate pop.MenuT + 1 + i * Abs(pop.VSpacing), pop.MenuL + 1
If menu_restrict(i + 1) Then Color c.PopupUnavail, c.PopupBkg Else Color c.PopupFrg, c.PopupBkg
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 2) = menu$(i + 1)
Print atmp
Color c.PopupFrg, c.PopupBkg
Locate , pop.MenuL
If t.HardwareMenus = 0 And pop.VSpacing = 2 Then
If i + 1 < nomi Then Print Chr$(195) + String$(pop.mwidth - 2, Chr$(196)) + Chr$(180); ' Ã ´
End If
Next
Else
If m.lb = 0 And pop.Show > 0 Then initiate = 2
End If
Do
If t.ScrnResize Then Exit Do ' Force popup to close when resizing app.
If pop.Show < 0 Or pop.CloseReOpen Then Exit Do ' Close or close and reopen popup menu.
mxalt = 0
If b$ = Chr$(0) + "H" Or m.mw = -1 Then
If (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing) > 1 Then
myalt = pop.MenuHL - Abs(pop.VSpacing): mxalt = -1
End If
ElseIf b$ = Chr$(0) + "P" Or m.mw = 1 Then
If pop.MenuHL = 0 Then
myalt = pop.MenuT + 1: mxalt = -1
Else
If (pop.MenuHL - pop.MenuT + 1) \ Abs(pop.VSpacing) < nomi + Abs(Abs(pop.VSpacing) - 2) Then
myalt = pop.MenuHL + Abs(pop.VSpacing): mxalt = -1
End If
End If
ElseIf b$ = Chr$(13) And pop.MenuHL Or m.mb = 2 Then
If menu_restrict((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) = 0 Then
pop.Choice = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
Exit Do
End If
End If
' Popup is present.
If m.rb = -1 And pop.MenuModel = -1 Then
If m.y < pop.MenuT Or m.y > pop.MenuB Or m.x < pop.MenuL Or m.x > pop.MenuR Then
Exit Do ' Right click outside popup reopens and moves popup on next sub call when right button = 2.
End If
End If
If mxalt = 0 Then myalt = m.y: mxalt = m.x
If m.y = oldmy And m.x = oldmx And m.lb = 0 Or oldmy = 0 And m.lb = 0 Then
i = 0 ' Prevents mouse on menu that was just opened from highlighting an entry.
Else
i = myalt > pop.MenuT And myalt < pop.MenuB And mxalt > pop.MenuL And mxalt < pop.MenuR
End If
If i Or mxalt = -1 Then
Select Case Abs(pop.VSpacing)
Case 1
i = myalt <> oldmy Or myalt = oldmy And m.x <> oldmx Or pop.MenuHL And m.lb = 2
Case 2
j = (myalt - pop.MenuT) \ Abs(pop.VSpacing): k = (myalt - pop.MenuT) / Abs(pop.VSpacing)
i = j <> k And myalt <> oldmy Or j <> k And myalt = oldmy And m.x <> oldmx Or pop.MenuHL And m.lb = 2
End Select
If i Or mxalt = -1 Then ' Works for odd or even number top margins.
If pop.MenuHL Then ' Remove highlighting from previous hover.
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 2, Len(menu$((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)))) = menu$((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing))
Locate pop.MenuHL, pop.MenuL + 2 - 1
If menu_restrict((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) Then Color c.PopupUnavail, c.PopupBkg Else Color c.PopupFrg, c.PopupBkg
Print atmp
End If
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 2, Len(menu$((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)))) = menu$((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing))
Locate myalt, pop.MenuL + 2 - 1
If menu_restrict((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) Then Color c.PopupBkg, c.PopupUnavail Else Color c.PopupBkg, c.PopupFrg
Print atmp;
Color c.PopupFrg, c.PopupBkg
pop.MenuHL = myalt
End If
If m.lb = 2 Then
If menu_restrict((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) = 0 Then
pop.Choice = (myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
Exit Do
End If
End If
Else
' Toggle close popup menu.
If m.lb = 2 And initiate = 2 Then
If m.y > pop.MenuT Or m.y < pop.MenuB Or m.x > pop.MenuR Or m.x < pop.MenuL Then pop.Choice = -1: Exit Do
End If
End If
If Len(b$) Then
'-----------------------------------------------------------------------------------------------------------
' Valid menu shortcut key list here.
Select Case b$
Case Chr$(0) + "S", Chr$(22), Chr$(24), Chr$(1), Chr$(3): m.autokey = b$: b$ = "": Exit Do
Case Chr$(27): b$ = "": Exit Do ' Simply close popup.
End Select
End If
If t.HardwareMenus Then _PutImage ((pop.MenuL - 1) * t.fw, (pop.MenuT - 1) * t.fh), pop.hwWindow
pop.ForceInitiate = 0
oldmy = m.y: oldmx = m.x
Locate y, x
Exit While ' -------------------------------------------------------->
Loop ' Loop is exited when popup is closed; otherwise we exit the sub from the statement above.
If pop.Choice > 0 Then pop.ChoiceName = menu$(pop.Choice) ' A negative value is created when clicking outside a menu.
pop.Show = 0
If initiate Then
PCopy 1, 0 ' Adding initiate here prevents a pop.Show -1 call that was first positive to open the popup and copy the screen.
If pop.MenuModel = 2 Then pop.MenuUpdate = 1 ' For Menubar only.
End If
Color restore_color1, restore_color2
Locate y, x
If b$ = Chr$(27) Then b$ = "" ' Negate b$ so an esc routine will not be preformed in the next subroutine before relooping to the mouse call.
_KeyClear
initiate = 0
If pop.CloseReOpen Then
pop.Show = pop.CloseReOpen: pop.CloseReOpen = 0
Else
pop.Show = 0: pop.MenuModel = 0
Exit While
End If
Wend
End If
End Sub
To make the demo easy, the top menu bar works the same as the one in the QB64 IDE.
Note: The shortcut keys inside each menu are not supported, yet.
Yes, you can press Alt + E, etc. to open the Edit selection, mouse slide with a menu bar menu open to the next selection like File menu to Edit menu and the menu will update as you slide. Arrow keys, Enter, etc., same as the QB4 IDE. Alt highlights the menu bar, afterwhich a shortcut key can be pressed. Right click (with menubar menu closed) to get a floating popup like the ones we use for cut, copy, paste.
@CMR Yeah, that's a Linux thing. Linux doesn't process the extended ASCII characters like Windows. I replaced them with CHR$(195) and CHR$(180), so unless I missed some others, it should display correctly in Linux, now. +1 for the report, I don't have a Linux system to test on.
Pete
Posts: 53
Threads: 11
Joined: Jun 2024
Reputation:
3
Works well in Linux Mint (with the Xfce desktop).
Great job, Pete, thanks for sharing.
Rudy M
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
Well I probably shouldn't code while watching the playoffs, but...
Code: (Select All)
$Resize:On
_ScreenMove 200, 20
Type TextVar
HardwareMenus As Integer ' 0 or 1.
FormStyle As Integer
InptMthd As Integer ' 2 is for creating an input field when csrlin is activated by mouse or keyboard.
mt As Integer
mr As Integer
mb As Integer
ml As Integer
bsTop As Integer
bsRight As Integer
bsBottom As Integer
bsLeft As Integer
noe As Integer
nol As Integer
scr As Integer
oldscr As Integer
wide As Integer
tall As Integer
fw As Integer
fh As Integer
redisplay As Integer
hl As Integer
HlFind As Integer
ScreenEstablished As Integer
ScrnW As Integer
ScrnH As Integer
ScrnResize As Integer
ScrnResizeMinW As Integer
ScrnResizeMinH As Integer
ScrnResizeInputRow As Integer
ScrnResizeInputCol As Integer
RollupEvent As Integer
RollupStatus As Integer
HoldScr As Integer
persistency As Integer ' 1 or 0
UseDefaultDisplay As Integer ' 1 or 0
InputActive As Integer ' Records cursor row.
FieldIndent As Integer ' 0 whole text. 1 Input field only for text after prefix (Ex URL:_________).
redo As Integer
undo As Integer
RedoText As String
UndoText As String
MarkerOn As Integer
marker As Integer
EncodeOn As Integer
remakeIDX As Integer
hideshow As String
AddDelete As Integer ' 1 Add, -1 Delete, or 0 inactive.
OpenInput As Integer ' 1 Open input line pase colon or 2 Open entire input line.
hgltPos1 As Integer
hwUnderlineShow As Integer
hwUnderlineImage As Long
End Type
Dim t As TextVar
Type InputVar
CurStyle As Integer
CurShow As Integer
fld As Integer
mtop As Integer
mleft As Integer
myclose As Integer
mxclose As Integer
hwFieldPresent As Integer
hwFieldFront As Long
hwFieldBack As Long
hwFieldHlMargin As Long
End Type
Dim in As InputVar
Type PopupVar
ForceInitiate As Integer
Show As Integer ' Number of window to show.
CloseReOpen As Integer ' Number of window to show after previous window gets closed.
hwWindow As Long
mwidth As Integer
mheight As Integer
FixMenuT As Integer
FixMenuL As Integer
MenuT As Integer
MenuB As Integer
MenuL As Integer
MenuR As Integer
MenuHL As Integer
MarginRt As Integer
BoundsLt As Integer
BoundsRt As Integer
Shadow As Integer ' 0 or 1.
VSpacing As Integer
Choice As Integer
ChoiceName As String
MenuBar As String
MenuBarLt As String
MenuBarRt As String
MenuBarRow As Integer
MenuModel As Integer
End Type
Dim pop As PopupVar
Type MouseVar
x As Integer
y As Integer
lb As Integer
rb As Integer
mb As Integer
mw As Integer
clkcnt As Integer
caps As Integer
shift As Integer
ctrl As Integer
alt As Integer
AltSwitch As Integer
prevx As Integer
prevy As Integer
drag As Integer
sbar As Integer
sbRow As Integer
oldsbRow As Integer
ThumbTop As Integer
ThumbSize As Integer
ThumbDrag As Integer
autokey As String
End Type
Dim m As MouseVar
Type ColorVar
pal1 As Integer
pal2 As Integer
pal3 As Integer
pal4 As Integer
PageColor As Integer
SkinFrg As Integer
SkinBkg As Integer
InputFrg As Integer
InputFrg2 As Integer
InputBkg As Integer
InputHl As Integer
InputH2 As Integer
SkinShadowFrg As Integer
SkinShadowBkg As Integer
PopupFrg As Integer
PopupBkg As Integer
PopupUnavail As Integer
PopupShadowFrg As Integer
PopupShadowBkg As Integer
PopupMenuBarFrg As Integer
PopupMenuBarBkg As Integer
FixedMenuFrg As Integer
FixedMenuBkg As Integer
FixedMenuHlFrg As Integer
FixedMenuHlBkg As Integer
FixedMenuScFrg As Integer
End Type
Dim c As ColorVar
Color 7, 1: Cls
User_Defined_Variables t, pop, c
ReDim text$(1)
Do
_Limit 60
ScreenSize t, c
control t, in, pop, m, b$, text$()
Mouse_Keyboard m, b$
Menu_Bar t, pop, m, c, b$
Popup_Menu t, in, pop, m, c, b$, text$()
_Display
Loop Until pop.Show = 0 And b$ = Chr$(27)
System
Sub User_Defined_Variables (t As TextVar, pop As PopupVar, c As ColorVar)
t.ml = 1: t.mr = _Width: t.mt = 1: t.mb = _Height
t.HardwareMenus = 1 ' Hardware Acceleration On. Used for Menus and requires _DISPLAY to be placed in calling loop.
t.ScrnW = 90
t.ScrnH = 36
t.ScrnResizeMinW = 80
t.ScrnResizeMinH = 30
pop.MenuBarRow = 1
pop.MenuBarLt = " File Edit View Search"
pop.MenuBarRt = "Help "
pop.FixMenuT = 15
pop.FixMenuL = 11
pop.MarginRt = 4 ' Margin from right side if popup. Popup elements will be limited to this point of indentation.
pop.BoundsLt = 0 ' Popup will not appear further left than this indent value measured as the distance away from the left border of the parent window.
pop.BoundsRt = 0 ' Popup and shadow, if present, will not appear further right than this indent value measured as the distance away from the right border of the parent window.
pop.VSpacing = 2 ' 1 single space with dividers (if harware images on), -1 single space no dividers, 2 double space with dividers, -2 double space no dividers.
pop.Shadow = 1 ' 1 for present or 0 for absent.
c.PageColor = 1 ' Background color of the page.
c.SkinFrg = 3
c.SkinBkg = 5
c.SkinShadowFrg = 8
c.SkinShadowBkg = 0
c.InputFrg = 0 ' Use 15 for bright white if a black input field background is wanted.
c.InputFrg2 = 6
c.InputBkg = c.PageColor ' Same as page color. Use with hardware highlighting, otherwise use 0 to create a black input field.
c.InputHl = 15
c.InputH2 = 6
c.PopupFrg = 0 ' Available menu item.
c.PopupBkg = 5 ' Popup background. (Same as c.SkinBkg)
c.PopupUnavail = 7 ' Unavailable menu item.
c.PopupShadowBkg = 2 ' Shadow. (Ignore if not present).
c.PopupShadowFrg = 7 ' Characters under shadow.
c.PopupMenuBarFrg = 0
c.PopupMenuBarBkg = 7
c.FixedMenuFrg = 0
c.FixedMenuBkg = 7
c.FixedMenuHlFrg = 7
c.FixedMenuHlBkg = 0
c.FixedMenuScFrg = 15
c.pal1 = 34
c.pal2 = 17
c.pal3 = 63
c.pal4 = 56
Palette c.InputFrg2, c.pal2
Palette c.SkinBkg, c.pal3
Palette c.PopupShadowBkg, c.pal4
MyFormData: ' Name column, name, input row, input column, input length, max length, initial text. Note eof must be lowercase.
Data 3,"Field 1:",2,12,44,250,""
Data 3,"Field 2:",5,12,44,250,""
Data eof
RtClkPopupData1: ' eof must be lowercase.
Data Cut.........Ctrl+X,Copy........Ctrl+C,Paste.......Ctrl+V,Clear.......Delete,Select All..Ctrl+A
Data Close..........Esc,eof
RtClkPopupData2: ' eof must be lowercase.
Data "I only code in QB64 Phoenix, the only BASIC language I need!"
Data "I only code in SCREEN 0 because everthing else is too graphic."
Data "I like to code in FreeBasic, but I hate myself in the morning."
Data "If AI becomes a singularity, QB64 will finally get TYPE arrays."
Data "Typing skills used to be all female related, so why is coding not?"
Data "Good coders copy. Great coders get good coders to code for them."
Data "An ounce of prevention... is Steve's used condom."
Data "We we're doing so well until Pete's mind fell back in the gutter."
Data eof
PopupMenuBarData1:
Data Open......Ctrl+O
Data Save......Ctrl+S
Data Save As...Ctrl+A
Data Exit
Data eof
PopupMenuBarData2:
Data Cut.........Ctrl+X,Copy........Ctrl+C,Paste.......Ctrl+V,Clear.......Delete,Select All..Ctrl+A
Data Close..........Esc,eof
Data eof
PopupMenuBarData3:
Data Subs....................F2
Data Line Numbers............F4
Data Compiler Warnings...Ctrl+W
Data eof
PopupMenuBarData4:
Data Find...................Ctrl+F3
Data Repeat Last Find......Shift+F3
Data Change..................Alt+F3
Data Clear Search History....Alt+Lt
Data Add / Remove Bookmark...Alt+Rt
Data Previous Bookmark.......Alt+Dn
Data Go To Line..............Ctrl+G
Data eof
PopupMenuBarData5:
Data View...Shift+F1
Data About...Shift+A
Data eof
PopupMenuBarData6:
Data eof
PopupMenuBarData7:
Data eof
PopupMenuBarData8:
Data eof
PopupMenuBarData9:
Data eof
End Sub
Sub Mouse_Keyboard (m As MouseVar, b$)
Static z1
If Len(m.autokey) Then
b$ = Mid$(m.autokey + ",", 1, InStr(m.autokey$ + ",", ",") - 1)
m.autokey = Mid$(m.autokey, InStr(m.autokey$ + ",", ",") + 1) ' Don't add "," tomid$() portion or the last key will always be a comma.
Else
b$ = InKey$
End If
m.prevx = m.x: m.prevy = m.y
If m.mw Then m.mw = 0
While _MouseInput
m.mw = m.mw + _MouseWheel: If m.mw Then m.mw = m.mw \ Abs(m.mw) ' Limit to 1 or -1 for up or down.
Wend
m.x = _MouseX
m.y = _MouseY
If z1 Then If Abs(Timer - z1) > .25 Then z1 = 0: m.clkcnt = 0
Select Case m.lb
Case 2: m.lb = 0 ' Click cycle completed.
Case 1: If _MouseButton(1) = 0 Then m.lb = 2: m.drag = 0: m.ThumbDrag = 0 ' Button released.
Case -1: m.lb = 1 ' Button held down.
Case 0: m.lb = _MouseButton(1)
End Select
Select Case m.rb
Case 2: m.rb = 0 ' Click cycle completed.
Case 1: If _MouseButton(2) = 0 Then m.rb = 2 ' Button released.
Case -1: m.rb = 1 ' Button held down.
Case 0: m.rb = _MouseButton(2)
End Select
Select Case m.mb
Case 2: m.mb = 0 ' Click cycle completed.
Case 1: If _MouseButton(3) = 0 Then m.mb = 2 ' Button released.
Case -1: m.mb = 1 ' Button held down.
Case 0: m.mb = _MouseButton(3)
End Select
If Abs(m.lb) = 1 Then
If m.lb = -1 Then z1 = Timer: m.clkcnt = m.clkcnt + 1
If m.prevx And m.prevx <> m.x Or m.prevy And m.prevy <> m.y Then
If m.x <> m.prevx Then m.drag = Sgn(m.x - m.prevx) ' Prevent zero which can occur if mouse moves off row when being draged horizontally.
End If
End If
If _KeyDown(100301) Then m.caps = -1 Else If m.caps Then m.caps = 0
If _KeyDown(100303) Or _KeyDown(100304) Then m.shift = -1 Else If m.shift Then m.shift = 0
If _KeyDown(100305) Or _KeyDown(100306) Then m.ctrl = -1 Else If m.ctrl Then m.ctrl = 0
If _KeyDown(100307) Or _KeyDown(100308) Then m.alt = -1 Else If m.alt Then m.alt = 0
If m.AltSwitch = 4 Then m.AltSwitch = 0 ' Cycle complete.
Select Case m.alt
Case _TRUE
If m.AltSwitch = 0 Then m.AltSwitch = 1 Else If m.AltSwitch = 2 Then m.AltSwitch = 3
Case Else
If m.AltSwitch = 1 Then m.AltSwitch = 2 Else If m.AltSwitch = 3 Then m.AltSwitch = 4
End Select
End Sub
Sub Menu_Bar (t As TextVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$)
If Len(pop.MenuBarLt) + Len(pop.MenuBarRt) = 0 Then Exit Sub
Static initiate, altmx, oldmy, oldmx, pcopyhack, AltBlocker, AltException, map$, shortcut$
y = CsrLin: x = Pos(0)
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If pcopyhack Then i = Abs(pcopyhack): md = 3: GoSub Redo_Menu_Bar: pcopyhack = 0
If pop.MenuModel < 0 Then
If pop.Choice And m.alt Then AltBlocker = 1
If AltException = 0 Then altmx = 0: m.AltSwitch = 0 Else AltException = 0
End If
If initiate = 0 Or t.ScrnResize = 2 Then
initiate = 1
If pop.MenuBarRow = 0 Then pop.MenuBarRow = 1 ' Default
Color c.PopupMenuBarFrg, c.PopupMenuBarBkg
Locate pop.MenuBarRow, 1: Print Space$(_Width);
Locate pop.MenuBarRow, 1
pop.MenuBar = Space$(_Width)
Mid$(pop.MenuBar, 1) = pop.MenuBarLt
If _Width > Len(RTrim$(pop.MenuBar)) + 3 + Len(pop.MenuBarRt) Then Mid$(pop.MenuBar, Len(pop.MenuBar) - Len(pop.MenuBarRt)) = pop.MenuBarRt
Print pop.MenuBar;
map$ = "": j = 0: k = 0
For i = 1 To _Width
If Mid$(pop.MenuBar, i, 1) <> " " Then
If k = 0 Then shortcut$ = shortcut$ + Mid$(pop.MenuBar, i, 1)
n$ = LTrim$(Str$(j + 1)): k = 1
Else
If k Then j = j + 1: k = 0
n$ = " "
End If
map$ = map$ + n$
Next
oldmy = m.y: oldmx = m.x ' Set so never zero.
Locate y, x
End If
i = 0
If AltBlocker = 0 Then
Select Case m.AltSwitch
Case 1
If pop.Show = 0 Then md = 1: GoSub Redo_Menu_Bar
Case 2
If pop.Show = 0 Then
md = 2
' Initial alt release. Menu bar is highlighted.
If altmx = 0 Then altmx = InStr(map$, "1"): b$ = "Menu" Else If pop.Show Then GoSub Close_Pseudo_Menu
End If
Case 3
Case 4
If altmx < 0 Then ' Alt pressed while menu open. Close menu and keep menu bar highlighted.
GoSub Close_Pseudo_Menu
altmx = Abs(altmx): i = altmx: m.AltSwitch = 2: pcopyhack = -Abs(i): AltException = 1
Else
md = 0: GoSub Redo_Menu_Bar: altmx = 0 ' Menu bar highlighting is removed when alt key is released.
End If
End Select
Else
If m.alt = 0 Then AltBlocker = 0: m.AltSwitch = 0: altmx = 0
End If
If Len(b$) Then
If Len(b$) = 2 And m.alt Then GoSub converter
If InStr(UCase$(shortcut$), UCase$(b$)) Then ' Shortcut key to open menu.
If m.AltSwitch And m.AltSwitch <= 2 And altmx > -1 Then ' Menu bar is highlghted without popup menu.
j = InStr(UCase$(shortcut$), UCase$(b$))
altmx = -InStr(map$, Chr$(j + 48)) ' altmx is negative so menu is open.
i = altmx
popit = Abs(i) ' Open popup menu.
End If
ElseIf b$ = Chr$(0) + "M" And altmx Then
j = Asc(Mid$(map$, Abs(altmx), 1)) - 48 + 1
If altmx < 0 Then i = -1 Else i = 1
altmx = InStr(map$, LTrim$(Str$(j))) * i
If altmx = 0 Then altmx = InStr(map$, "1") * i
i = altmx
If altmx < 0 Then popit = Abs(i)
ElseIf b$ = Chr$(0) + "K" And altmx Then
j = Asc(Mid$(map$, Abs(altmx), 1)) - 48 - 1
If altmx < 0 Then i = -1 Else i = 1
altmx = InStr(map$, LTrim$(Str$(j))) * i
If altmx = 0 Then altmx = InStr(map$, Mid$(map$, Len(RTrim$(map$)), 1)) * i
i = altmx
If altmx < 0 Then popit = Abs(i)
ElseIf b$ = Chr$(13) And altmx > 0 Or b$ = Chr$(0) + "P" And altmx > 0 Then
altmx = -altmx: popit = Abs(altmx): i = altmx
ElseIf b$ = Chr$(27) And altmx Then ' Esc with highlighted menu bar with or without a popup menu open.
b$ = "" ' Negate b$ so it won't affect other sub routines or the main.
md = 0
If altmx < 0 Then GoSub Close_Pseudo_Menu
md = 0: GoSub Redo_Menu_Bar: altmx = 0: m.AltSwitch = 0
End If
End If
Select Case m.lb
Case -1
If m.y = pop.MenuBarRow And Mid$(map$, m.x, 1) <> " " And altmx >= 0 Then
i = -m.x: popit = i: altmx = i: m.AltSwitch = 2
ElseIf altmx > 0 Then
md = 0: GoSub Redo_Menu_Bar: altmx = 0: m.AltSwitch = 0
End If
Case 0
If altmx Then
If Len(b$) Then
If b$ = "Menu" Then i = altmx
ElseIf m.y = pop.MenuBarRow Then
If oldmx <> m.x Or oldmy <> m.y Then
x$ = Mid$(map$, m.x, 1)
If x$ <> " " And InStr(map$, x$) <> Abs(altmx) Then
i = m.x
If altmx < 0 Then i = -i: popit = i ' A popup menu is open so slide it with the bar.
End If
End If
End If
End If
End Select
If i Then
If altmx > 0 Then GoSub Redo_Menu_Bar
x$ = Mid$(map$, Abs(i), 1)
j = InStr(map$, RTrim$(x$))
altmx = j: If i < 0 Then altmx = -altmx
End If
If popit Then ' Open a menu.
md = 0: GoSub Redo_Menu_Bar
pcopyhack = Abs(i)
pop.MenuModel = 2
If popit > 0 Then g = popit Else g = m.x
x$ = Mid$(map$, g, 1)
h = InStr(map$, RTrim$(x$))
If pop.Show > 0 Then pop.CloseReOpen = Asc(x$) - 48
pop.Show = Asc(x$) - 48
pop.MenuL = Abs(h) - 2
popit = 0
End If
Color restore_color1, restore_color2
Locate y, x
oldmy = m.y: oldmx = m.x
Exit Sub '---------------------------------->
Redo_Menu_Bar:
If md = 0 Or md = 2 Then
Color c.PopupMenuBarFrg, c.PopupMenuBarBkg: Locate pop.MenuBarRow, 1: Print pop.MenuBar
End If
If md > 1 Then ' Highlight Menu Name.
x$ = Mid$(map$, Abs(i), 1)
j = InStr(map$, RTrim$(x$))
If j <> Abs(altmx) And m.lb = 0 Or Len(b$) Or md = 3 Then
Color c.FixedMenuHlFrg, c.FixedMenuHlBkg
k = _InStrRev(map$, x$) + 1 - j
Locate pop.MenuBarRow, j - 1
Print " " + Mid$(pop.MenuBar, j, k); " ";
End If
End If
If md > 0 And altmx > 0 Then ' Shortcut Menubar.
If pop.Show < 1 Then
For h = 1 To Len(shortcut$)
a$ = Mid$(shortcut$, h, 1)
If Len(x$) Then
If h = Asc(x$) - 48 Then Color c.FixedMenuScFrg, c.FixedMenuHlBkg Else Color c.FixedMenuScFrg, c.FixedMenuBkg
Else
Color c.FixedMenuScFrg, c.FixedMenuBkg
End If
Locate pop.MenuBarRow, InStr(pop.MenuBar, a$)
Print Mid$(shortcut$, h, 1);
Next
End If
End If
Return
Close_Pseudo_Menu:
pop.Show = -1: m.AltSwitch = 0
Return
converter:
g = Asc(Mid$(b$, 2, 1)) - 15
If g >= 1 And g <= 35 Then
x$ = "QWERTYUIOP ASDFGHJKL ZXCVBNM"
b$ = RTrim$(Mid$(x$, g, 1)) ' Cancel if space.
End If
Return
End Sub
Sub Popup_Menu (t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$, text$())
Static initiate, nomi, oldmy, oldmx, myalt, RtClkRedo
Static menu$(), sc$(), menu_restrict(), y, x, atmp As String
Static UcaseKeys$, LcaseKeys$, CtrlKeys$, AltKeys$
If pop.MenuModel < 0 Then pop.MenuModel = 0: pop.Choice = 0 ' Completed cycle.
If m.rb = -1 And pop.MenuModel = 0 Or RtClkRedo Then
RtClkRedo = 0
pop.Show = 1: pop.MenuModel = 3 ' Future: pop.show will have to be set to another variable to determine the popup data to be loaded.
End If
If pop.Show Then
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
y = CsrLin: x = Pos(0)
While -1
If pop.ForceInitiate Then initiate = 0
If initiate = 0 And pop.Show > 0 Then ' Note: pop.Show = -1 will force menu close.
If t.ml = 0 Or t.mr = 0 Or t.mt = 0 Or t.mb = 0 Then
_MessageBox "Configuration Error", "The required variables (t.mt, t.mr, t.mb, and t.ml must be set and passed to this routine to open the popup window.", "error"
System
End If
initiate = 1: _Font 16
in.CurShow = 0: Locate , , in.CurShow ' Hide cursor
nomi = 0: oldmy = 0: oldmx = 0: myalt = 0: pop.MenuHL = 0
pop.hwWindow = 0: pop.ChoiceName = ""
UcaseKeys$ = ",84 F1,85 F2,86 F3,87 F4,88 F5,89 F6,90 F7,91 F8,92 F9,93 F10,133 F11,134 F12,82 Insert,83 Delete,73 PgUp,81 PgDn,71 Home,79 End,75 Lt,72 Up,80 Dn,77 Rt,8 Backspace,126 ~,33 !,64 @,35 #,36 $,37 %,94 ^,38 &,42 *,40 (,41 ),95 _,43 +,81 Q,87 W,69 E,82 R,84 T,89 Y,85 U,73 I,79 O,80 P,123 {,125 },124 |,65 A,83 S,68 D,70 F,71 G,72 H,74 J,75 K,76 L,58 :,34 -Q,90 Z,88 X,67 C,86 V,66 B,78 N,77 M,60 <,62 >,63 ?,32 Space,15 Tab,27 Esc,13 Enter"
LcaseKeys$ = ",59 F1,60 F2,61 F3,62 F4,63 F5,64 F6,65 F7,66 F8,67 F9,68 F10,133 F11,134 F12,82 Insert,83 Delete,73 PgUp,81 PgDn,71 Home,79 End,75 Lt,72 Up,80 Dn,77 Rt,8 Backspace,96 `,49 1,50 2,51 3,52 4,53 5,54 6,55 7,56 8,57 9,48 0,45 -,61 =,113 q,119 w,101 e,114 r,116 t,121 y,117 u,105 i,111 o,112 p,91 [,93 ],92 \,97 a,115 s,100 d,102 f,103 g,104 h,106 j,107 k,108 l,59 ;,39 ',122 z,120 x,99 c,118 v,98 b,110 n,109 m,44 ,,46 .,47 /,32 Space,9 Tab,27 Esc,13 Enter,42 *,43 +" ' Last 2 are for numlock.
CtrlKeys$ = ",94 F1,95 F2,96 F3,97 F4,98 F5,99 F6,100 F7,101 F8,102 F9,103 F10,137 F11,138 F12,146 Insert,147 Delete,132 PgDp,118 PgDn,119 Home,117 End,115 Lt,141 Up,145 Dn,116 Rt,147 Backspace,17 q,23 w,5 e,18 r,20 t,25 y,21 u,9 i,15 o,16 p,1 a,19 s,4 d,6 f,7 g,8 h,10 j,11 k,12 l,26 z,24 x,3 c,22 v,2 b,14 n,13 m,32 Space,0 2,30 6,31 -"
AltKeys$ = ",104 F1,105 F2,106 F3,108 F5,109 F6,110 F7,111 F8,112 F9,113 F10,139 F11,140 F12,162 Insert,163 Delete,153 PgDp,161 PgDn,151 Home,159 End,155 Lt,152 Up,160 Dn,157 Rt,14 Backspace,41 `,120 1,121 2,122 3,123 4,124 5,125 6,126 7,127 8,128 9,129 0,130 -,131 =,16 q,17 w,18 e,19 r,20 t,21 y,22 u,23 i,24 o,25 p,26 [,27 ],43 \,30 a,31 s,32 d,33 f,34 g,35 h,36 j,37 k,38 l,39 ;,40 ',44 z,45 x,46 c,47 v,48 b,49 n,50 m,51 , 52,. 53,/"
If t.fw = 0 Then t.fw = _FontWidth: t.fh = _FontHeight
Select Case pop.MenuModel
Case 1, 3
Select Case pop.Show
Case 1: Restore RtClkPopupData1
Case 2: Restore RtClkPopupData2
End Select
Case 2
Select Case pop.Show
Case 1: Restore PopupMenuBarData1
Case 2: Restore PopupMenuBarData2
Case 3: Restore PopupMenuBarData3
Case 4: Restore PopupMenuBarData4
Case 5: Restore PopupMenuBarData5
Case 6: Restore PopupMenuBarData6
Case 7: Restore PopupMenuBarData7
Case 8: Restore PopupMenuBarData8
Case 9: Restore PopupMenuBarData9
End Select
End Select
Do
Read tmp$
If tmp$ = "eof" Then Exit Do
nomi = nomi + 1
ReDim _Preserve menu$(nomi), sc$(nomi)
menu$(nomi) = tmp$
sc$(nomi) = Chr$(3) + "0" + Chr$(4) + "0" + Chr$(5) + "0" + Space$(10)
x$ = LCase$(Mid$(tmp$, _InStrRev(tmp$, ".") + 1))
If InStr(x$, " ") Then
a$ = ""
For i = 1 To Len(x$)
If Mid$(x$, i, 1) <> " " Then a$ = a$ + Mid$(x$, i, 1)
Next
x$ = a$
End If
If InStr(x$, "shift") Then Mid$(sc$(nomi), 2, 1) = "1"
If InStr(x$, "ctrl") Then Mid$(sc$(nomi), 4, 1) = "1"
If InStr(x$, "alt") Then Mid$(sc$(nomi), 6, 1) = "1"
Mid$(sc$(nomi), 7) = Mid$(x$, _InStrRev("+" + x$, "+"))
Loop
ReDim menu_restrict(nomi) ' Restrictions.
If pop.MenuModel = 3 Then
If text$(in.fld) = "" Then ' Empty input line. Cut/Copy/Paste/Clear/Select All unavilable.
For i = 1 To nomi - 2: menu_restrict(i) = 1: Next
Else
If t.hl = 0 Then ' Unhighlighted text - Cut/Copy/Paste/Clear unavilable. Select All available.
For i = 1 To 4: menu_restrict(i) = 1: Next
End If
End If
If text$(in.fld) = "" Then menu_restrict(5) = 1 ' Cannot Select All on a blank input line.
If Len(_Clipboard$) Then menu_restrict(3) = 0 Else menu_restrict(3) = 1 ' Paste available if clipboard is loaded.
End If
' Open popup.
PCopy 0, 1
For i = 1 To nomi
j = Len(menu$(i))
If j > k Then k = j
Next
pop.mwidth = k + pop.MarginRt ' Variable to determine margin spaces from the right of menu.
pop.mheight = nomi * Abs(pop.VSpacing) + 1 ' Add one for the separate border element.
Select Case pop.MenuModel
Case 1 ' Fixed Menu.
pop.MenuT = pop.FixMenuT: pop.MenuL = pop.FixMenuL: pop.MenuR = pop.MenuL + pop.mwidth: pop.MenuB = pop.MenuT + pop.mheight
Case 2 ' Menu Bar.
pop.MenuT = pop.MenuBarRow + 1
pop.MenuR = pop.MenuL + pop.mwidth: pop.MenuB = pop.MenuT + pop.mheight
If pop.MenuL + pop.mwidth >= t.mr - pop.Shadow Then
pop.MenuL = t.mr - pop.mwidth - pop.BoundsRt - pop.Shadow
ElseIf pop.MenuL <= pop.BoundsLt Then
pop.MenuL = t.ml - 1 + pop.BoundsLt
End If
Case 3 ' Movable Menu.
pop.MenuT = m.y + 1 ' One below input line.
pop.MenuL = m.x
If pop.MenuT + pop.mheight >= _Height Then pop.MenuT = _Height - pop.mheight - pop.Shadow
If pop.MenuL + pop.mwidth >= t.mr - pop.Shadow Then
pop.MenuL = t.mr - pop.mwidth - pop.BoundsRt - pop.Shadow
ElseIf pop.MenuL <= pop.BoundsLt Then
pop.MenuL = t.ml - 1 + pop.BoundsLt
End If
pop.MenuR = pop.MenuL + pop.mwidth: pop.MenuB = pop.MenuT + pop.mheight
End Select
If t.HardwareMenus Then
If pop.hwWindow = 0 Then
vs = (Abs(Abs(pop.VSpacing) - 2)) ' Equals 1 for single space and 0 for double space.
hWth = t.fw \ 2
hHgt = t.fh \ 2
t1 = _NewImage((pop.mwidth + 2) * t.fw, nomi * 3 * t.fh, 32)
_Dest t1
M2adj = t.fh \ 2
If pop.MenuModel = 2 Then
Line (hWth + 1, 0)-(pop.mwidth * t.fw - hWth, t.fh), _RGB32(255, 255, 255), BF
End If
' top bottom left right (mask)
Line (hWth + 1, 0 + M2adj)-(pop.mwidth * t.fw - hWth, hHgt + M2adj), _RGB32(255, 255, 255), BF
Line (hWth + 1, (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + hHgt - t.fh + M2adj)-(pop.mwidth * t.fw - hWth, ((i - 1 + vs) * Abs(pop.VSpacing) * t.fh + hHgt - t.fh + hHgt + M2adj)), _RGB32(255, 255, 255), BF
Line (hWth + 1, 0 + M2adj)-(t.fw, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh + M2adj), _RGB32(255, 255, 255), BF
Line (pop.mwidth * t.fw - hWth, 0 + M2adj)-(pop.mwidth * t.fw - t.fw, (pop.MenuB - pop.MenuT - (Abs(pop.VSpacing) - 1)) * t.fh + M2adj), _RGB32(255, 255, 255), BF
If pop.VSpacing > 0 Then
For i = 0 To nomi
If i > 0 And i < nomi Or vs Then
Line (hWth, (i + .5 * vs) * Abs(pop.VSpacing) * t.fh + M2adj)-(pop.mwidth * t.fw - hWth, (i + .5 * vs) * Abs(pop.VSpacing) * t.fh + M2adj), _RGB32(0, 0, 0, 32), B
End If
Next
End If
If vs And pop.VSpacing = 1 Then ' Redo right and left mask over divider lines so they do not extend to the edges.
Line (hWth + 1, 0 + M2adj)-(t.fw, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh + M2adj), _RGB32(255, 255, 255), BF
Line (pop.mwidth * t.fw - hWth, 0 + M2adj)-(pop.mwidth * t.fw - t.fw, (pop.MenuB - pop.MenuT - (Abs(pop.VSpacing) - 1)) * t.fh + M2adj), _RGB32(255, 255, 255), BF
End If
' top bottom left right (outer border)
If pop.MenuModel <> 2 Then Line (hWth, 0 + M2adj)-(pop.mwidth * t.fw - hWth, 0 + M2adj), _RGB32(0, 0, 0, 32), B
Line (t.fw * .5, (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + M2adj)-((pop.mwidth * t.fw - hWth), (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + M2adj), _RGB32(0, 0, 0, 32), B
Line (hWth, 0 + M2adj)-(hWth, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh + M2adj), _RGB32(0, 0, 0, 32), B
Line (pop.mwidth * t.fw - hWth, 0 + M2adj)-(pop.mwidth * t.fw - hWth, (pop.MenuB - pop.MenuT - 1 + vs) * t.fh + M2adj), _RGB32(0, 0, 0, 32), B
j = 2 ' Make shadow 2 units smaller than font height and width.
Line (pop.mwidth * t.fw - hWth + 1, hHgt)-((pop.mwidth) * t.fw + hWth - j, (pop.MenuB - pop.MenuT + vs) * t.fh - hHgt - j + M2adj), _RGB32(0, 0, 0, 128), BF
Line (t.fw * 1.5, (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + 1 + M2adj)-((pop.mwidth * t.fw - hWth), (i - 1 + vs) * Abs(pop.VSpacing) * t.fh + hHgt - j + M2adj), _RGB32(0, 0, 0, 128), BF
pop.hwWindow = _CopyImage(t1, 33)
_FreeImage t1
_Dest 0
End If
Locate pop.MenuT + 1, pop.MenuL
For i = 1 To pop.mheight - 2
Color c.PopupFrg, c.PopupBkg: Locate , pop.MenuL + 1
Print Space$(pop.mwidth - 2)
Next
Else
Locate pop.MenuT, pop.MenuL
Color c.PopupFrg, c.PopupBkg
Print Chr$(218) + String$(pop.mwidth - 2, 196) + Chr$(191)
For i = 1 To pop.mheight - Abs(pop.VSpacing)
Color c.PopupFrg, c.PopupBkg: Locate , pop.MenuL
Print Chr$(179); Space$(pop.mwidth - 2) + Chr$(179);
Color c.PopupShadowBkg, c.PopupShadowFrg: Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Next
Color c.PopupFrg, c.PopupBkg: Locate , pop.MenuL
Print Chr$(192) + String$(pop.mwidth - 2, 196) + Chr$(217);
Color c.PopupShadowBkg, c.PopupShadowFrg: Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Locate , pop.MenuL + 2
For i = 1 To pop.mwidth
Print Chr$(Screen(CsrLin, Pos(0)));
Next
End If
Locate pop.MenuT + 2, pop.MenuL + 2
For i = 0 To nomi - 1
Locate pop.MenuT + 1 + i * Abs(pop.VSpacing), pop.MenuL + 1
If menu_restrict(i + 1) Then Color c.PopupUnavail, c.PopupBkg Else Color c.PopupFrg, c.PopupBkg
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 2) = menu$(i + 1)
Print atmp
Color c.PopupFrg, c.PopupBkg
Locate , pop.MenuL
If t.HardwareMenus = 0 And pop.VSpacing = 2 Then
If i + 1 < nomi Then Print Chr$(195) + String$(pop.mwidth - 2, Chr$(196)) + Chr$(180); ' Ã ´
End If
Next
Else
If m.lb = 0 And pop.Show > 0 Then initiate = 2
End If
Do
If t.ScrnResize = 1 Then pop.Choice = -1: Exit Do ' Force popup to close when resizing app.
If pop.Show < 0 Or pop.CloseReOpen Then Exit Do ' Close or close and reopen popup menu. Ex: pop.show = -1
mxalt = 0
If b$ = Chr$(0) + "H" Or m.mw = -1 Then
If (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing) > 1 Then
myalt = pop.MenuHL - Abs(pop.VSpacing): mxalt = -1
End If
ElseIf b$ = Chr$(0) + "P" Or m.mw = 1 Then
If pop.MenuHL = 0 Then
myalt = pop.MenuT + 1: mxalt = -1
Else
If (pop.MenuHL - pop.MenuT + 1) \ Abs(pop.VSpacing) < nomi + Abs(Abs(pop.VSpacing) - 2) Then
myalt = pop.MenuHL + Abs(pop.VSpacing): mxalt = -1
End If
End If
ElseIf b$ = Chr$(13) And pop.MenuHL Or m.mb = 2 Then
If menu_restrict((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) = 0 Then
pop.Choice = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
Exit Do
End If
ElseIf b$ = Chr$(27) Then Exit Do
End If
' Popup is present.
If m.rb = -1 And pop.MenuModel = 3 And RtClkRedo = 0 Then
If m.y < pop.MenuT Or m.y > pop.MenuB Or m.x < pop.MenuL Or m.x > pop.MenuR Then
RtClkRedo = _TRUE
Exit Do ' Right click outside popup reopens and moves popup on next sub call when right button = 2.
End If
End If
If mxalt = 0 Then myalt = m.y: mxalt = m.x
If m.y = oldmy And m.x = oldmx And m.lb = 0 Or oldmy = 0 And m.lb = 0 Then
i = 0 ' Prevents mouse on menu that was just opened from highlighting an entry.
Else
i = myalt > pop.MenuT And myalt < pop.MenuB And mxalt > pop.MenuL And mxalt < pop.MenuR
End If
If i Or mxalt = -1 Then
Select Case Abs(pop.VSpacing)
Case 1
i = myalt <> oldmy Or myalt = oldmy And m.x <> oldmx Or pop.MenuHL And m.lb = 2
Case 2
j = (myalt - pop.MenuT) \ Abs(pop.VSpacing): k = (myalt - pop.MenuT) / Abs(pop.VSpacing)
i = j <> k And myalt <> oldmy Or j <> k And myalt = oldmy And m.x <> oldmx Or pop.MenuHL And m.lb = 2
End Select
If i Or mxalt = -1 Then ' Works for odd or even number top margins.
If pop.MenuHL Then ' Remove highlighting from previous hover.
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 2, Len(menu$((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)))) = menu$((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing))
Locate pop.MenuHL, pop.MenuL + 2 - 1
If menu_restrict((pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) Then Color c.PopupUnavail, c.PopupBkg Else Color c.PopupFrg, c.PopupBkg
Print atmp
End If
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 2, Len(menu$((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)))) = menu$((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing))
Locate myalt, pop.MenuL + 2 - 1
If menu_restrict((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) Then Color c.PopupBkg, c.PopupUnavail Else Color c.PopupBkg, c.PopupFrg
Print atmp;
Color c.PopupFrg, c.PopupBkg
pop.MenuHL = myalt
End If
If m.lb = 2 Then
If menu_restrict((myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)) = 0 Then
pop.Choice = (myalt - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
Exit Do
End If
End If
Else
' Toggle close popup menu.
If m.lb = 2 And initiate = 2 Then
If m.y > pop.MenuT Or m.y < pop.MenuB Or m.x > pop.MenuR Or m.x < pop.MenuL Then pop.Choice = -1: Exit Do
End If
End If
If Len(b$) Then
If m.alt Then
x$ = AltKeys$
ElseIf m.ctrl Then x$ = CtrlKeys$
ElseIf m.shift Then x$ = UcaseKeys$ Else x$ = LcaseKeys$
End If
If Len(b$) = 1 Then e$ = LTrim$(Str$(Asc(b$))): seed = InStr(x$, "Arrow Rt") + 8 Else e$ = LTrim$(Str$(Asc(Mid$(b$, 2, 1)))): seed = 0
j = InStr(seed, x$, "," + e$ + " ")
If j Then
key$ = Mid$(x$, j + Len(e$) + 2)
key$ = Mid$(key$, 1, InStr(key$ + ",", ",") - 1)
If m.shift Then
j = InStr("`1234567890-=[]\;',./", key$)
If j Then key$ = Mid$("~!@#$%^&*()_+{}|:'<>?", j, 1): If key$ = "'" Then key$ = Chr$(34)
End If
If key$ = "-Q" Then key$ = Chr$(34) ' Compensate for inability to store a quote mark in a data statement.
End If
For i = 1 To nomi
If m.shift And Mid$(sc$(i), 2, 1) = "1" Or m.shift = 0 And Mid$(sc$(i), 2, 1) = "0" Then
If m.ctrl And Mid$(sc$(i), 4, 1) = "1" Or m.ctrl = 0 And Mid$(sc$(i), 4, 1) = "0" Then
If m.alt And Mid$(sc$(i), 6, 1) = "1" Or m.alt = 0 And Mid$(sc$(i), 6, 1) = "0" Then
If RTrim$(Mid$(sc$(i), 7)) = LCase$(key$) Then
pop.Choice = i: pop.ChoiceName$ = menu$(i): Exit Do
End If
End If
End If
End If
Next i
End If
If t.HardwareMenus Then _PutImage ((pop.MenuL - 1) * t.fw, (pop.MenuT - 1) * t.fh), pop.hwWindow
pop.ForceInitiate = 0
oldmy = m.y: oldmx = m.x
Locate y, x
Exit While ' -------------------------------------------------------->
Loop ' Loop is exited when popup is closed; otherwise we exit the sub from the statement above.
If pop.Choice > 0 Then pop.ChoiceName = menu$(pop.Choice) ' A negative value is created when clicking outside a menu.
pop.Show = 0
If initiate Then
PCopy 1, 0 ' Adding initiate here prevents a pop.Show -1 call that was first positive to open the popup and copy the screen.
End If
Color restore_color1, restore_color2
Locate y, x
If b$ = Chr$(27) Then b$ = "" ' Negate b$ so an esc routine will not be preformed in the next subroutine before relooping to the mouse call.
_KeyClear
initiate = 0
If pop.CloseReOpen Then
pop.Show = pop.CloseReOpen: pop.CloseReOpen = 0 ' Loop back.
Else
pop.MenuModel = -pop.MenuModel
Exit While
End If
Wend
End If
End Sub
Sub control (t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, b$, text$())
Static initiate, seen
If initiate = 0 Or t.ScrnResize = 2 Then
t.HardwareMenus = 1: pop.VSpacing = 2: mc = 8
If t.ScrnResize = 0 Then getmenu = 1
initiate = 1
ReDim text$(1): in.fld = 1: text$(in.fld) = "Test!"
GoSub Menu_Layout
End If
If m.y >= 3 And m.y <= 8 + 3 Then
If m.lb = -1 Then b$ = Chr$(0) + Chr$(59 + m.y - 3)
End If
If Mid$(b$, 2, 1) >= Chr$(59) And Mid$(b$, 2, 1) <= Chr$(66) Then
If pop.MenuModel = 2 And pop.Show Then
Else
getmenu = 1
Select Case b$
Case Chr$(0) + Chr$(59): t.HardwareMenus = 0: pop.VSpacing = -1: mc = 1
Case Chr$(0) + Chr$(60): t.HardwareMenus = 0: pop.VSpacing = -2: mc = 2
Case Chr$(0) + Chr$(61): t.HardwareMenus = 0: pop.VSpacing = 1: mc = 3
Case Chr$(0) + Chr$(62): t.HardwareMenus = 0: pop.VSpacing = 2: mc = 4
Case Chr$(0) + Chr$(63): t.HardwareMenus = 1: pop.VSpacing = -1: mc = 5
Case Chr$(0) + Chr$(64): t.HardwareMenus = 1: pop.VSpacing = -2: mc = 6
Case Chr$(0) + Chr$(65): t.HardwareMenus = 1: pop.VSpacing = 1: mc = 7
Case Chr$(0) + Chr$(66): t.HardwareMenus = 1: pop.VSpacing = 2: mc = 8
End Select
End If
End If
If getmenu Then
pop.Show = 2: pop.MenuModel = 1: pop.ForceInitiate = 1
getmenu = 0
GoSub Menu_Layout
End If
If pop.Choice > 0 Then
Sound 1000, .1
seen = 1
Locate _Height - 1, 1: Color 15, 1: Print Space$(_Width);
Locate _Height - 1, 2: Print "#"; LTrim$(Str$(pop.Choice)); " "; pop.ChoiceName;
If pop.MenuModel = -3 Then
If pop.Choice = 5 Then t.hl = 1 Else t.hl = 0
End If
Else
If pop.Show And seen = 1 Then
Locate _Height - 1, 1: Color 15, 1: Print Space$(_Width);: seen = 0
End If
End If
Exit Sub '===============================>
Menu_Layout:
Color 15, 1: View Print 2 To _Height: Cls 2: View Print
Locate 3, 2
Print "Press F1 for a Single-Spaced No Lines Popup Menu"
Locate , 2
Print "Press F2 for a Double-Spaced No Lines Popup Menu"
Locate , 2
Print "Press F3 for a Single-Spaced Lined Popup Menu"
Locate , 2
Print "Press F4 for a Double-Spaced Lined Popup Menu"
Locate , 2
Print "Press F5 for a Single-Spaced No Lines Hardware Popup Menu"
Locate , 2
Print "Press F6 for a Double-Spaced No Lines Hardware Popup Menu"
Locate , 2
Print "Press F7 for a Single-Spaced Lined Hardware Popup Menu"
Locate , 2
Print "Press F8 for a Double-Spaced Lined Hardware Popup Menu"
Print
Locate , 2
a$ = "Current Menu Type: "
q1 = CsrLin: q2 = Len(a$)
Print a$;
Select Case mc
Case 1: a$ = "Single-Spaced No Lines Popup Menu"
Case 2: a$ = "Double-Spaced No Lines Popup Menu"
Case 3: a$ = "Single-Spaced Lined Popup Menu"
Case 4: a$ = "Double-Spaced Lined Popup Men"
Case 5: a$ = "Single-Spaced No Lines Hardware Popup Menu"
Case 6: a$ = "Double-Spaced No Lines Hardware Popup Menu"
Case 7: a$ = "Single-Spaced Lined Hardware Popup Menu"
Case 0, 8: a$ = "Double-Spaced Lined Hardware Popup Menu"
End Select
Color 14, 1
Print a$ + Space$(14)
Print
Color 1, 3
For i = 1 To 20
Print String$(_Width, Chr$(177))
Next
Color 15, 1
Return
End Sub
Sub ScreenSize (t As TextVar, c As ColorVar)
Static initiate
If t.ScreenEstablished = 0 Then
_Resize On: w = t.ScrnW: h = t.ScrnH
Else
Select Case t.ScrnResize
Case 0
If _ResizeWidth \ _FontWidth <> _Width Or _ResizeHeight \ _FontHeight <> _Height Then
t.ScrnResize = 1: Exit Sub
End If
Case 1
t.ScrnResize = 2: w = _ResizeWidth \ _FontWidth: h = _ResizeHeight \ _FontHeight
Case 2
t.ScrnResize = 0: Exit Sub ' Resize cycle complete.
End Select
End If
If t.ScrnResize = 2 Then
If w < x Then w = 0 ' Prevents the screen from resizing smaller than the current cursor column.
If w < t.ScrnResizeMinW Then w = 0
If h < CsrLin Then h = 0 'Prevents the screen from resizing smaller than the current cursor row.
If h < t.ScrnResizeMinH Then h = 0
End If
If w And h <> 0 Then
Width w, h: _Font 16
t.mr = _Width
Palette c.InputFrg2, c.pal2
Palette c.SkinBkg, c.pal3
Palette c.PopupShadowBkg, c.pal4
Color , c.PageColor: Cls
t.ScreenEstablished = 1: initiate = 1
End If
End Sub
So universal shortcut keys now function with a menu open, but I also want to add all keys in all menus when they are all closed.
Pete
Shoot first and shoot people who ask questions, later.
Posts: 42
Threads: 7
Joined: Mar 2025
Reputation:
3
Everything works great now. I'll have to take a longer look at this sometime and try to figure out how my own menu system failed.
|
