SCREEN 0 with hardware generated dragable popup menu.
To drag: Hold left button down whit mouse cursor at, or slightly avove the first menu item, "cut".
What's neat is the 3-D shadow. It is a proper shadow effect, instead of an approximated simulated effect, which was the best we could do in SCREEN 0, before QB64 evolved into what it is, today.
Right click to open or reopen popup menu.
Use the mouse, wheel, left or middle button, keys, including shortcut keys, etc.
The demo DOES NOT INCLUDE any actions selected.
Edit: Added right click extras to reopen popup at different location or to act as a left click if on a menu item.
Pete
To drag: Hold left button down whit mouse cursor at, or slightly avove the first menu item, "cut".
Code: (Select All)
Dim Shared PopDrg
ReDim Shared text$(0)
Type fields_and_buttons
' Input Types
InputField As Integer
mvar As Integer
mwidth As Integer
mheight As Integer
' Popup Colors
cp2 As Integer ' Popup background.
cp4 As Integer ' Popup shadow.
cp1 As Integer ' Available menu item.
cp3 As Integer ' Unavailable menu item.
End Type
Dim fb As fields_and_buttons
fb_palette fb
Cls , 7
For i = 1 To _Width * (_Height - 1)
j = Int(Rnd * 14) + 1
k = Int(Rnd * 25) + 1
Color j, 7
Print Chr$(k + 96);
Next
Color 0, 7: Locate _Height, 2: Print "Right click to display popup menu.";
ReDim menu$(0)
Do
MyMouse_and_Keyboard act, lb, mb, rb, my, mx, mw, shift%, AltStatus%, AltToggle%, alt%, ctrl%, clkcnt, drag, k&, b$, autokey$
If rb = 2 Then popit = -1
If PopDrg Then If drag = 0 Then PopDrg = -1: popit = -1 Else popit = -1
If popit Then
fb_input_popup fb, menu$(), hl, popit, lb, mb, rb, my, mx, mw, drag, b$
End If
_Display
Loop
Sub fb_input_popup (fb As fields_and_buttons, menu$(), hl, popit, lb, mb, rb, my, mx, mw, drag, b$)
Static initiate, h, nomi, oldmy, oldmx
Static menu_restrict()
Static menu_variety, MenuHL, MenuT, MenuR, MenuB, MenuL, shadowM, hwpop&
menu_variety = 1
y = CsrLin: x = Pos(0)
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
Rem fb.CurShow = 0: Locate , , fb.CurShow ' Hide cursor
If fb.mvar Then
_PutImage ((MenuL - 1) * _FontWidth, (MenuT - 1) * _FontHeight), hwpop&
If MenuHL Then _PutImage (MenuL * _FontWidth, (MenuHL - 1) * _FontHeight), shadowM
End If
If PopDrg > 0 And oldmx = mx And oldmy = my Then Exit Sub
If initiate = 0 Then
initiate = 1
h = 5 ' Variable to determine margin spaces from the right of menu.
Restore PopupMenuData
PopupMenuData: ' eof must be lowercase.
Data Cut.........Ctrl+X,Copy........Ctrl+C,Paste.......Ctrl+V,Clear..........Del,Select All..Ctrl+A
Data Close..........Esc,eof
nomi = 0
Do
Read tmp$
If tmp$ = "eof" Then Exit Do
nomi = nomi + 1
ReDim _Preserve menu$(nomi)
menu$(nomi) = tmp$
Loop
If nomi > _Height - 2 Or Len(menu$(1)) > _Width - 4 Then nomi = 0: initiate = 0: Exit Sub ' Not enough room to open popup.
For i = 1 To nomi ' Determine menu width by largest menu item.
j = Len(menu$(i))
If j > k Then k = j
Next
fb.mwidth = k + h
fb.mheight = nomi * 2 + 1 ' Add one for the separate border element.
End If
Do
If PopDrg < 0 Then
PopDrg = -MenuL
fb.mvar = 0: MenuHL = 0
popit = -1
Else
If drag And oldmx <> mx Or drag And oldmy <> my Then
If my > MenuT - 2 And my < MenuT + 2 And mx >= MenuL And mx <= MenuR Or PopDrg Then
PopDrg = MenuL - (oldmx - mx):
If PopDrg < 1 Then PopDrg = 1 ' Prevents going over left page margin.
fb.mvar = 0
MenuHL = 0
popit = -1 ' Reopens popup in next cycle.
End If
End If
End If
Select Case fb.mvar
Case 0 ' Open popup menu.
fb.mvar = -1 ' Identifies the menu is open.
If PopDrg = 0 Then
ReDim menu_restrict(nomi) ' Restrictions.
If text$(fb.InputField) = "" Then
For i = 1 To nomi - 2: menu_restrict(i) = 1: Next
Else
If hl = 0 Then
For i = 1 To 4: menu_restrict(i) = 1: Next
End If
End If
If Len(_Clipboard$) Then menu_restrict(3) = 0 Else menu_restrict(3) = 1 ' End Restrictions.
MenuT = 1: MenuL = 1: MenuR = MenuL + fb.mwidth: MenuB = MenuT + fb.mheight
t& = _NewImage((fb.mwidth - 1) * _FontWidth, _FontHeight, 32)
_Dest t&
Line (0, 0)-((fb.mwidth - 2) * _FontWidth, _FontHeight), _RGB32(128, 128, 128, 190), BF
shadowM = _CopyImage(t&, 33)
_FreeImage t&
t& = _NewImage((fb.mwidth + 2) * _FontWidth, (fb.mheight + 1) * _FontHeight, 32)
_Dest t&
Line (0, fb.mheight * _FontHeight)-(fb.mwidth * _FontWidth, fb.mheight * _FontHeight), _RGB32(240, 240.240), BF
Line ((fb.mwidth) * _FontWidth, _FontHeight)-((fb.mwidth + 2) * _FontWidth, (fb.mheight + 1) * _FontHeight), _RGB32(0, 0, 0, 50), BF
Line (_FontWidth * 2, (fb.mheight) * _FontHeight)-(fb.mwidth * _FontWidth - 1, (fb.mheight + 1) * _FontHeight), _RGB32(0, 0, 0, 50), BF
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
Locate MenuT, MenuL
Print Chr$(218) + String$(fb.mwidth - 2, 196) + Chr$(191) ' Menu top border.
For i = 1 To fb.mheight - 2
Locate , MenuL
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
Print Chr$(179); Space$(fb.mwidth - 2) + Chr$(179)
Next
Locate , MenuL
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
Print Chr$(192) + String$(fb.mwidth - 2, 196) + Chr$(217); ' Menu bottom border.
For i = 0 To nomi - 1 ' Show menu items.
Locate MenuT + 1 + i * 2, MenuL + 2
If menu_restrict(i + 1) Then
Color _RGB32(128, 128, 128), _RGB32(255, 255, 255)
Else
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
End If
Print menu$(i + 1)
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
Locate , MenuL
If i + 1 < nomi Then Print "Ã" + String$(fb.mwidth - 2, Chr$(196)) + "´";
Next
hwpop& = _CopyImage(t&, 33)
_FreeImage t&
_Dest 0
End If
MenuHL = 0 ' Removes any menu highlighting when using a right click to move menu.
Select Case menu_variety
Case 0 ' Fixed menu to left.
MenuT = 3: MenuL = 1: MenuR = MenuL + fb.mwidth: MenuB = MenuT + fb.mheight
Case 1 ' Movable menu.
Select Case PopDrg
Case Is < 0
MenuL = Abs(PopDrg)
PopDrg = 0 ' Drag cycle completed.
Case Is > 0
MenuT = my
MenuL = PopDrg
Case 0
MenuT = my
MenuL = mx
End Select
If MenuT + fb.mheight > _Height Then MenuT = _Height - fb.mheight ' -1 for shadow.
If MenuL + fb.mwidth >= _Width Then MenuL = _Width - fb.mwidth - 1 ' -1 for shadow.
MenuR = MenuL + fb.mwidth: MenuB = MenuT + fb.mheight
End Select
Case -1 ' Hover or menu actions.
If b$ = Chr$(0) + "H" Or mw = -1 Then ' Keyboard ---------------
If (MenuHL - MenuT + 1) \ 2 > 1 Then
MenuHL = MenuHL - 2
b$ = ""
End If
ElseIf b$ = Chr$(0) + "P" Or mw = 1 Then
If MenuHL = 0 Then
MenuHL = MenuT + 1
Else
If (MenuHL - MenuT + 1) \ 2 < nomi Then
MenuHL = MenuHL + 2
End If
End If
b$ = ""
ElseIf b$ = Chr$(13) And MenuHL Or mb = 2 And MenuHL Then
b$ = ""
If menu_restrict((MenuHL - MenuT + 1) \ 2) = 0 Then
fb.mvar = (MenuHL - MenuT + 1) \ 2
popit = 0
Exit Do
End If ' ----------------------------------------------------
ElseIf Len(b$) Then ' Menu selections by key.
Select Case b$
Case Chr$(0) + "S", Chr$(22), Chr$(24), Chr$(1), Chr$(3): popit = 0: Exit Do
Case Chr$(27): b$ = "": fb.mvar = 0: popit = 0: Exit Do ' Simply close popup.
Case Else: b$ = "" ' Prevents a non-menu response from getting into the input line routine.
End Select ' ------------------------------------------------
Else ' Mouse input.
i = my >= MenuT And my < MenuB And mx > MenuL And mx < MenuR
If my <> oldmy Or mx <> oldmx Or lb = 2 And drag = 0 Or rb = 2 Then
If i Then
hot` = (my - MenuT) \ 2 <> (my - MenuT) / 2 ' Local variable to determine if click is on a menu item or space between.
If hot` Then
If lb = 2 And MenuHL <> my Or rb = 2 And MenuHL <> my Then hot` = 0
MenuHL = my
End If
Else
hot` = 0
End If
End If
End If
If rb = 2 And MenuHL <> my Then
If Not hot` Then ' If inside menu it will go to next condition.
If my <> MenuT Or mx <> MenuL Then ' Reopen only if mouse position has changed.
If Not i Then
fb.mvar = 0: Exit Do ' Right click to close menu and reopen in new location.
End If
End If
End If
End If
If lb = 2 Or rb = 2 Then ' Left mouse click.
If hot` Then ' Get selection if non-restricted.
If menu_restrict((MenuHL - MenuT + 1) \ 2) = 0 Then
fb.mvar = (MenuHL - MenuT + 1) \ 2
popit = 0
End If
Exit Do
Else ' Close popup if click was outside the menu; otherwise click is ignored.
If Not i And rb <> 2 Then ' Never close the popup with a right click.
popit = 0
fb.mvar = 0
End If
Exit Do
End If
End If ' --------------------------------------------------------
End Select
Exit Do
Loop
oldmy = my: oldmx = mx
If popit = 0 Then MenuHL = 0
Color restore_color1, restore_color2
Locate y, x
_KeyClear
Select Case fb.mvar
Case 1: b$ = Chr$(24) ' Cut
Case 2: b$ = Chr$(3) ' Copy
Case 3: b$ = Chr$(22) ' Paste
Case 4: b$ = Chr$(0) + "S" ' Delete
Case 5: b$ = Chr$(1) ' Select All
Case 6 ' Close
End Select
If fb.mvar > 0 Or Len(b$) Then fb.mvar = 0 ' A selection was reported above or by keyboard shortcut.
End Sub
Sub fb_palette (fb As fields_and_buttons)
' Reserved colors 3, 5, 6.
Palette 6, 63 ' Bright white for background uses.
' Popup Colors
fb.cp2 = 6 ' Popup background.
fb.cp4 = 3 ' Popup shadow.
fb.cp1 = 0 ' Available menu item.
fb.cp3 = 7 ' Unavailable menu item.
End Sub
Sub MyMouse_and_Keyboard (act, lb, mb, rb, my, mx, mw, shift%, AltStatus%, AltToggle%, alt%, ctrl%, clkcnt, drag, k&, b$, autokey$)
Dim As Integer oldmw
Static As Integer oldmy, oldmx, mwy, oldmwy
Static z1 As Single
Do
_Limit 60
act = 0
If AltStatus% Then AltStatus% = 0
If Len(autokey$) Then ' Note: Do not exit as mouse buttons may also be going through a cycle when mouse clicks are converted to key entries.
b$ = Mid$(autokey$, 1, InStr(autokey$ + ",", ",") - 1)
autokey$ = Mid$(autokey$, InStr(autokey$ + ",", ",") + 1)
act = 1
Else
k& = _KeyHit
If k& = 100307 Or k& = 100308 Then
AltStatus% = -1
AltToggle% = 1 - AltToggle%
act = 1
Exit Do
End If
If k& > 0 Then
b$ = MKI$(k&)
If Mid$(b$, 2, 1) = Chr$(135) Then b$ = "" ' Keys like like Shift, Ctrl, and Alt.
If Right$(b$, 1) = Chr$(0) Then b$ = Left$(b$, 1)
act = 3
Else
b$ = ""
End If
End If
If z1 Then If Abs(Timer - z1) > .25 Then z1 = 0: clkcnt = 0
If lb > 0 Then If lb = 1 Then lb = -1: act = 1 Else lb = 0: act = -1
If rb > 0 Then If rb = 1 Then rb = -1: act = 1 Else rb = 0: act = -1
If mb > 0 Then If mb = 1 Then mb = -1: act = 1 Else mb = 0: act = -1
While _MouseInput
mwy = mwy + _MouseWheel: act = 1
Wend
my = _MouseY
mx = _MouseX
If lb = -1 Then
If oldmy And oldmx <> mx Or oldmy And oldmy <> my Then
If mx <> oldmx Then drag = Sgn(mx - oldmx) ' Prevent zero which can occur if mouse moves off row when being dragged horizontally.
End If
End If
If drag = 0 Then
If mwy <> oldmw Then
mw = Sgn(mwy - oldmwy): mwy = 0
Else
mw = 0
End If
oldmwy = mwy
If _KeyDown(100303) Or _KeyDown(100304) Then shift% = -1: act = 1 Else If shift% Then shift% = 0
If _KeyDown(100305) Or _KeyDown(100306) Then ctrl% = -1: act = 1 Else If ctrl% Then ctrl% = 0
If _KeyDown(100307) Or _KeyDown(100308) Then alt% = -1: act = 1 Else If alt% Then alt% = 0
If ctrl% Then ' Convert select all, cut, copy, paste.
Select Case LCase$(b$)
Case "a": b$ = Chr$(1)
Case "x": b$ = Chr$(24)
Case "c": b$ = Chr$(3)
Case "v": b$ = Chr$(22)
Case Chr$(0) + "k": b$ = Chr$(0) + "s"
Case Chr$(0) + "m": b$ = Chr$(0) + "t"
End Select
End If
End If
If lb = -1 And _MouseButton(1) = 0 Then
lb = 2: drag = 0: hover = 0: act = 1
ElseIf rb = -1 And _MouseButton(2) = 0 Then
rb = 2: act = 1
ElseIf mb = -1 And _MouseButton(3) = 0 Then
mb = 2: act = 1
End If
If _MouseButton(1) Then
If lb = 0 Then
lb = 1: z1 = Timer: act = 1
clkcnt = clkcnt + 1
End If
ElseIf _MouseButton(2) And rb = 0 Then
rb = 1: act = 1
ElseIf _MouseButton(3) And mb = 0 Then
mb = 1: act = 1
End If
If my <> oldmy Or mx <> oldmx Then act = 2
oldmy = my: oldmx = mx
Exit Do
Loop
End SubWhat's neat is the 3-D shadow. It is a proper shadow effect, instead of an approximated simulated effect, which was the best we could do in SCREEN 0, before QB64 evolved into what it is, today.
Right click to open or reopen popup menu.
Use the mouse, wheel, left or middle button, keys, including shortcut keys, etc.
The demo DOES NOT INCLUDE any actions selected.
Edit: Added right click extras to reopen popup at different location or to act as a left click if on a menu item.
Pete
![[Image: immagine-2025-04-03-002432916.png]](https://i.ibb.co/zHZctCj0/immagine-2025-04-03-002432916.png)