11-25-2025, 07:05 AM
Code: (Select All)
Dim Shared lin4, hwaccel
Type inputvars
initiate As Integer
CurStyle As Integer
CurShow As Integer
hl1 As Integer
hl2 As Integer
fld As Integer
mhovery As Integer
mhoverx As Integer
mtop As Integer
mleft As Integer
myclose As Integer
mxclose As Integer
page_color As Integer
skin_frg As Integer
skin_bkg As Integer
input_frg As Integer
input_bkg As Integer
skin_shadow_frg As Integer
skin_shadow_bkg As Integer
mwidth As Integer
mheight As Integer
PopupStatus As Integer ' 0 or 1
PopupOpen As Integer ' 0 or 1
PopupChoice As Integer
MenuHL As Integer
MenuT As Integer
MenuB As Integer
MenuL As Integer
MenuR As Integer
End Type
Dim mki As inputvars
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
End Type
Dim m As MouseVar
Type TextVar
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
HlFind As Integer
ScreenEstablished As Integer
ScrnResize As Integer
ScrnResizeW As Integer
ScrnResizeH As Integer
rollup As Integer
HoldScr As Integer
persistency As Integer ' 1 or 0
UseDefaultDisplay As Integer ' 1 or 0
EditText As Integer ' -1, 0, or 1
End Type
Dim t As TextVar
Width 82, 25: _Font 16: Color 15, 1: Cls
Palette 2, 56: Palette 5, 63: Palette 6, 17
t.mt = 1: t.mr = _Width: t.mb = _Height: t.ml = 1
t.fw = _FontWidth: t.fh = _FontHeight
a$ = "Right click to display the popup menu... "
For i = 1 To _Height * 2
j = i Mod 13 + 2
If i / 2 <> i \ 2 Then row = row + 1: Locate row, 1
Color j
Print a$;
Next
Color 15
hwaccel = 1
Do
_Limit 60
Msekbd m, b$
If m.rb = -1 Then hwaccel = 1 - hwaccel
If m.rb = 2 Or mki.PopupStatus Then MyInput_PopUp mki, text$(), m, t, b$, hl
If mki.PopupStatus Then
If hwaccel Then
_PutImage ((mki.MenuL - 1) * t.fw, (mki.MenuT - 1) * t.fh + t.fh / 2), lin4
End If
End If
_Display
Loop
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
Sub Msekbd (m As MouseVar, b$)
Static z1
b$ = InKey$
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 MyInput_PopUp (mki As inputvars, text$(), m As MouseVar, t As TextVar, b$, hl)
Static initialize_menu, WinCon.noi, oldmy, cp1, cp2, cp3, cp4, cp5, myalt
Static PopupMarginRt, PopupBoundsLt
Static menu$(), menu_restrict(), y, x, menu_variety, atmp As String
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If initialize_menu = 0 Then
If t.ml = 0 Or t.mr = 0 Or t.mt = 0 Or t.mb = 0 Then
_MessageBox "Configuration Error", "The reuired 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
initialize_menu = 1
mki.CurShow = 0: Locate , , mki.CurShow ' Hide cursor
WinCon.noi = 0: oldmy = 0: menu_variety = 0: myalt = 0: mki.MenuHL = 0
cp1 = 0 ' Available menu item.
cp2 = 5 ' Popup background. (Same as mki.skin_bkg)
cp3 = 7 ' Unavailable menu item.
cp4 = 2 ' Shadow. (Ignore if not present).
cp5 = 7 ' Characters under shadow.
PopupMarginRt = 4 ' Margin from right side if popup. Popup elements will be limited to this point of indentation.
PopupBoundsLt = 0 ' Popup will not appear further left than this indent value measured as the distance away from the left border of the parent window.
PopupBoundsRt = 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.
PopupShadow = 1 ' 1 for present or 0 for absent.
Restore PopupMenuData
Do
Read tmp$
If tmp$ = "eof" Then Exit Do
WinCon.noi = WinCon.noi + 1
ReDim _Preserve menu$(WinCon.noi)
menu$(WinCon.noi) = tmp$
ReDim menu_restrict(WinCon.noi) ' Restrictions.
y = CsrLin: x = Pos(0)
Loop
If text$(mki.fld) = "" Then
For i = 1 To WinCon.noi - 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.
End If
Do
If mki.PopupOpen = -1 Then
If m.y >= mki.MenuT And m.y <= mki.MenuB And m.x >= mki.MenuL And m.x <= mki.MenuR Then
mki.PopupOpen = 1 ' Right click inside menu so it gets negated.
Else
Exit Do ' Another right click made so close and move popup.
End If
End If
mxalt = 0
If b$ = Chr$(0) + "H" Or m.mw = -1 Then
If (mki.MenuHL - mki.MenuT + 1) \ 2 > 1 Then
myalt = mki.MenuHL - 2: mxalt = -1
End If
ElseIf b$ = Chr$(0) + "P" Or m.mw = 1 Then
If mki.MenuHL = 0 Then
myalt = mki.MenuT + 1: mxalt = -1
Else
If (mki.MenuHL - mki.MenuT + 1) \ 2 < WinCon.noi Then
myalt = mki.MenuHL + 2: mxalt = -1
End If
End If
ElseIf b$ = Chr$(13) Or m.mb = 2 Then
If menu_restrict((mki.MenuHL - mki.MenuT + 1) \ 2) = 0 Then
mki.PopupChoice = (mki.MenuHL - mki.MenuT + 1) \ 2
Exit Do
End If
End If
Select Case mki.PopupStatus
Case 0 ' Opens the popup menu.
menu_variety = 1
For i = 1 To WinCon.noi
j = Len(menu$(i))
If j > k Then k = j
Next
mki.mwidth = k + PopupMarginRt ' Variable to determine margin spaces from the right of menu.
mki.mheight = WinCon.noi * 2 + 1 ' Add one for the separate border element.
Select Case menu_variety
Case 0 ' Fixed menu to left.
mki.MenuT = 3: mki.MenuL = 1: mki.MenuR = mki.MenuL + mki.mwidth: mki.MenuB = mki.MenuT + mki.mheight
Case 1 ' Movable menu.
While _MouseInput: Wend
mki.MenuT = _MouseY + 1 ' One below input line.
mki.MenuL = _MouseX
If mki.MenuT + mki.mheight >= _Height Then mki.MenuT = _Height - mki.mheight - PopupShadow
If mki.MenuL + mki.mwidth >= t.mr - PopupShadow Then
mki.MenuL = t.mr - mki.mwidth - PopupBoundsRt - PopupShadow
ElseIf mki.MenuL <= PopupBoundsLt Then
mki.MenuL = t.ml - 1 + PopupBoundsLt
End If
mki.MenuR = mki.MenuL + mki.mwidth: mki.MenuB = mki.MenuT + mki.mheight
End Select
mki.PopupStatus = -1 ' Identifies the menu is open.
PCopy 0, 1
If hwaccel Then
If lin4 = 0 Then
CRed = 120: CGrn = 120: CBlu = 120
t1 = _NewImage((mki.mwidth + 2) * t.fw, WinCon.noi * 3 * t.fh, 32)
_Dest t1
Line (t.fw \ 2, 0)-(mki.mwidth * t.fw - t.fw \ 2, t.fh \ 2), _RGB32(255, 255, 255), BF
Line (t.fw \ 2, (i - 1) * 2 * t.fh + t.fh \ 2 - t.fh)-(mki.mwidth * t.fw - t.fw \ 2, ((i - 1) * 2 * t.fh + t.fh \ 2 - t.fh + 7)), _RGB32(255, 255, 255), BF
Line (t.fw \ 2 + 1, 0)-(t.fw, (mki.MenuB - mki.MenuT - 1) * t.fh), _RGB32(255, 255, 255), BF
Line (mki.mwidth * t.fw - t.fw \ 2, 0)-(mki.mwidth * t.fw - t.fw, (mki.MenuB - mki.MenuT - 1) * t.fh), _RGB32(255, 255, 255), BF
For i = 0 To WinCon.noi
Line (t.fw \ 2, i * 2 * t.fh)-(mki.mwidth * t.fw - t.fw \ 2, i * 2 * t.fh), _RGB32(CRed, CGrn, CBlu), B
Next
Line (t.fw \ 2, 0)-(t.fw \ 2, (mki.MenuB - mki.MenuT - 1) * t.fh), _RGB32(CRed, CGrn, CBlu), B
Line (mki.mwidth * t.fw - t.fw \ 2, 0)-(mki.mwidth * t.fw - t.fw \ 2, (mki.MenuB - mki.MenuT - 1) * t.fh), _RGB32(CRed, CGrn, CBlu), B
Line (mki.mwidth * t.fw - t.fw \ 2 + 1, t.fh \ 2)-((mki.mwidth) * t.fw + t.fw \ 2, (mki.MenuB - mki.MenuT) * t.fh - t.fh \ 2), _RGB32(0, 0, 0, 128), BF
Line (t.fw * 1.5, (i - 1) * 2 * t.fh + 1)-((mki.mwidth * t.fw - t.fw \ 2), (i - 1) * 2 * t.fh + t.fh \ 2), _RGB32(0, 0, 0, 128), BF
lin4 = _CopyImage(t1, 33)
_FreeImage t1
_Dest 0
End If
Locate mki.MenuT + 1, mki.MenuL
For i = 1 To mki.mheight - 2
Color cp1, cp2: Locate , mki.MenuL + 1
Print Space$(mki.mwidth - 2)
Next
Else
Locate mki.MenuT, mki.MenuL
Color cp1, cp2
Print Chr$(218) + String$(mki.mwidth - 2, 196) + Chr$(191)
For i = 1 To mki.mheight - 2
Color cp1, cp2: Locate , mki.MenuL
Print Chr$(179); Space$(mki.mwidth - 2) + Chr$(179);
Color cp5, cp4: Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Next
Color cp1, cp2: Locate , mki.MenuL
Print Chr$(192) + String$(mki.mwidth - 2, 196) + Chr$(217);
Color cp5, cp4: Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Locate , mki.MenuL + 2
For i = 1 To mki.mwidth
Print Chr$(Screen(CsrLin, Pos(0)));
Next
End If
Locate mki.MenuT + 2, mki.MenuL + 2
For i = 0 To WinCon.noi - 1
Locate mki.MenuT + 1 + i * 2, mki.MenuL + 2
If menu_restrict(i + 1) Then Color cp3, cp2 Else Color cp1, cp2
Print menu$(i + 1)
Color cp1, cp2
Locate , mki.MenuL
If hwaccel Then
Else
If i + 1 < WinCon.noi Then Print "Ã" + String$(mki.mwidth - 2, Chr$(196)) + "´";
End If
Next
Case Else ' Popup is present.
If m.rb = -1 Then Exit Do ' Right click when popup is present relocates popup on next sub call when mouse status is right button = 2.
If mxalt = 0 Then myalt = m.y: mxalt = m.x
i = myalt > mki.MenuT And myalt < mki.MenuB And mxalt > mki.MenuL And mxalt < mki.MenuR
If i Or mxalt = -1 Then
i = (myalt - mki.MenuT) \ 2 <> (myalt - mki.MenuT) / 2 And myalt <> oldmy
If i Or mxalt = -1 Then ' Works for odd or even number top margins.
If mki.MenuHL Then ' Remove highlighting from previous hover.
atmp = Space$(mki.mwidth - 2)
Mid$(atmp, 2, Len(menu$((mki.MenuHL - mki.MenuT + 1) \ 2))) = menu$((mki.MenuHL - mki.MenuT + 1) \ 2)
Locate mki.MenuHL, mki.MenuL + 2 - 1
If menu_restrict((mki.MenuHL - mki.MenuT + 1) \ 2) Then Color cp3, cp2 Else Color cp1, cp2
Print atmp
End If
atmp = Space$(mki.mwidth - 2)
Mid$(atmp, 2, Len(menu$((myalt - mki.MenuT + 1) \ 2))) = menu$((myalt - mki.MenuT + 1) \ 2)
Locate myalt, mki.MenuL + 2 - 1
If menu_restrict((myalt - mki.MenuT + 1) \ 2) Then Color cp2, cp3 Else Color cp2, cp1
Print atmp;
Color cp1, cp2
mki.MenuHL = myalt
oldmy = m.y
End If
If m.lb = 2 Then
If menu_restrict((myalt - mki.MenuT + 1) \ 2) = 0 Then
mki.PopupChoice = (myalt - mki.MenuT + 1) \ 2
Exit Do
End If
End If
Else
' Toggle close popup menu.
If m.lb = 1 Then
If m.y > mki.MenuT Or m.y < mki.MenuB Or m.x > mki.MenuR Or m.x < mki.MenuL Then
mki.PopupOpen = 0: Exit Do
End If
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): Exit Do
Case Chr$(27): mki.PopupOpen = 0: Exit Do ' Simply close popup.
End Select
End If
End Select
Locate y, x
Exit Sub
Loop
mki.PopupOpen = 0: mki.PopupStatus = 0
PCopy 1, 0
Color restore_color1, restore_color2
Locate y, x
_KeyClear
initialize_menu = 0
End Sub
Right click to get the popup to appear. Thats a SCREEN 0 example.
Right click again to toggle the hardware accelerated popup. Better, right? Hover, mouse wheel, etc. on either. The size difference and the shadow effects are worth it.
Pete
![[Image: First-Popupmenu.png]](https://i.ibb.co/5gFf6bJY/First-Popupmenu.png)
![[Image: Second-Popupmenu.png]](https://i.ibb.co/wrzM9m17/Second-Popupmenu.png)
