Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
Thanks! I'll probably add more commenting in the code before I add too much more. That should make it easier to follow the code. Most of the stuff I put together, these days, is what I call "Flow-Through" meaning the subs keep passing back to the main, instead of being stuck in any one sub until some action occurs. It's a bit of a challenge to code this way, but I like it.
Hey if you are having any difficulties with your project, you are welcome to post in the "Help Me" forum. Text or graphics, we have enough vets here to work out solutions. I'd say one of the most important things is to figure out ahead of time is the goal of your menu system. If you don't need a great deal of complexity, it may be easier to avoid extra code you won't be using. If, however, you want to grow a routine into something you can use in more complex situations, well, the best advice I have is to make the overall structure first then fill in the rest. No need to make a hundred menu choices with a shaky menu handling routine when you can begin to formulate a solid structure, with say five menu choices, and add other choices when the structure is perfected.
Pete
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
Okay, so what's new today...
Built in menu maker.
The data statements get written with 3 parameters.
1) Name to display in the menu.
2) Shortcut key to display in menu
3) ID
Something like this: Data Cut|Ctrl+X|>Text Cutter
So the program runs and converts that info into...
Cut...Ctrl+X and stores the ID as the string "Text Cutter"
It adds to the clipboard...
Select Case pop.ID
Case "Text Cutter"
End Select
So if we are making a new program we can run it once, without a case selection routine and let the program build the routine for us! All we have to do is paste it from the clipboard into the program.
To turn off this feature, we simply set the MakeMyCase variable to zero.
---------------------------------------
Another addition is a shortcut key routine that recognizes all shortcut keys in all of the menus, so a menu need not be open to preform a shortcut routine. If a menu is open, it limits the choices to those in the menu.
Code: (Select All)
$Resize:On
_ScreenMove 200, 20
ReDim Shared SCopy(100)
Type GlobalVar
anum As Integer
MyScreen As Integer
UcaseKeys As String
LcaseKeys As String
CtrlKeys As String
AltKeys As String
End Type
Dim gbl As GlobalVar
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
ID As String
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 gbl, 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 gbl, t, pop, m, c, b$
Popup_Menu gbl, t, in, pop, m, c, b$, text$()
_Display
Loop Until pop.Show = 0 And b$ = Chr$(27)
System
Sub User_Defined_Variables (gbl As GlobalVar, t As TextVar, pop As PopupVar, c As ColorVar)
Static initiate
If initiate = 0 Then
MakeMyCase = 1 ' Change this to ZERO when your select case gets processed to the clipboard and is pasted in your new program.
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|>Open File
Data Save|Ctrl+S|>Save File
Data Save As|Ctrl+A|>Save As
Data Exit|>Quit
Data eof
PopupMenuBarData2:
Data Cut|Ctrl+X|>Cut
Data Copy|Ctrl+C|>Copy
Data Paste|Ctrl+V|>Paste
Data Clear|Delete|>Clear
Data Select All|Ctrl+A|>Select All
Data Close|Esc|>Close
Data eof
PopupMenuBarData3:
Data Subs|Shift+F2|>View Subs
Data Line Numbers|Shift+F4|>Show Lines
Data Compiler Warnings|Ctrl+W|>Warnings
Data eof
PopupMenuBarData4:
Data Find|Ctrl+F3|>Find
Data Repeat Last Find|Shift+F3|>Repeat Find
Data Change|Alt+F3|>Change
Data Clear Search History|Alt+Lt|>History
Data Add / Remove Bookmark|Alt+Rt|>Remove Bookmark
Data Previous Bookmark|Alt+Dn|>Previous Bookmark
Data Go To Line|Ctrl+G|>Go to LIne
Data eof
PopupMenuBarData5:
Data View|Shift+F1|>View Help
Data About|Shift+A|>About
Data eof
PopupMenuBarData6:
Data eof
PopupMenuBarData7:
Data eof
PopupMenuBarData8:
Data eof
PopupMenuBarData9:
Data eof
gbl.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"
gbl.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.
gbl.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 -"
gbl.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 MakeMyCase Then
Restore PopupMenuBarData1
_Clipboard$ = "Select Case pop.ID" + Chr$(10) + Chr$(13)
Do
Read tmp$
If tmp$ = "eof" Then
cnt = cnt + 1: If cnt = 9 Then x$ = "": a$ = "": tmp$ = "": Exit Do
Else
nomi = nomi + 1
j = InStr(tmp$, "|>") + 2
If j Then
_Clipboard$ = _Clipboard$ + " Case " + Chr$(34) + Mid$(tmp$, j) + Chr$(34) + Chr$(10) + Chr$(13) + Chr$(10) + Chr$(13)
End If
End If
Loop
_Clipboard$ = _Clipboard$ + "End Select"
End If
initiate = 0
End If
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 (gbl As GlobalVar, 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, nomi, map$, shortcut$, sc$(), id$()
y = CsrLin: x = Pos(0): pop.ID = ""
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
Restore PopupMenuBarData1
Do
Read tmp$
If tmp$ = "eof" Then
cnt = cnt + 1: If cnt = 9 Then x$ = "": a$ = "": tmp$ = "": Exit Do
Else
nomi = nomi + 1
ReDim _Preserve sc$(nomi), id$(nomi)
sc$(nomi) = Chr$(3) + "0" + Chr$(4) + "0" + Chr$(5) + "0" + Space$(10)
If InStr(tmp$, "|>") Then
id$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2))
x$ = Mid$(tmp$, 1, InStr(tmp$, "|>") - 1)
Else
x$ = tmp$
End If
If InStr(x$, "|") Then x$ = LCase$(Mid$(x$, InStr(x$, "|") + 1)) Else x$ = ""
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$, "+"))
End If
Loop
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
Else
If pop.Show = 0 Then
If m.alt Then ' Search for a valid shortcut key.
x$ = gbl.AltKeys
ElseIf m.ctrl Then x$ = gbl.CtrlKeys
ElseIf m.shift Then x$ = gbl.UcaseKeys Else x$ = gbl.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 h = 1 To nomi
If m.shift And Mid$(sc$(h), 2, 1) = "1" Or m.shift = 0 And Mid$(sc$(h), 2, 1) = "0" Then
If m.ctrl And Mid$(sc$(h), 4, 1) = "1" Or m.ctrl = 0 And Mid$(sc$(h), 4, 1) = "0" Then
If m.alt And Mid$(sc$(h), 6, 1) = "1" Or m.alt = 0 And Mid$(sc$(h), 6, 1) = "0" Then
If RTrim$(Mid$(sc$(h), 7)) = LCase$(key$) Then
pop.ID = id$(h) ' Valid Shortcut key found.
Exit For
End If
End If
End If
End If
Next h
End If
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 (gbl As GlobalVar, 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$(), id$(), menu_restrict(), y, x, atmp As String
If pop.MenuModel < 0 Then pop.MenuModel = 0: pop.Choice = 0: pop.ChoiceName = "": pop.ID = "" ' 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
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), id$(nomi)
If InStr(tmp$, "|") Then
If InStr(tmp$, "|>") Then id$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2)): tmp$ = _Trim$(Mid$(tmp$, 1, InStr(tmp$, "|>") - 1))
If InStr(tmp$, "|") Then
short$ = _Trim$(Mid$(tmp$, InStr(tmp$, "|") + 1))
tmp$ = Mid$(tmp$, 1, InStr(tmp$, "|") - 1)
End If
x$ = tmp$: If Len(short$) Then x$ = x$ + Chr$(4) + short$
menu$(nomi) = x$: If jj < Len(x$) Then jj = Len(x$)
x$ = "": short$ = ""
Else
menu$(nomi) = tmp$
End If
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
For i = 1 To nomi
If InStr(menu$(i), Chr$(4)) Then
k = jj - Len(menu$(i))
x$ = Mid$(menu$(i), 1, InStr(menu$(i), Chr$(4)) - 1) + String$(k + 3, ".") + Mid$(menu$(i), InStr(menu$(i), Chr$(4)) + 1)
Else
x$ = menu$(i)
End If
menu$(i) = x$
Next
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.
gbl.anum = 1: FreeCopy gbl, SCopy()
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 Then ' This routine is (must be) the same for m.lb = 2.
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)
pop.ID = id$(pop.Choice)
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 ' This routien is (must be) the same as b$ = Enter.
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)
pop.ID = id$(pop.Choice)
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$ = gbl.AltKeys
ElseIf m.ctrl Then x$ = gbl.CtrlKeys
ElseIf m.shift Then x$ = gbl.UcaseKeys Else x$ = gbl.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): pop.ID = id$(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 ' Adding initiate here prevents a pop.Show -1 call that was first positive to open the popup and copy the screen.
gbl.anum = -1: FreeCopy gbl, SCopy()
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 Len(pop.ID) Then
Sound 1000, .1
Select Case pop.ID
Case "Open File"
pop.ChoiceName = "You selected Open File."
Case "Save File"
pop.ChoiceName = "You selected Save File."
Case "Save As"
pop.ChoiceName = "You selected Save File As..."
Case "Quit"
pop.ChoiceName = "Are you sure you want to quit???  "
Case "Cut"
pop.ChoiceName = "You selected Cut Text."
Case "Copy"
pop.ChoiceName = "You selected Copy Text."
Case "Paste"
pop.ChoiceName = "You selected Paste Text."
Case "Clear"
pop.ChoiceName = "You selected Clear Text."
Case "Select All"
pop.ChoiceName = "You selected all text."
Case "Close"
pop.ChoiceName = "You selected to close the menu."
Case "View Subs"
pop.ChoiceName = "You selected to view the subs."
Case "Show Lines"
pop.ChoiceName = "You selected to Show Lines."
Case "Warnings"
pop.ChoiceName = "You selected to view compiler warnings."
Case "Find"
pop.ChoiceName = "You selected to Find Text."
Case "Repeat Find"
pop.ChoiceName = "You selected to Repeat Text Find."
Case "Change"
pop.ChoiceName = "You selected to Change Text."
Case "History"
pop.ChoiceName = "You selected to View History."
Case "Remove Bookmark"
pop.ChoiceName = "You selected to Remove a Bookmark."
Case "Previous Bookmark"
pop.ChoiceName = "You selected to go to Previous Bookmark"
Case "Go to LIne"
pop.ChoiceName = "You selected to go to a line number."
Case "View Help"
pop.ChoiceName = "You selected to View Help."
Case "About"
pop.ChoiceName = "You selected to view info about this app."
End Select
Locate _Height - 1, 1: Color 15, 1: Print Space$(_Width);
Locate _Height - 1, 2: Print pop.ChoiceName;
Else
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
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
Sub FreeCopy (gbl As GlobalVar, SCopy())
Static fcopy$
Dim i As Integer
If gbl.anum > 0 Then
i = 0
Do
i = i + 1
i$ = LTrim$(Str$(i)) + "|"
If InStr(fcopy$, i$) = 0 Then Exit Do
Loop
fcopy$ = fcopy$ + i$
SCopy(gbl.anum) = i
PCopy gbl.MyScreen, SCopy(gbl.anum)
ElseIf gbl.anum < 0 Then
i$ = LTrim$(Str$(SCopy(Abs(gbl.anum)))) + "|"
fcopy$ = Mid$(fcopy$, 1, j) + Mid$(fcopy$, j + Len(i$) + 1)
PCopy SCopy(Abs(gbl.anum)), gbl.MyScreen
End If
Rem _Title Str$(gbl.MyScreen) + " " + Str$(gbl.anum) + " " + Str$(SCopy(Abs(gbl.anum))) + " " + Str$(i) + " fcopy = " + fcopy$
End Sub
Pete
Shoot first and shoot people who ask questions, later.
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
Now with SUCKERFISH menus...
See the pointer in the View or Help menus.
Code: (Select All)
ReDim Shared suckerfish
$Resize:On
_ScreenMove 200, 20
ReDim Shared SCopy(100)
Type GlobalVar
anum As Integer
MyScreen As Integer
UcaseKeys As String
LcaseKeys As String
CtrlKeys As String
AltKeys As String
End Type
Dim gbl As GlobalVar
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
ID As String
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 gbl, 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 gbl, t, pop, m, c, b$
Popup_Menu gbl, t, in, pop, m, c, b$, text$()
_Display
Loop Until pop.Show = 0 And b$ = Chr$(27)
System
Sub User_Defined_Variables (gbl As GlobalVar, t As TextVar, pop As PopupVar, c As ColorVar)
Static initiate
If initiate = 0 Then
MakeMyCase = 0 ' Non-zero to attach Select Case code to clipboard. ZERO to ignore.
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
PopupMenuBarData:
Data Open|Ctrl+O|>Open File
Data Save|Ctrl+S|>Save File
Data Save As|Ctrl+A|>Save As
Data Exit|>Quit
Data eof
Data Cut|Ctrl+X|>Cut
Data Copy|Ctrl+C|>Copy
Data Paste|Ctrl+V|>Paste
Data Clear|Delete|>Clear
Data Select All|Ctrl+A|>Select All
Data Close|Esc|>Close
Data eof
Data Subs|Shift+F2|>View Subs
Data Line Numbers||>Show Lines
Data Compiler Warnings|Ctrl+W|>Warnings
Data eof
Data Find|Ctrl+F3|>Find
Data Repeat Last Find|Shift+F3|>Repeat Find
Data Change|Alt+F3|>Change
Data Clear Search History|Alt+Lt|>History
Data Add / Remove Bookmark|Alt+Rt|>Remove Bookmark
Data Previous Bookmark|Alt+Dn|>Previous Bookmark
Data Go To Line|Ctrl+G|>Go to LIne
Data eof
Data View|Shift+F1|>View Help
Data About||>About
Data eof
Data eom
SuckerfishMenus:
Data Show Line Numbers|>Display Line Numbers
Data Hide Line Numbers|>Hide Line Numbers
Data Show Separator|>Show Separator
Data eof
Data Show Copyright|>Display Copyright
Data Hide Copyright|>Hide Copyright
Data Give Pete Rep Points!|>Pete is Tremendous
Data eof
Data eom
gbl.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"
gbl.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.
gbl.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 -"
gbl.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 MakeMyCase Then
Restore PopupMenuBarData
_Clipboard$ = "Select Case pop.ID" + Chr$(10) + Chr$(13)
Do
Read tmp$
If tmp$ = "eom" Then
Exit Do
ElseIf tmp$ = "eof" Then _Continue
Else
nomi = nomi + 1
j = InStr(tmp$, "|>") + 2
If j Then
_Clipboard$ = _Clipboard$ + " Case " + Chr$(34) + Mid$(tmp$, j) + Chr$(34) + Chr$(10) + Chr$(13) + Chr$(10) + Chr$(13)
End If
End If
Loop
_Clipboard$ = _Clipboard$ + "End Select"
End If
initiate = 0
End If
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 (gbl As GlobalVar, 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, nomi, map$, shortcut$, sc$(), id$()
y = CsrLin: x = Pos(0)
pop.ID = "" ' Needed here as well as in popup menu sub. Reason: Shortcut keys used without an open menu will not trigger a negative pop.MenuModel value to nullify this variable in the popup sub.
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
Restore PopupMenuBarData
Do
Read tmp$
If tmp$ = "eom" Then
x$ = "": a$ = "": tmp$ = "": Exit Do
ElseIf tmp$ = "eof" Then _Continue
Else
nomi = nomi + 1
ReDim _Preserve sc$(nomi), id$(nomi)
sc$(nomi) = Chr$(3) + "0" + Chr$(4) + "0" + Chr$(5) + "0" + Space$(10)
If InStr(tmp$, "|>") Then
id$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2))
x$ = Mid$(tmp$, 1, InStr(tmp$, "|>") - 1)
Else
x$ = tmp$
End If
If InStr(x$, "|") Then x$ = LCase$(Mid$(x$, InStr(x$, "|") + 1)) Else x$ = ""
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$, "+"))
End If
Loop
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
Else
If pop.Show = 0 Then
If m.alt Then ' Search for a valid shortcut key.
x$ = gbl.AltKeys
ElseIf m.ctrl Then x$ = gbl.CtrlKeys
ElseIf m.shift Then x$ = gbl.UcaseKeys Else x$ = gbl.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 h = 1 To nomi
If m.shift And Mid$(sc$(h), 2, 1) = "1" Or m.shift = 0 And Mid$(sc$(h), 2, 1) = "0" Then
If m.ctrl And Mid$(sc$(h), 4, 1) = "1" Or m.ctrl = 0 And Mid$(sc$(h), 4, 1) = "0" Then
If m.alt And Mid$(sc$(h), 6, 1) = "1" Or m.alt = 0 And Mid$(sc$(h), 6, 1) = "0" Then
If RTrim$(Mid$(sc$(h), 7)) = LCase$(key$) Then
pop.ID = id$(h) ' Valid Shortcut key found.
Exit For
End If
End If
End If
End If
Next h
End If
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
If suckerfish Then suckerfish = -1: gbl.anum = -2: FreeCopy gbl, SCopy(): gbl.anum = -1: FreeCopy gbl, SCopy()
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 (gbl As GlobalVar, t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$, text$())
Static initiate, SFMenuMap, nomi, oldmy, oldmx, myalt, RtClkRedo, SFCounter, SFReversed
Static menu$(), sc$(), id$(), SFMenu(), MenuRestrict(), y, x, atmp As String
Static SFParentT, SFParentR, SFParentB, SFParentL, SFParentW, SFParentH, SFParentNomi, SFParentMenuHL, SFhwWindow&, InsideSFParent, SFParentMenu$(), SFParentSc$(), SFParentID$()
If pop.MenuModel < 0 Then pop.MenuModel = 0: pop.Choice = 0: pop.ChoiceName = "": pop.ID = "" ' 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 suckerfish = -1 Then ' Closed by slider in Menubar sub.
suckerfish = 0: SFParentT = 0: SFParentR = 0: SFParentB = 0: SFParentL = 0
SFParentW = 0: SFParentH = 0: SFParentNomi = 0: SFParentMenuHL = 0: InsideSFParent = 0: SFhwWindow& = 0
ReDim SFParentMenu$(0), SFParentSc$(0), SFParentID$(0), SFMenuRestrict(0)
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
End If
If pop.Show Then
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
y = CsrLin: x = Pos(0)
If SFMenuMap = 0 Then
SFMenuMap = 1: SFCounter = 0
Restore PopupMenuBarData
Do
Read tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ <> "eof" Then
SFCounter = SFCounter + 1: ReDim _Preserve SFMenu(SFCounter)
If InStr(tmp$, Chr$(16)) Then j = j + 1: SFMenu(SFCounter) = j
End If
Loop
SFCounter = 0
End If
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
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
Restore PopupMenuBarData: SFCounter = 0
For i = 1 To pop.Show - 1
Do
Read tmp$
If tmp$ = "eof" Then Exit Do Else SFCounter = SFCounter + 1
Loop
Next
Case 4
Restore SuckerfishMenus
For i = 1 To suckerfish - 1
Do: Read tmp$: If tmp$ = "eof" Then Exit Do
Loop
Next
End Select
ReDim menu$(0), sc$(0), id$(0)
Do
Read tmp$
If tmp$ = "eof" Then Exit Do
nomi = nomi + 1
ReDim _Preserve menu$(nomi), sc$(nomi), id$(nomi)
If InStr(tmp$, "|") Then
If InStr(tmp$, "|>") Then id$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2)): tmp$ = _Trim$(Mid$(tmp$, 1, InStr(tmp$, "|>") - 1))
If InStr(tmp$, "|") Then
short$ = _Trim$(Mid$(tmp$, InStr(tmp$, "|") + 1))
tmp$ = Mid$(tmp$, 1, InStr(tmp$, "|") - 1)
End If
x$ = tmp$: If Len(short$) Then x$ = x$ + Chr$(4) + short$
menu$(nomi) = x$: If jj < Len(x$) Then jj = Len(x$)
Else
menu$(nomi) = tmp$
End If
sc$(nomi) = Chr$(3) + "0" + Chr$(4) + "0" + Chr$(5) + "0" + Space$(10)
If InStr(tmp$, "|>") Then
id$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2))
x$ = Mid$(tmp$, 1, InStr(tmp$, "|>") - 1)
Else
x$ = tmp$
End If
If InStr(x$, "|") Then x$ = LCase$(Mid$(x$, InStr(x$, "|") + 1)) Else x$ = ""
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
x$ = LCase$(short$)
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$(LCase$(short$), _InStrRev("+" + LCase$(short$), "+"))
short$ = "": x$ = ""
Loop
For i = 1 To nomi
If InStr(menu$(i), Chr$(4)) Then
k = jj - Len(menu$(i))
x$ = Mid$(menu$(i), 1, InStr(menu$(i), Chr$(4)) - 1) + String$(k + 3, ".") + Mid$(menu$(i), InStr(menu$(i), Chr$(4)) + 1)
Else
x$ = menu$(i)
End If
menu$(i) = x$
Next
ReDim MenuRestrict(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: MenuRestrict(i) = 1: Next
Else
If t.hl = 0 Then ' Unhighlighted text - Cut/Copy/Paste/Clear unavilable. Select All available.
For i = 1 To 4: MenuRestrict(i) = 1: Next
End If
End If
If text$(in.fld) = "" Then MenuRestrict(5) = 1 ' Cannot Select All on a blank input line.
If Len(_Clipboard$) Then MenuRestrict(3) = 0 Else MenuRestrict(3) = 1 ' Paste available if clipboard is loaded.
End If
' Open popup.
If suckerfish Then gbl.anum = 2 Else gbl.anum = 1
FreeCopy gbl, SCopy()
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
Case 4
pop.MenuL = SFParentR
If pop.MenuL + pop.mwidth >= t.mr - pop.Shadow Then
pop.MenuL = SFParentL - pop.mwidth
SFReversed = _TRUE
Else
SFReversed = 0
End If
pop.MenuT = pop.MenuBarRow + 1
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 Or pop.MenuModel = 4 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 And pop.MenuModel <> 4 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 ' Space between menu items.
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);
_Title Str$(pop.MenuL) + " " + Str$(SFReversed) + " " + Str$(pop.mheight) + " " + Str$(SFParentH)
Color c.PopupShadowBkg, c.PopupShadowFrg
If suckerfish = 0 Or suckerfish And SFReversed = 0 Then
Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Else
If SFReversed Then
If i >= SFParentH And pop.VSpacing = 2 Or i > SFParentH And pop.VSpacing = 1 Then Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1)) Else Print
Else
Print
End If
End If
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 MenuRestrict(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
If m.lb = 2 And suckerfish Then
If InsideSFParent = _TRUE Then
pop.MenuT = SFParentT: pop.MenuR = SFParentR + 1: pop.MenuB = SFParentB + 1: pop.MenuL = SFParentL
pop.MenuModel = 2: pop.Show = suckerfish
pop.mwidth = SFParentW: nomi = SFParentNomi
pop.mheight = SFParentH
suckerfish = 0: m.lb = 0
InsideSFParent = 0
ReDim menu$(nomi), sc$(nomi), id$(nomi), SFMenuRestrict(nomi)
For i = 1 To SFParentNomi
menu$(i) = SFParentMenu$(i): sc$(i) = SFParentSc$(i)
id$(i) = SFParentID$(i): MenuRestrict(i) = SFMenuRestrict(i)
Next
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
pop.MenuHL = SFParentMenuHL: oldy = 0
pop.hwWindow = SFhwWindow&
gbl.anum = -2: FreeCopy gbl, SCopy()
End If
End If
If m.y >= pop.MenuT And m.y <= pop.MenuB And m.x >= pop.MenuL And m.x <= pop.MenuR Then
InsideMenu = _TRUE
Else
InsideMenu = _FALSE
End If
If suckerfish Then
If m.y >= SFParentT And m.y <= SFParentB And m.x >= SFParentL And m.x <= SFParentR Then
InsideSFParent = _TRUE
Else
InsideSFParent = _FALSE
End If
End If
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.lb = 2 And InsideMenu = _TRUE Then
j = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
If MenuRestrict(j) = 0 Then
If InStr(menu$(j), Chr$(16)) And pop.MenuModel = 2 Then ' Suckerfish menu pointer.
If suckerfish = 0 Then
suckerfish = SFMenu(SFCounter + j): pop.MenuModel = 4: pop.CloseReOpen = pop.Show
SFParentT = pop.MenuT: SFParentR = pop.MenuR - 1: SFParentB = pop.MenuB - 1
SFParentL = pop.MenuL: SFParentW = pop.mwidth: SFParentH = pop.mheight
ReDim SFParentMenu$(nomi), SFParentSc$(nomi), SFParentID$(nomi), SFMenuRestrict(nomi)
For i = 1 To nomi
SFParentMenu$(i) = menu$(i): SFParentSc$(i) = sc$(i)
SFParentID$(i) = id$(i): SFMenuRestrict(i) = MenuRestrict(i)
Next
SFParentNomi = nomi: SFParentMenuHL = pop.MenuHL: SFhwWindow& = pop.hwWindow
End If
Exit Do
Else
pop.Choice = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
pop.ID = id$(pop.Choice): Exit Do
End If
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 MenuRestrict((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 MenuRestrict((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
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$ = gbl.AltKeys
ElseIf m.ctrl Then x$ = gbl.CtrlKeys
ElseIf m.shift Then x$ = gbl.UcaseKeys Else x$ = gbl.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): pop.ID = id$(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
If SFhwWindow& Then _PutImage ((SFParentL - 1) * t.fw, (SFParentT - 1) * t.fh), SFhwWindow&
End If
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 ' Adding initiate here prevents a pop.Show -1 call that was first positive to open the popup and copy the screen.
If suckerfish = 0 Or suckerfish And pop.CloseReOpen = 0 Then
If suckerfish And pop.CloseReOpen = 0 Then gbl.anum = -2: FreeCopy gbl, SCopy()
gbl.anum = -1: FreeCopy gbl, SCopy()
End If
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
suckerfish = 0: SFParentT = 0: SFParentR = 0: SFParentB = 0: SFParentL = 0: SFhwWindow& = 0
SFParentW = 0: SFParentH = 0: SFParentNomi = 0: SFParentMenuHL = 0: InsideSFParent = 0: SFhwWindow& = 0
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
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 Or pop.MenuModel = 4 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.MenuModel < 0 Then Locate _Height - 1, 1: Color 15, 1: Print Space$(_Width);
If Len(pop.ID) Then
Sound 1000, .1
Select Case pop.ID
Case "Open File"
pop.ChoiceName = "You selected Open File."
Case "Save File"
pop.ChoiceName = "You selected Save File."
Case "Save As"
pop.ChoiceName = "You selected Save File As..."
Case "Quit"
pop.ChoiceName = "Are you sure you want to quit??? "
Case "Cut"
pop.ChoiceName = "You selected Cut Text."
Case "Copy"
pop.ChoiceName = "You selected Copy Text."
Case "Paste"
pop.ChoiceName = "You selected Paste Text."
Case "Clear"
pop.ChoiceName = "You selected Clear Text."
Case "Select All"
pop.ChoiceName = "You selected all text."
Case "Close"
pop.ChoiceName = "You selected to close the menu."
Case "View Subs"
pop.ChoiceName = "You selected to view the subs."
Case "Show Lines"
pop.ChoiceName = "You selected to Show Lines."
Case "Warnings"
pop.ChoiceName = "You selected to view compiler warnings."
Case "Find"
pop.ChoiceName = "You selected to Find Text."
Case "Repeat Find"
pop.ChoiceName = "You selected to Repeat Text Find."
Case "Change"
pop.ChoiceName = "You selected to Change Text."
Case "History"
pop.ChoiceName = "You selected to View History."
Case "Remove Bookmark"
pop.ChoiceName = "You selected to Remove a Bookmark."
Case "Previous Bookmark"
pop.ChoiceName = "You selected to go to Previous Bookmark"
Case "Go to LIne"
pop.ChoiceName = "You selected to go to a line number."
Case "View Help"
pop.ChoiceName = "You selected to View Help."
Case "About"
pop.ChoiceName = "You selected to view info about this app."
End Select
Locate _Height - 1, 1: Color 15, 1: Print Space$(_Width);
Locate _Height - 1, 2: Print pop.ChoiceName;
Else
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
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
Sub FreeCopy (gbl As GlobalVar, SCopy())
Static fcopy$
Dim i As Integer
If gbl.anum > 0 Then
i = 0
Do
i = i + 1
i$ = LTrim$(Str$(i)) + "|"
If InStr(fcopy$, i$) = 0 Then Exit Do
Loop
fcopy$ = fcopy$ + i$
SCopy(gbl.anum) = i
PCopy gbl.MyScreen, SCopy(gbl.anum)
ElseIf gbl.anum < 0 Then
i$ = LTrim$(Str$(SCopy(Abs(gbl.anum)))) + "|"
j = InStr(fcopy$, i$) - 1
fcopy$ = Mid$(fcopy$, 1, j) + Mid$(fcopy$, j + Len(i$) + 1)
PCopy SCopy(Abs(gbl.anum)), gbl.MyScreen
End If
Rem _Title Str$(gbl.MyScreen) + " " + Str$(gbl.anum) + " " + Str$(SCopy(Abs(gbl.anum))) + " " + Str$(i) + " fcopy = " + fcopy$
End Sub
Shoot first and shoot people who ask questions, later.
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
01-22-2026, 12:53 AM
(This post was last modified: 01-22-2026, 03:43 AM by Pete.)
Added some support for menus that drop down from the page. I haven't got to the hardware acceleration for those, so tis demo is in text for this feature.
Code: (Select All)
$Resize:On
_ScreenMove 200, 20
ReDim Shared PageMap$(0)
Type GlobalVar
anum As Integer
MyScreen As Integer
UcaseKeys As String
LcaseKeys As String
CtrlKeys As String
AltKeys As String
End Type
Dim gbl As GlobalVar
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
PageMenuy As Integer
PageMenux As Integer
MenuBar As String
MenuBarLt As String
MenuBarRt As String
MenuBarRow As Integer
MenuModel As Integer
ID As String
SuckerFish 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
PageMenuFrg As Integer
PageFrg As Integer
PageBkg As Integer
ILF As Integer
ILB As Integer
PageMenuBkg As Integer
PageMenuHlFrg As Integer
PageMenuHlBkg As Integer
PageMenuBdr As Integer
End Type
Dim c As ColorVar
User_Defined_Variables gbl, t, pop, c
Color c.PageFrg, c.PageBkg: Cls
ReDim text$(1)
Do
_Limit 60
ScreenSize t, c
control t, in, pop, m, c, b$, text$()
Mouse_Keyboard m, b$
Menu_Bar gbl, t, pop, m, c, b$, SCopy()
Popup_Menu gbl, t, in, pop, m, c, b$, text$(), SCopy()
Page_Menus pop, m
_Display
Loop Until pop.Show = 0 And b$ = Chr$(27)
System
Sub User_Defined_Variables (gbl As GlobalVar, t As TextVar, pop As PopupVar, c As ColorVar)
Static initiate
If initiate = 0 Then
MakeMyCase = 0 ' Non-zero to attach Select Case code to clipboard. ZERO to ignore.
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.PageFrg = 15
c.PageBkg = 1
c.ILF = 14
c.ILB = 1
c.PageMenuFrg = 7
c.PageMenuBkg = 1
c.PageMenuHlFrg = 15
c.PageMenuHlBkg = 14
c.PageMenuBdr = 14
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
PageMenuData:
Data "Single-Spaced No Lines Popup Menu"
Data "Double-Spaced No Lines Popup Menu"
Data "Single-Spaced Lined Popup Menu"
Data "Double-Spaced Lined Popup Men"
Data "Single-Spaced No Lines Hardware Popup Menu"
Data "Double-Spaced No Lines Hardware Popup Menu"
Data "Single-Spaced Lined Hardware Popup Menu"
Data "Double-Spaced Lined Hardware Popup Menu"
Data eof
Data eom
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 everything 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
PopupMenuBarData:
Data Open|Ctrl+O|>Open File
Data Save|Ctrl+S|>Save File
Data Save As|Ctrl+A|>Save As
Data Exit|>Quit
Data eof
Data Cut|Ctrl+X|>Cut
Data Copy|Ctrl+C|>Copy
Data Paste|Ctrl+V|>Paste
Data Clear|Delete|>Clear
Data Select All|Ctrl+A|>Select All
Data Close|Esc|>Close
Data eof
Data Subs|Shift+F2|>View Subs
Data Line Numbers||>Show Lines
Data Compiler Warnings|Ctrl+W|>Warnings
Data eof
Data Find|Ctrl+F3|>Find
Data Repeat Last Find|Shift+F3|>Repeat Find
Data Change|Alt+F3|>Change
Data Clear Search History|Alt+Lt|>History
Data Add / Remove Bookmark|Alt+Rt|>Remove Bookmark
Data Previous Bookmark|Alt+Dn|>Previous Bookmark
Data Go To Line|Ctrl+G|>Go to LIne
Data eof
Data View|Shift+F1|>View Help
Data About||>About
Data eof
Data eom
SuckerfishMenus:
Data Show Line Numbers|>Display Line Numbers
Data Hide Line Numbers|>Hide Line Numbers
Data Show Separator|>Show Separator
Data eof
Data Show Copyright|>Display Copyright
Data Hide Copyright|>Hide Copyright
Data Give Pete Rep Points!|>Pete is Tremendous
Data eof
Data eom
gbl.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"
gbl.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.
gbl.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 -"
gbl.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 MakeMyCase Then
Restore PopupMenuBarData
_Clipboard$ = "Select Case pop.ID" + Chr$(10) + Chr$(13)
Do
Read tmp$
If tmp$ = "eom" Then
Exit Do
ElseIf tmp$ = "eof" Then _Continue
Else
nomi = nomi + 1
j = InStr(tmp$, "|>") + 2
If j Then
_Clipboard$ = _Clipboard$ + " Case " + Chr$(34) + Mid$(tmp$, j) + Chr$(34) + Chr$(10) + Chr$(13) + Chr$(10) + Chr$(13)
End If
End If
Loop
_Clipboard$ = _Clipboard$ + "End Select"
End If
initiate = 0
End If
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 (gbl As GlobalVar, t As TextVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$, SCopy())
If Len(pop.MenuBarLt) + Len(pop.MenuBarRt) = 0 Then Exit Sub
Static initiate, altmx, oldmy, oldmx, pcopyhack, AltBlocker, AltException, nomi, map$, shortcut$, sc$(), id$()
y = CsrLin: x = Pos(0)
pop.ID = "" ' Needed here as well as in popup menu sub. Reason: Shortcut keys used without an open menu will not trigger a negative pop.MenuModel value to nullify this variable in the popup sub.
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
Restore PopupMenuBarData
Do
Read tmp$
If tmp$ = "eom" Then
x$ = "": a$ = "": tmp$ = "": Exit Do
ElseIf tmp$ = "eof" Then _Continue
Else
nomi = nomi + 1
ReDim _Preserve sc$(nomi), id$(nomi)
sc$(nomi) = Chr$(3) + "0" + Chr$(4) + "0" + Chr$(5) + "0" + Space$(10)
If InStr(tmp$, "|>") Then
id$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2))
x$ = Mid$(tmp$, 1, InStr(tmp$, "|>") - 1)
Else
x$ = tmp$
End If
If InStr(x$, "|") Then x$ = LCase$(Mid$(x$, InStr(x$, "|") + 1)) Else x$ = ""
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$, "+"))
End If
Loop
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
Else
If pop.Show = 0 Then
If m.alt Then ' Search for a valid shortcut key.
x$ = gbl.AltKeys
ElseIf m.ctrl Then x$ = gbl.CtrlKeys
ElseIf m.shift Then x$ = gbl.UcaseKeys Else x$ = gbl.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 h = 1 To nomi
If m.shift And Mid$(sc$(h), 2, 1) = "1" Or m.shift = 0 And Mid$(sc$(h), 2, 1) = "0" Then
If m.ctrl And Mid$(sc$(h), 4, 1) = "1" Or m.ctrl = 0 And Mid$(sc$(h), 4, 1) = "0" Then
If m.alt And Mid$(sc$(h), 6, 1) = "1" Or m.alt = 0 And Mid$(sc$(h), 6, 1) = "0" Then
If RTrim$(Mid$(sc$(h), 7)) = LCase$(key$) Then
pop.ID = id$(h) ' Valid Shortcut key found.
Exit For
End If
End If
End If
End If
Next h
End If
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
If pop.SuckerFish Then pop.SuckerFish = -1: gbl.anum = -2: FreeCopy gbl, SCopy(): gbl.anum = -1: FreeCopy gbl, SCopy()
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 (gbl As GlobalVar, t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$, text$(), SCopy())
Static initiate, SFMenuMap, nomi, oldmy, oldmx, myalt, RtClkRedo, SFCounter, SFReversed
Static menu$(), sc$(), MenuID$(), SFMenu(), MenuRestrict(), y, x, atmp As String
Static SFParentT, SFParentR, SFParentB, SFParentL, SFParentW, SFParentH, SFParentNomi, SFParentMenuHL, SFhwWindow&, InsideSFParent, SFParentMenu$(), SFParentSc$(), SFParentID$()
If pop.MenuModel = 5 Then
If initiate = 0 Then
Restore PageMenuData: pop.mheight = 0: ReDim menu$(0)
For i = 1 To pop.Show
Do: Read tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ = "eof" Then If cnt + 1 = pop.Show Then Exit Do Else cnt = cnt + 1: _Continue
If cnt + 1 = pop.Show Then
pop.mheight = pop.mheight + 1: ReDim _Preserve menu$(pop.mheight): menu$(pop.mheight) = tmp$
If k < Len(tmp$) Then k = Len(tmp$)
End If
Loop
Next
pop.mwidth = k + 2
cnt = 0: k = 0: mxalt = 0
x$ = Mid$(PageMap$(m.y), m.x, 1)
pop.MenuL = InStr(PageMap$(m.y), x$) - 1
pop.MenuR = pop.MenuL + pop.mwidth
pop.MenuB = pop.MenuT + pop.mheight
Locate pop.MenuT, pop.MenuL
Color c.PageMenuBdr, c.PageMenuBkg
For i = 1 To pop.mheight
Locate , pop.MenuL
Print Chr$(179); Space$(pop.mwidth - 2) + Chr$(179)
Next
Color c.PageMenuBdr, c.PageMenuBkg: Locate , pop.MenuL
Print Chr$(192) + String$(pop.mwidth - 2, 196) + Chr$(217);
Color c.PageMenuFrg, c.PageMenuBkg
For i = 0 To pop.mheight - 1
Locate pop.MenuT + i, pop.MenuL + 1
Print menu$(i + 1);
Next
initiate = 1
Else
While -1
Do
If t.ScrnResize = 1 Then pop.Choice = -1: Exit Do ' Force popup to close when resizing app.
If m.y >= pop.MenuT And m.y < pop.MenuB And m.x >= pop.MenuL And m.x <= pop.MenuR Then
InsideMenu = _TRUE
Else
InsideMenu = _FALSE
End If
mxalt = 0
If b$ = Chr$(0) + "H" Or m.mw = -1 Then
If pop.MenuHL - pop.MenuT > 0 Then
myalt = pop.MenuHL - 1: mxalt = -1
End If
ElseIf b$ = Chr$(0) + "P" Or m.mw = 1 Then
If pop.MenuHL = 0 Then
myalt = pop.MenuT: mxalt = -1
Else
If (pop.MenuHL - pop.MenuT + 1) < nomi Then
myalt = pop.MenuHL + 1: mxalt = -1
End If
End If
ElseIf b$ = Chr$(13) And pop.MenuHL Or m.lb = 2 And InsideMenu = _TRUE Then
pop.Choice = pop.MenuHL - pop.MenuT + 1
Exit Do
ElseIf b$ = Chr$(27) Then
Exit Do
End If
' Popup is present.
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
i = myalt <> oldmy Or myalt = oldmy And m.x <> oldmx Or pop.MenuHL And m.lb = 2
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, 1, Len(menu$(pop.MenuHL + 1 - pop.MenuT))) = menu$(pop.MenuHL + 1 - pop.MenuT)
Locate pop.MenuHL, pop.MenuL + 1
Color c.PageMenuFrg, c.PageMenuBkg
Print atmp
End If
atmp = Space$(pop.mwidth - 2)
Mid$(atmp, 1, Len(menu$(myalt + 1 - pop.MenuT))) = menu$(myalt + 1 - pop.MenuT)
Locate myalt, pop.MenuL + 1
Color c.PageMenuHlFrg, c.PageMenuHlBkg
Print atmp;
Color c.PageMenuFrg, c.PageMenuBkg
pop.MenuHL = myalt
End If
Else
' Toggle close popup menu.
If m.lb = 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
End If
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.
mxalt = 0: initiate = 0: pop.Show = 0: pop.MenuModel = -pop.MenuModel
pop.MenuT = 0: pop.MenuL = 0: pop.MenuR = 0: pop.MenuB = 0: pop.MenuHL = 0: pop.mwidth = 0: pop.mheight = 0
gbl.anum = -1: FreeCopy gbl, SCopy()
b$ = ""
If pop.Choice > 0 Then
j = pop.mwidth - 2
Rem pop.ID = MenuID$(pop.Choice)
Color c.ILF, c.ILB
Locate pop.PageMenuy, pop.PageMenux: Print Space$(j);
Locate pop.PageMenuy, pop.PageMenux: Print menu$(pop.Choice);
End If
Exit While
Wend
End If
Else
If pop.MenuModel < 0 Then
pop.PageMenuy = 0: pop.PageMenux = 0: oldmy = 0: myalt = 0: pop.MenuHL = 0: pop.MenuT = 0: pop.MenuB = 0: pop.MenuL = 0: pop.MenuR = 0
pop.MenuModel = 0: pop.Choice = 0: pop.ChoiceName = "": pop.ID = "" ' Completed cycle.
Erase menu$: ReDim MenuID$(0): ReDim sc$(0) ' Note: Can't erase because it isn't defined until later in the code.
End If
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.SuckerFish = -1 Then ' Closed by slider in Menubar sub.
pop.SuckerFish = 0: SFParentT = 0: SFParentR = 0: SFParentB = 0: SFParentL = 0
SFParentW = 0: SFParentH = 0: SFParentNomi = 0: SFParentMenuHL = 0: InsideSFParent = 0: SFhwWindow& = 0
ReDim SFParentMenu$(0), SFParentSc$(0), SFParentID$(0), SFMenuRestrict(0)
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
End If
If pop.Show Then
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
y = CsrLin: x = Pos(0)
If SFMenuMap = 0 Then
SFMenuMap = 1: SFCounter = 0
Restore PopupMenuBarData
Do
Read tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ <> "eof" Then
SFCounter = SFCounter + 1: ReDim _Preserve SFMenu(SFCounter)
If InStr(tmp$, Chr$(16)) Then j = j + 1: SFMenu(SFCounter) = j
End If
Loop
SFCounter = 0
End If
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
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
Restore PopupMenuBarData: SFCounter = 0
For i = 1 To pop.Show - 1
Do
Read tmp$
If tmp$ = "eof" Then Exit Do Else SFCounter = SFCounter + 1
Loop
Next
Case 4
Restore SuckerfishMenus
For i = 1 To pop.SuckerFish - 1
Do: Read tmp$: If tmp$ = "eof" Then Exit Do
Loop
Next
End Select
ReDim menu$(0), sc$(0), MenuID$(0)
Do
Read tmp$
If tmp$ = "eof" Then Exit Do
nomi = nomi + 1
ReDim _Preserve menu$(nomi), sc$(nomi), MenuID$(nomi)
If InStr(tmp$, "|") Then
If InStr(tmp$, "|>") Then MenuID$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2)): tmp$ = _Trim$(Mid$(tmp$, 1, InStr(tmp$, "|>") - 1))
If InStr(tmp$, "|") Then
short$ = _Trim$(Mid$(tmp$, InStr(tmp$, "|") + 1))
tmp$ = Mid$(tmp$, 1, InStr(tmp$, "|") - 1)
End If
x$ = tmp$: If Len(short$) Then x$ = x$ + Chr$(4) + short$
menu$(nomi) = x$: If jj < Len(x$) Then jj = Len(x$)
Else
menu$(nomi) = tmp$
End If
sc$(nomi) = Chr$(3) + "0" + Chr$(4) + "0" + Chr$(5) + "0" + Space$(10)
If InStr(tmp$, "|>") Then
MenuID$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2))
x$ = Mid$(tmp$, 1, InStr(tmp$, "|>") - 1)
Else
x$ = tmp$
End If
If InStr(x$, "|") Then x$ = LCase$(Mid$(x$, InStr(x$, "|") + 1)) Else x$ = ""
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
x$ = LCase$(short$)
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$(LCase$(short$), _InStrRev("+" + LCase$(short$), "+"))
short$ = "": x$ = ""
Loop
For i = 1 To nomi
If InStr(menu$(i), Chr$(4)) Then
k = jj - Len(menu$(i))
x$ = Mid$(menu$(i), 1, InStr(menu$(i), Chr$(4)) - 1) + String$(k + 3, ".") + Mid$(menu$(i), InStr(menu$(i), Chr$(4)) + 1)
Else
x$ = menu$(i)
End If
menu$(i) = x$
Next
ReDim MenuRestrict(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: MenuRestrict(i) = 1: Next
Else
If t.hl = 0 Then ' Unhighlighted text - Cut/Copy/Paste/Clear unavilable. Select All available.
For i = 1 To 4: MenuRestrict(i) = 1: Next
End If
End If
If text$(in.fld) = "" Then MenuRestrict(5) = 1 ' Cannot Select All on a blank input line.
If Len(_Clipboard$) Then MenuRestrict(3) = 0 Else MenuRestrict(3) = 1 ' Paste available if clipboard is loaded.
End If
' Open popup.
If pop.SuckerFish Then gbl.anum = 2 Else gbl.anum = 1
FreeCopy gbl, SCopy()
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
Case 4
pop.MenuL = SFParentR
If pop.MenuL + pop.mwidth >= t.mr - pop.Shadow Then
pop.MenuL = SFParentL - pop.mwidth
SFReversed = _TRUE
Else
SFReversed = 0
End If
pop.MenuT = pop.MenuBarRow + 1
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 Or pop.MenuModel = 4 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 And pop.MenuModel <> 4 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 ' Space between menu items.
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
If pop.SuckerFish = 0 Or pop.SuckerFish And SFReversed = 0 Then
Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Else
If SFReversed Then
If i >= SFParentH And pop.VSpacing = 2 Or i > SFParentH And pop.VSpacing = 1 Then Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1)) Else Print
Else
Print
End If
End If
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 MenuRestrict(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
If m.lb = 2 And pop.SuckerFish Then
If InsideSFParent = _TRUE Then
pop.MenuT = SFParentT: pop.MenuR = SFParentR + 1: pop.MenuB = SFParentB + 1: pop.MenuL = SFParentL
pop.MenuModel = 2: pop.Show = pop.SuckerFish
pop.mwidth = SFParentW: nomi = SFParentNomi
pop.mheight = SFParentH
pop.SuckerFish = 0: m.lb = 0
InsideSFParent = 0
ReDim menu$(nomi), sc$(nomi), MenuID$(nomi), SFMenuRestrict(nomi)
For i = 1 To SFParentNomi
menu$(i) = SFParentMenu$(i): sc$(i) = SFParentSc$(i)
MenuID$(i) = SFParentID$(i): MenuRestrict(i) = SFMenuRestrict(i)
Next
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
pop.MenuHL = SFParentMenuHL: oldy = 0
pop.hwWindow = SFhwWindow&
gbl.anum = -2: FreeCopy gbl, SCopy()
End If
End If
If m.y > pop.MenuT And m.y < pop.MenuB And m.x >= pop.MenuL And m.x <= pop.MenuR Then
InsideMenu = _TRUE
Else
InsideMenu = _FALSE
End If
If pop.SuckerFish Then
If m.y >= SFParentT And m.y <= SFParentB And m.x >= SFParentL And m.x <= SFParentR Then
InsideSFParent = _TRUE
Else
InsideSFParent = _FALSE
End If
End If
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.lb = 2 And InsideMenu = _TRUE Then
j = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
If MenuRestrict(j) = 0 Then
If InStr(menu$(j), Chr$(16)) And pop.MenuModel = 2 Then ' Suckerfish menu pointer.
If pop.SuckerFish = 0 Then
pop.SuckerFish = SFMenu(SFCounter + j): pop.MenuModel = 4: pop.CloseReOpen = pop.Show
SFParentT = pop.MenuT: SFParentR = pop.MenuR - 1: SFParentB = pop.MenuB - 1
SFParentL = pop.MenuL: SFParentW = pop.mwidth: SFParentH = pop.mheight
ReDim SFParentMenu$(nomi), SFParentSc$(nomi), SFParentID$(nomi), SFMenuRestrict(nomi)
For i = 1 To nomi
SFParentMenu$(i) = menu$(i): SFParentSc$(i) = sc$(i)
SFParentID$(i) = MenuID$(i): SFMenuRestrict(i) = MenuRestrict(i)
Next
SFParentNomi = nomi: SFParentMenuHL = pop.MenuHL: SFhwWindow& = pop.hwWindow
End If
Exit Do
Else
pop.Choice = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
pop.ID = MenuID$(pop.Choice): Exit Do
End If
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 MenuRestrict((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 MenuRestrict((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
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$ = gbl.AltKeys
ElseIf m.ctrl Then x$ = gbl.CtrlKeys
ElseIf m.shift Then x$ = gbl.UcaseKeys Else x$ = gbl.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): pop.ID = MenuID$(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
If SFhwWindow& Then _PutImage ((SFParentL - 1) * t.fw, (SFParentT - 1) * t.fh), SFhwWindow&
End If
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 ' Adding initiate here prevents a pop.Show -1 call that was first positive to open the popup and copy the screen.
If pop.SuckerFish = 0 Or pop.SuckerFish And pop.CloseReOpen = 0 Then
If pop.SuckerFish And pop.CloseReOpen = 0 Then gbl.anum = -2: FreeCopy gbl, SCopy()
gbl.anum = -1: FreeCopy gbl, SCopy()
End If
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
pop.SuckerFish = 0: SFParentT = 0: SFParentR = 0: SFParentB = 0: SFParentL = 0: SFhwWindow& = 0
SFParentW = 0: SFParentH = 0: SFParentNomi = 0: SFParentMenuHL = 0: InsideSFParent = 0: SFhwWindow& = 0
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
Exit While
End If
Wend
End If
End If
End Sub
Sub control (t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, 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 pop.Choice > 0 And pop.MenuModel = -5 Then m.autokey = Chr$(0) + Chr$(58 + pop.Choice)
If Mid$(b$, 2, 1) >= Chr$(59) And Mid$(b$, 2, 1) <= Chr$(66) Then
If pop.MenuModel = 2 And pop.Show Or pop.MenuModel = 4 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.MenuModel < 0 Then Locate _Height - 1, 1: Color c.PageFrg, c.PageBkg: Print Space$(_Width);
If Len(pop.ID) Then
Sound 1000, .1
Select Case pop.ID
Case "Open File"
pop.ChoiceName = "You selected Open File."
Case "Save File"
pop.ChoiceName = "You selected Save File."
Case "Save As"
pop.ChoiceName = "You selected Save File As..."
Case "Quit"
pop.ChoiceName = "Are you sure you want to quit??? "
Case "Cut"
pop.ChoiceName = "You selected Cut Text."
Case "Copy"
pop.ChoiceName = "You selected Copy Text."
Case "Paste"
pop.ChoiceName = "You selected Paste Text."
Case "Clear"
pop.ChoiceName = "You selected Clear Text."
Case "Select All"
pop.ChoiceName = "You selected all text."
Case "Close"
pop.ChoiceName = "You selected to close the menu."
Case "View Subs"
pop.ChoiceName = "You selected to view the subs."
Case "Show Lines"
pop.ChoiceName = "You selected to Show Lines."
Case "Warnings"
pop.ChoiceName = "You selected to view compiler warnings."
Case "Find"
pop.ChoiceName = "You selected to Find Text."
Case "Repeat Find"
pop.ChoiceName = "You selected to Repeat Text Find."
Case "Change"
pop.ChoiceName = "You selected to Change Text."
Case "History"
pop.ChoiceName = "You selected to View History."
Case "Remove Bookmark"
pop.ChoiceName = "You selected to Remove a Bookmark."
Case "Previous Bookmark"
pop.ChoiceName = "You selected to go to Previous Bookmark"
Case "Go to LIne"
pop.ChoiceName = "You selected to go to a line number."
Case "View Help"
pop.ChoiceName = "You selected to View Help."
Case "About"
pop.ChoiceName = "You selected to view info about this app."
End Select
Locate _Height - 1, 1: Color c.PageFrg, c.PageBkg: Print Space$(_Width);
Locate _Height - 1, 2: Print pop.ChoiceName;
Else
If pop.Choice > 0 Then
Sound 1000, .1
seen = 1
Locate _Height - 1, 1: Color c.PageFrg, c.PageBkg: 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 c.PageFrg, c.PageBkg: Print Space$(_Width);: seen = 0
End If
End If
End If
Exit Sub '===============================>
Menu_Layout:
Color c.PageFrg, c.PageBkg: 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 c.ILF, c.ILB
insert a$
Locate CsrLin + 2, 1
Color 1, 3
For i = 1 To 20
Print String$(_Width, Chr$(177))
Next
Color c.ILF, c.ILB
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
Sub FreeCopy (gbl As GlobalVar, SCopy())
Static fcopy$
Dim i As Integer
If gbl.anum > 0 Then
i = 0
Do
i = i + 1
i$ = LTrim$(Str$(i)) + "|"
If InStr(fcopy$, i$) = 0 Then Exit Do
Loop
fcopy$ = fcopy$ + i$
SCopy(gbl.anum) = i
PCopy gbl.MyScreen, SCopy(gbl.anum)
ElseIf gbl.anum < 0 Then
i$ = LTrim$(Str$(SCopy(Abs(gbl.anum)))) + "|"
j = InStr(fcopy$, i$) - 1
fcopy$ = Mid$(fcopy$, 1, j) + Mid$(fcopy$, j + Len(i$) + 1)
PCopy SCopy(Abs(gbl.anum)), gbl.MyScreen
End If
Rem _Title Str$(gbl.MyScreen) + " " + Str$(gbl.anum) + " " + Str$(SCopy(Abs(gbl.anum))) + " " + Str$(i) + " fcopy = " + fcopy$
End Sub
Sub insert (ins$)
Static initiate, MapID As Integer, k
If initiate = 0 Then ReDim _Preserve PageMap$(222): initiate = 1
y = CsrLin: x = Pos(0): restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If LTrim$(PageMap$(CsrLin)) = "" Then ' Prevents duplication if this sub is called multiple times.
MapID = MapID + 1
Restore PageMenuData
For i = 1 To MapID
Do
Read tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ = "eof" Then If cnt + 1 = MapID Then Exit Do Else cnt = cnt + 1: _Continue
If cnt + 1 = MapID Then
If k < Len(tmp$) Then k = Len(tmp$)
End If
Loop
Next
If MapID = 222 Then ' Hard Limit
_MessageBox "Configuration Error", "The maximun number of PageMap arrays (222) has been reached.", "error"
System
End If
PageMap$(CsrLin) = Space$(_Width)
Mid$(PageMap$(y), x, k) = String$(k, Asc(Chr$(MapID + 33)))
End If
Locate y - 1, x - 1: Print Chr$(218) + String$(k, 196) + Chr$(191)
Locate y, x - 1: Print Chr$(179);: Locate y, x + k: Print Chr$(179);
Locate y + 1, x - 1: Print Chr$(192) + String$(k, 196) + Chr$(217);
Locate y, x + k - 1: Print Chr$(25);
Locate y, x: Print ins$;
Locate y, x
Color restore_color1, restore_color2
End Sub
Sub Page_Menus (pop As PopupVar, m As MouseVar)
If m.lb = 2 And pop.MenuModel = 0 Then
x$ = LTrim$(Mid$(PageMap$(m.y), m.x, 1))
If Len(x$) Then
pop.MenuModel = 5: pop.Show = Asc(x$) - 33: pop.MenuT = m.y + 1
pop.PageMenuy = m.y
k = Asc(x$)
pop.PageMenux = InStr(PageMap$(m.y), Chr$(k))
End If
End If
End Sub
Pete
Shoot first and shoot people who ask questions, later.
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
Added the hardware input field image to the page popdown menu. Yeah, I know, I need to add a nice arrow image, too. Maybe tomorrow. Right now, I have to hit they gym.
Code: (Select All)
$Resize:On
_ScreenMove 200, 20
ReDim Shared PageMap$(0)
Type GlobalVar
anum As Integer
MyScreen As Integer
UcaseKeys As String
LcaseKeys As String
CtrlKeys As String
AltKeys As String
End Type
Dim gbl As GlobalVar
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.
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
InputLine As Integer ' Records cursor row.
hwFieldPresent As Integer
hwFieldFront As Long
hwFieldBack As Long
PopupHardwareAceleration As Integer
PageMenuHWFront As Long
PageMenuHWBack As Long
FldL As Integer
FldR As Integer
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
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
PageMenuy As Integer
PageMenux As Integer
MenuBar As String
MenuBarLt As String
MenuBarRt As String
MenuBarRow As Integer
MenuModel As Integer
PMImageHeight As Integer
ID As String
SuckerFish 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
PageMenuFrg As Integer
PageFrg As Integer
PageBkg As Integer
ILF As Integer
ILB As Integer
PageMenuBkg As Integer
PageMenuHlFrg As Integer
PageMenuHlBkg As Integer
PageMenuBdr As Integer
End Type
Dim c As ColorVar
User_Defined_Variables gbl, t, pop, c
Color c.PageFrg, c.PageBkg: Cls
ReDim text$(1)
Do
_Limit 60
ScreenSize t, c
control t, in, pop, m, c, b$, text$()
Mouse_Keyboard m, b$
Menu_Bar gbl, t, pop, m, c, b$, SCopy()
Popup_Menu gbl, t, in, pop, m, c, b$, text$(), SCopy()
Page_Menus pop, m
HW_Input_Field t, pop
_Display
Loop Until pop.Show = 0 And b$ = Chr$(27)
System
Sub User_Defined_Variables (gbl As GlobalVar, t As TextVar, pop As PopupVar, c As ColorVar)
Static initiate
If initiate = 0 Then
MakeMyCase = 0 ' Non-zero to attach Select Case code to clipboard. ZERO to ignore.
t.PopupHardwareAceleration = 1 ' Hardware Acceleration On.
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.PageFrg = 15
c.PageBkg = 1
c.ILF = 14
c.ILB = 1
c.PageMenuFrg = 7
c.PageMenuBkg = 1
c.PageMenuHlFrg = 15
c.PageMenuHlBkg = 14
c.PageMenuBdr = 14
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
PageMenuData:
Data "Single-Spaced No Lines Popup Menu"
Data "Double-Spaced No Lines Popup Menu"
Data "Single-Spaced Lined Popup Menu"
Data "Double-Spaced Lined Popup Menu"
Data "Single-Spaced No Lines Hardware Popup Menu"
Data "Double-Spaced No Lines Hardware Popup Menu"
Data "Single-Spaced Lined Hardware Popup Menu"
Data "Double-Spaced Lined Hardware Popup Menu"
Data eof
Data eom
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 everything 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
PopupMenuBarData:
Data Open|Ctrl+O|>Open File
Data Save|Ctrl+S|>Save File
Data Save As|Ctrl+A|>Save As
Data Exit|>Quit
Data eof
Data Cut|Ctrl+X|>Cut
Data Copy|Ctrl+C|>Copy
Data Paste|Ctrl+V|>Paste
Data Clear|Delete|>Clear
Data Select All|Ctrl+A|>Select All
Data Close|Esc|>Close
Data eof
Data Subs|Shift+F2|>View Subs
Data Line Numbers||>Show Lines
Data Compiler Warnings|Ctrl+W|>Warnings
Data eof
Data Find|Ctrl+F3|>Find
Data Repeat Last Find|Shift+F3|>Repeat Find
Data Change|Alt+F3|>Change
Data Clear Search History|Alt+Lt|>History
Data Add / Remove Bookmark|Alt+Rt|>Remove Bookmark
Data Previous Bookmark|Alt+Dn|>Previous Bookmark
Data Go To Line|Ctrl+G|>Go to LIne
Data eof
Data View|Shift+F1|>View Help
Data About||>About
Data eof
Data eom
SuckerfishMenus:
Data Show Line Numbers|>Display Line Numbers
Data Hide Line Numbers|>Hide Line Numbers
Data Show Separator|>Show Separator
Data eof
Data Show Copyright|>Display Copyright
Data Hide Copyright|>Hide Copyright
Data Give Pete Rep Points!|>Pete is Tremendous
Data eof
Data eom
gbl.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"
gbl.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.
gbl.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 -"
gbl.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 MakeMyCase Then
Restore PopupMenuBarData
_Clipboard$ = "Select Case pop.ID" + Chr$(10) + Chr$(13)
Do
Read tmp$
If tmp$ = "eom" Then
Exit Do
ElseIf tmp$ = "eof" Then _Continue
Else
nomi = nomi + 1
j = InStr(tmp$, "|>") + 2
If j Then
_Clipboard$ = _Clipboard$ + " Case " + Chr$(34) + Mid$(tmp$, j) + Chr$(34) + Chr$(10) + Chr$(13) + Chr$(10) + Chr$(13)
End If
End If
Loop
_Clipboard$ = _Clipboard$ + "End Select"
End If
initiate = 0
End If
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 (gbl As GlobalVar, t As TextVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$, SCopy())
If Len(pop.MenuBarLt) + Len(pop.MenuBarRt) = 0 Then Exit Sub
Static initiate, altmx, oldmy, oldmx, pcopyhack, AltBlocker, AltException, nomi, map$, shortcut$, sc$(), id$()
y = CsrLin: x = Pos(0)
pop.ID = "" ' Needed here as well as in popup menu sub. Reason: Shortcut keys used without an open menu will not trigger a negative pop.MenuModel value to nullify this variable in the popup sub.
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
Restore PopupMenuBarData
Do
Read tmp$
If tmp$ = "eom" Then
x$ = "": a$ = "": tmp$ = "": Exit Do
ElseIf tmp$ = "eof" Then _Continue
Else
nomi = nomi + 1
ReDim _Preserve sc$(nomi), id$(nomi)
sc$(nomi) = Chr$(3) + "0" + Chr$(4) + "0" + Chr$(5) + "0" + Space$(10)
If InStr(tmp$, "|>") Then
id$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2))
x$ = Mid$(tmp$, 1, InStr(tmp$, "|>") - 1)
Else
x$ = tmp$
End If
If InStr(x$, "|") Then x$ = LCase$(Mid$(x$, InStr(x$, "|") + 1)) Else x$ = ""
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$, "+"))
End If
Loop
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
Else
If pop.Show = 0 Then
If m.alt Then ' Search for a valid shortcut key.
x$ = gbl.AltKeys
ElseIf m.ctrl Then x$ = gbl.CtrlKeys
ElseIf m.shift Then x$ = gbl.UcaseKeys Else x$ = gbl.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 h = 1 To nomi
If m.shift And Mid$(sc$(h), 2, 1) = "1" Or m.shift = 0 And Mid$(sc$(h), 2, 1) = "0" Then
If m.ctrl And Mid$(sc$(h), 4, 1) = "1" Or m.ctrl = 0 And Mid$(sc$(h), 4, 1) = "0" Then
If m.alt And Mid$(sc$(h), 6, 1) = "1" Or m.alt = 0 And Mid$(sc$(h), 6, 1) = "0" Then
If RTrim$(Mid$(sc$(h), 7)) = LCase$(key$) Then
pop.ID = id$(h) ' Valid Shortcut key found.
Exit For
End If
End If
End If
End If
Next h
End If
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
If pop.SuckerFish Then pop.SuckerFish = -1: gbl.anum = -2: FreeCopy gbl, SCopy(): gbl.anum = -1: FreeCopy gbl, SCopy()
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 (gbl As GlobalVar, t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$, text$(), SCopy())
Static initiate, SFMenuMap, nomi, oldmy, oldmx, myalt, RtClkRedo, SFCounter, SFReversed
Static menu$(), sc$(), MenuID$(), SFMenu(), MenuRestrict(), y, x, atmp As String
Static SFParentT, SFParentR, SFParentB, SFParentL, SFParentW, SFParentH, SFParentNomi, SFParentMenuHL, SFhwWindow&, InsideSFParent, SFParentMenu$(), SFParentSc$(), SFParentID$()
If pop.MenuModel = 5 Then
If initiate = 0 Then
j = _Width: t.fw = _FontWidth: t.fh = _FontHeight
CRed = 255: CGrn = 255: CBlu = 255: pop.PMImageHeight = 30
t1 = _NewImage((j + 1) * t.fw, 31 * t.fh, 32)
_Dest t1
Line (0, 0)-(0, pop.PMImageHeight * t.fh), _RGB32(CRed, CGrn, CBlu), B
t.PageMenuHWBack = _CopyImage(t1, 33)
Line (0, pop.PMImageHeight * t.fh)-(j * t.fw, pop.PMImageHeight * t.fh), _RGB32(CRed, CGrn, CBlu), B
t.PageMenuHWFront = _CopyImage(t1, 33)
_Dest 0
_FreeImage t1
Restore PageMenuData: pop.mheight = 0: ReDim menu$(0)
For i = 1 To pop.Show
Do: Read tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ = "eof" Then If cnt + 1 = pop.Show Then Exit Do Else cnt = cnt + 1: _Continue
If cnt + 1 = pop.Show Then
pop.mheight = pop.mheight + 1: ReDim _Preserve menu$(pop.mheight): menu$(pop.mheight) = tmp$
If k < Len(tmp$) Then k = Len(tmp$)
End If
Loop
Next
pop.mwidth = k + 2
cnt = 0: k = 0: mxalt = 0
x$ = Mid$(PageMap$(m.y), m.x, 1)
pop.MenuL = InStr(PageMap$(m.y), x$) - 1
pop.MenuR = pop.MenuL + pop.mwidth
pop.MenuB = pop.MenuT + pop.mheight
Locate pop.MenuT, pop.MenuL
Color c.PageMenuBdr, c.PageMenuBkg
If t.PopupHardwareAceleration Then
For i = 0 To pop.mheight - 1
Locate pop.MenuT + i, pop.MenuL
Print Space$(pop.mwidth);
Next
Else
For i = 1 To pop.mheight
Locate , pop.MenuL
Print Chr$(179); Space$(pop.mwidth - 2) + Chr$(179)
Next
Color c.PageMenuBdr, c.PageMenuBkg: Locate , pop.MenuL
Print Chr$(192) + String$(pop.mwidth - 2, 196) + Chr$(217);
End If
Color c.PageMenuFrg, c.PageMenuBkg
For i = 0 To pop.mheight - 1
Locate pop.MenuT + i, pop.MenuL + 1
Print menu$(i + 1);
Next
initiate = 1
Else
While -1
Do
If t.ScrnResize = 1 Then pop.Choice = -1: Exit Do ' Force popup to close when resizing app.
If m.y >= pop.MenuT And m.y < pop.MenuB And m.x >= pop.MenuL And m.x <= pop.MenuR Then
InsideMenu = _TRUE
Else
InsideMenu = _FALSE
End If
mxalt = 0
If b$ = Chr$(0) + "H" Or m.mw = -1 Then
If pop.MenuHL - pop.MenuT > 0 Then
myalt = pop.MenuHL - 1: mxalt = -1
End If
ElseIf b$ = Chr$(0) + "P" Or m.mw = 1 Then
If pop.MenuHL = 0 Then
myalt = pop.MenuT: mxalt = -1
Else
If (pop.MenuHL - pop.MenuT + 1) < nomi Then
myalt = pop.MenuHL + 1: mxalt = -1
End If
End If
ElseIf b$ = Chr$(13) And pop.MenuHL Or m.lb = 2 And InsideMenu = _TRUE Or m.mb = 2 And pop.MenuHL Then
pop.Choice = pop.MenuHL - pop.MenuT + 1
Exit Do
ElseIf b$ = Chr$(27) Then
Exit Do
End If
' Popup is present.
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
i = myalt <> oldmy Or myalt = oldmy And m.x <> oldmx Or pop.MenuHL And m.lb = 2
If i Or mxalt = -1 Then ' Works for odd or even number top margins.
If t.PopupHardwareAceleration Then j = 0 Else j = 2
If pop.MenuHL Then ' Remove highlighting from previous hover.
atmp = Space$(pop.mwidth - j)
Mid$(atmp, Abs(j - 2 + j / 2), Len(menu$(pop.MenuHL + 1 - pop.MenuT))) = menu$(pop.MenuHL + 1 - pop.MenuT)
Locate pop.MenuHL, pop.MenuL + j / 2
Color c.PageMenuFrg, c.PageMenuBkg
Print atmp;
End If
atmp = Space$(pop.mwidth - j)
Mid$(atmp, Abs(j - 2 + j / 2), Len(menu$(myalt + 1 - pop.MenuT))) = menu$(myalt + 1 - pop.MenuT)
Locate myalt, pop.MenuL + j / 2
Color c.PageMenuHlFrg, c.PageMenuHlBkg
Print atmp;
Color c.PageMenuFrg, c.PageMenuBkg
pop.MenuHL = myalt
End If
Else
' Toggle close popup menu.
If m.lb = 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
End If
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.
mxalt = 0: initiate = 0: pop.Show = 0: pop.MenuModel = -pop.MenuModel
pop.MenuT = 0: pop.MenuL = 0: pop.MenuR = 0: pop.MenuB = 0: pop.MenuHL = 0: pop.mwidth = 0: pop.mheight = 0
gbl.anum = -1: FreeCopy gbl, SCopy()
b$ = ""
If pop.Choice > 0 Then
j = pop.mwidth - 2
Rem pop.ID = MenuID$(pop.Choice)
Color c.ILF, c.ILB
Locate pop.PageMenuy, pop.PageMenux: Print Space$(j);
Locate pop.PageMenuy, pop.PageMenux: Print menu$(pop.Choice);
End If
Exit While
Wend
End If
Else
If pop.MenuModel < 0 Then
pop.PageMenuy = 0: pop.PageMenux = 0: oldmy = 0: myalt = 0: pop.MenuHL = 0: pop.MenuT = 0: pop.MenuB = 0: pop.MenuL = 0: pop.MenuR = 0
pop.MenuModel = 0: pop.Choice = 0: pop.ChoiceName = "": pop.ID = "" ' Completed cycle.
Erase menu$: ReDim MenuID$(0): ReDim sc$(0) ' Note: Can't erase because it isn't defined until later in the code.
End If
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.SuckerFish = -1 Then ' Closed by slider in Menubar sub.
pop.SuckerFish = 0: SFParentT = 0: SFParentR = 0: SFParentB = 0: SFParentL = 0
SFParentW = 0: SFParentH = 0: SFParentNomi = 0: SFParentMenuHL = 0: InsideSFParent = 0: SFhwWindow& = 0
ReDim SFParentMenu$(0), SFParentSc$(0), SFParentID$(0), SFMenuRestrict(0)
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
End If
If pop.Show Then
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
y = CsrLin: x = Pos(0)
If SFMenuMap = 0 Then
SFMenuMap = 1: SFCounter = 0
Restore PopupMenuBarData
Do
Read tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ <> "eof" Then
SFCounter = SFCounter + 1: ReDim _Preserve SFMenu(SFCounter)
If InStr(tmp$, Chr$(16)) Then j = j + 1: SFMenu(SFCounter) = j
End If
Loop
SFCounter = 0
End If
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
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
Restore PopupMenuBarData: SFCounter = 0
For i = 1 To pop.Show - 1
Do
Read tmp$
If tmp$ = "eof" Then Exit Do Else SFCounter = SFCounter + 1
Loop
Next
Case 4
Restore SuckerfishMenus
For i = 1 To pop.SuckerFish - 1
Do: Read tmp$: If tmp$ = "eof" Then Exit Do
Loop
Next
End Select
ReDim menu$(0), sc$(0), MenuID$(0)
Do
Read tmp$
If tmp$ = "eof" Then Exit Do
nomi = nomi + 1
ReDim _Preserve menu$(nomi), sc$(nomi), MenuID$(nomi)
If InStr(tmp$, "|") Then
If InStr(tmp$, "|>") Then MenuID$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2)): tmp$ = _Trim$(Mid$(tmp$, 1, InStr(tmp$, "|>") - 1))
If InStr(tmp$, "|") Then
short$ = _Trim$(Mid$(tmp$, InStr(tmp$, "|") + 1))
tmp$ = Mid$(tmp$, 1, InStr(tmp$, "|") - 1)
End If
x$ = tmp$: If Len(short$) Then x$ = x$ + Chr$(4) + short$
menu$(nomi) = x$: If jj < Len(x$) Then jj = Len(x$)
Else
menu$(nomi) = tmp$
End If
sc$(nomi) = Chr$(3) + "0" + Chr$(4) + "0" + Chr$(5) + "0" + Space$(10)
If InStr(tmp$, "|>") Then
MenuID$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2))
x$ = Mid$(tmp$, 1, InStr(tmp$, "|>") - 1)
Else
x$ = tmp$
End If
If InStr(x$, "|") Then x$ = LCase$(Mid$(x$, InStr(x$, "|") + 1)) Else x$ = ""
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
x$ = LCase$(short$)
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$(LCase$(short$), _InStrRev("+" + LCase$(short$), "+"))
short$ = "": x$ = ""
Loop
For i = 1 To nomi
If InStr(menu$(i), Chr$(4)) Then
k = jj - Len(menu$(i))
x$ = Mid$(menu$(i), 1, InStr(menu$(i), Chr$(4)) - 1) + String$(k + 3, ".") + Mid$(menu$(i), InStr(menu$(i), Chr$(4)) + 1)
Else
x$ = menu$(i)
End If
menu$(i) = x$
Next
ReDim MenuRestrict(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: MenuRestrict(i) = 1: Next
Else
If t.hl = 0 Then ' Unhighlighted text - Cut/Copy/Paste/Clear unavilable. Select All available.
For i = 1 To 4: MenuRestrict(i) = 1: Next
End If
End If
If text$(in.fld) = "" Then MenuRestrict(5) = 1 ' Cannot Select All on a blank input line.
If Len(_Clipboard$) Then MenuRestrict(3) = 0 Else MenuRestrict(3) = 1 ' Paste available if clipboard is loaded.
End If
' Open popup.
If pop.SuckerFish Then gbl.anum = 2 Else gbl.anum = 1
FreeCopy gbl, SCopy()
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
Case 4
pop.MenuL = SFParentR
If pop.MenuL + pop.mwidth >= t.mr - pop.Shadow Then
pop.MenuL = SFParentL - pop.mwidth
SFReversed = _TRUE
Else
SFReversed = 0
End If
pop.MenuT = pop.MenuBarRow + 1
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 Or pop.MenuModel = 4 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 And pop.MenuModel <> 4 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.
If pop.MenuModel = 1 Then k = 2 Else k = 1
Line (pop.mwidth * t.fw - hWth + 1, hHgt * k)-((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 ' Space between menu items.
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
If pop.SuckerFish = 0 Or pop.SuckerFish And SFReversed = 0 Then
Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Else
If SFReversed Then
If i >= SFParentH And pop.VSpacing = 2 Or i > SFParentH And pop.VSpacing = 1 Then Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1)) Else Print
Else
Print
End If
End If
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 MenuRestrict(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
If m.lb = 2 And pop.SuckerFish Then
If InsideSFParent = _TRUE Then
pop.MenuT = SFParentT: pop.MenuR = SFParentR + 1: pop.MenuB = SFParentB + 1: pop.MenuL = SFParentL
pop.MenuModel = 2: pop.Show = pop.SuckerFish
pop.mwidth = SFParentW: nomi = SFParentNomi
pop.mheight = SFParentH
pop.SuckerFish = 0: m.lb = 0
InsideSFParent = 0
ReDim menu$(nomi), sc$(nomi), MenuID$(nomi), SFMenuRestrict(nomi)
For i = 1 To SFParentNomi
menu$(i) = SFParentMenu$(i): sc$(i) = SFParentSc$(i)
MenuID$(i) = SFParentID$(i): MenuRestrict(i) = SFMenuRestrict(i)
Next
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
pop.MenuHL = SFParentMenuHL: oldy = 0
pop.hwWindow = SFhwWindow&
gbl.anum = -2: FreeCopy gbl, SCopy()
End If
End If
If m.y > pop.MenuT And m.y < pop.MenuB And m.x >= pop.MenuL And m.x <= pop.MenuR Then
InsideMenu = _TRUE
Else
InsideMenu = _FALSE
End If
If pop.SuckerFish Then
If m.y >= SFParentT And m.y <= SFParentB And m.x >= SFParentL And m.x <= SFParentR Then
InsideSFParent = _TRUE
Else
InsideSFParent = _FALSE
End If
End If
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.lb = 2 And InsideMenu = _TRUE Or m.mb = 2 And pop.MenuHL Then
If pop.MenuHL = 0 Then pop.MenuHL = m.y ' Happens if a click is made when a menu opens up over the mouse before the mouse is moved.
j = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
If MenuRestrict(j) = 0 Then
If InStr(menu$(j), Chr$(16)) And pop.MenuModel = 2 Then ' Suckerfish menu pointer.
If pop.SuckerFish = 0 Then
pop.SuckerFish = SFMenu(SFCounter + j): pop.MenuModel = 4: pop.CloseReOpen = pop.Show
SFParentT = pop.MenuT: SFParentR = pop.MenuR - 1: SFParentB = pop.MenuB - 1
SFParentL = pop.MenuL: SFParentW = pop.mwidth: SFParentH = pop.mheight
ReDim SFParentMenu$(nomi), SFParentSc$(nomi), SFParentID$(nomi), SFMenuRestrict(nomi)
For i = 1 To nomi
SFParentMenu$(i) = menu$(i): SFParentSc$(i) = sc$(i)
SFParentID$(i) = MenuID$(i): SFMenuRestrict(i) = MenuRestrict(i)
Next
SFParentNomi = nomi: SFParentMenuHL = pop.MenuHL: SFhwWindow& = pop.hwWindow
End If
Exit Do
Else
pop.Choice = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
pop.ID = MenuID$(pop.Choice): Exit Do
End If
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 MenuRestrict((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 MenuRestrict((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
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$ = gbl.AltKeys
ElseIf m.ctrl Then x$ = gbl.CtrlKeys
ElseIf m.shift Then x$ = gbl.UcaseKeys Else x$ = gbl.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): pop.ID = MenuID$(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
If SFhwWindow& Then _PutImage ((SFParentL - 1) * t.fw, (SFParentT - 1) * t.fh), SFhwWindow&
End If
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 ' Adding initiate here prevents a pop.Show -1 call that was first positive to open the popup and copy the screen.
If pop.SuckerFish = 0 Or pop.SuckerFish And pop.CloseReOpen = 0 Then
If pop.SuckerFish And pop.CloseReOpen = 0 Then gbl.anum = -2: FreeCopy gbl, SCopy()
gbl.anum = -1: FreeCopy gbl, SCopy()
End If
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
pop.SuckerFish = 0: SFParentT = 0: SFParentR = 0: SFParentB = 0: SFParentL = 0: SFhwWindow& = 0
SFParentW = 0: SFParentH = 0: SFParentNomi = 0: SFParentMenuHL = 0: InsideSFParent = 0: SFhwWindow& = 0
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
Exit While
End If
Wend
End If
End If
End Sub
Sub control (t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, 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 pop.Choice > 0 And pop.MenuModel = -5 Then m.autokey = Chr$(0) + Chr$(58 + pop.Choice)
If Mid$(b$, 2, 1) >= Chr$(59) And Mid$(b$, 2, 1) <= Chr$(66) Then
If pop.MenuModel = 2 And pop.Show Or pop.MenuModel = 4 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.MenuModel < 0 Then Locate _Height - 1, 1: Color c.PageFrg, c.PageBkg: Print Space$(_Width);
If Len(pop.ID) Then
Sound 1000, .1
Select Case pop.ID
Case "Open File"
pop.ChoiceName = "You selected Open File."
Case "Save File"
pop.ChoiceName = "You selected Save File."
Case "Save As"
pop.ChoiceName = "You selected Save File As..."
Case "Quit"
pop.ChoiceName = "Are you sure you want to quit??? "
Case "Cut"
pop.ChoiceName = "You selected Cut Text."
Case "Copy"
pop.ChoiceName = "You selected Copy Text."
Case "Paste"
pop.ChoiceName = "You selected Paste Text."
Case "Clear"
pop.ChoiceName = "You selected Clear Text."
Case "Select All"
pop.ChoiceName = "You selected all text."
Case "Close"
pop.ChoiceName = "You selected to close the menu."
Case "View Subs"
pop.ChoiceName = "You selected to view the subs."
Case "Show Lines"
pop.ChoiceName = "You selected to Show Lines."
Case "Warnings"
pop.ChoiceName = "You selected to view compiler warnings."
Case "Find"
pop.ChoiceName = "You selected to Find Text."
Case "Repeat Find"
pop.ChoiceName = "You selected to Repeat Text Find."
Case "Change"
pop.ChoiceName = "You selected to Change Text."
Case "History"
pop.ChoiceName = "You selected to View History."
Case "Remove Bookmark"
pop.ChoiceName = "You selected to Remove a Bookmark."
Case "Previous Bookmark"
pop.ChoiceName = "You selected to go to Previous Bookmark"
Case "Go to LIne"
pop.ChoiceName = "You selected to go to a line number."
Case "View Help"
pop.ChoiceName = "You selected to View Help."
Case "About"
pop.ChoiceName = "You selected to view info about this app."
End Select
Locate _Height - 1, 1: Color c.PageFrg, c.PageBkg: Print Space$(_Width);
Locate _Height - 1, 2: Print pop.ChoiceName;
Else
If pop.Choice > 0 Then
Sound 1000, .1
seen = 1
Locate _Height - 1, 1: Color c.PageFrg, c.PageBkg: 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 c.PageFrg, c.PageBkg: Print Space$(_Width);: seen = 0
End If
End If
End If
Exit Sub '===============================>
Menu_Layout:
Color c.PageFrg, c.PageBkg: 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 c.ILF, c.ILB
insert t, a$
Locate CsrLin + 2, 1
Color 1, 3
For i = 1 To 20
Print String$(_Width, Chr$(177))
Next
Color c.ILF, c.ILB
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
Sub FreeCopy (gbl As GlobalVar, SCopy())
Static fcopy$
Dim i As Integer
If gbl.anum > 0 Then
i = 0
Do
i = i + 1
i$ = LTrim$(Str$(i)) + "|"
If InStr(fcopy$, i$) = 0 Then Exit Do
Loop
fcopy$ = fcopy$ + i$
SCopy(gbl.anum) = i
PCopy gbl.MyScreen, SCopy(gbl.anum)
ElseIf gbl.anum < 0 Then
i$ = LTrim$(Str$(SCopy(Abs(gbl.anum)))) + "|"
j = InStr(fcopy$, i$) - 1
fcopy$ = Mid$(fcopy$, 1, j) + Mid$(fcopy$, j + Len(i$) + 1)
PCopy SCopy(Abs(gbl.anum)), gbl.MyScreen
End If
Rem _Title Str$(gbl.MyScreen) + " " + Str$(gbl.anum) + " " + Str$(SCopy(Abs(gbl.anum))) + " " + Str$(i) + " fcopy = " + fcopy$
End Sub
Sub insert (t As TextVar, ins$)
Static initiate, MapID As Integer, k
y = CsrLin: x = Pos(0): restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If initiate = 0 Then
initiate = 1
ReDim _Preserve PageMap$(222)
j = 200 ' Make Input Field
t.fw = _FontWidth: t.fh = _FontHeight
CRed = 255: CGrn = 255: CBlu = 255
t1 = _NewImage((j + 1) * t.fw, 2 * t.fh, 32)
_Dest t1
Line (0, 0)-(j * t.fw, t.fh), _RGB32(CRed, CGrn, CBlu), B
t.hwFieldFront = _CopyImage(t1, 33)
_FreeImage t1
j = 1
t1 = _NewImage((j + 1) * t.fw, 2 * t.fh, 32)
_Dest t1
Line (0, 0)-(0, t.fh), _RGB32(CRed, CGrn, CBlu), B
t.hwFieldBack = _CopyImage(t1, 33)
_FreeImage t1
_Dest 0
End If
If LTrim$(PageMap$(CsrLin)) = "" Then ' Prevents duplication if this sub is called multiple times.
MapID = MapID + 1
Restore PageMenuData
For i = 1 To MapID
Do
Read tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ = "eof" Then If cnt + 1 = MapID Then Exit Do Else cnt = cnt + 1: _Continue
If cnt + 1 = MapID Then
If k < Len(tmp$) Then k = Len(tmp$)
End If
Loop
Next
If MapID = 222 Then ' Hard Limit
_MessageBox "Configuration Error", "The maximun number of PageMap arrays (222) has been reached.", "error"
System
End If
PageMap$(CsrLin) = Space$(_Width)
Mid$(PageMap$(y), x, k) = String$(k, Asc(Chr$(MapID + 33)))
t.InputLine = y: t.FldL = x: t.FldR = x + k ' Future change needed here.
End If
If t.PopupHardwareAceleration = 0 Then
Locate y - 1, x - 1: Print Chr$(218) + String$(k, 196) + Chr$(191)
Locate y, x - 1: Print Chr$(179);: Locate y, x + k: Print Chr$(179);
Locate y + 1, x - 1: Print Chr$(192) + String$(k, 196) + Chr$(217);
Locate y, x + k - 1: Print Chr$(25);
End If
Locate y, x: Print ins$;
Locate y, x
Color restore_color1, restore_color2
End Sub
Sub Page_Menus (pop As PopupVar, m As MouseVar)
If m.lb = 2 And pop.MenuModel = 0 Then
x$ = LTrim$(Mid$(PageMap$(m.y), m.x, 1))
If Len(x$) Then
pop.MenuModel = 5: pop.Show = Asc(x$) - 33: pop.MenuT = m.y + 1
pop.PageMenuy = m.y
k = Asc(x$)
pop.PageMenux = InStr(PageMap$(m.y), Chr$(k))
End If
End If
End Sub
Sub HW_Input_Field (t As TextVar, pop As PopupVar)
If t.PopupHardwareAceleration = 0 Then Exit Sub '========================>
If pop.MenuModel = 5 And pop.PMImageHeight Then
dx1 = (pop.MenuL - 1) * t.fw: dy1 = (pop.MenuT - 1) * t.fh
sx1 = 0: sy1 = (pop.PMImageHeight - pop.mheight) * t.fh
sx2 = (pop.mwidth - 0) * t.fw: sy2 = pop.PMImageHeight * t.fh
_PutImage (dx1, dy1), t.PageMenuHWFront, , (sx1, sy1)-(sx2, sy2)
_PutImage ((pop.MenuL + pop.mwidth - 1) * t.fw, (pop.MenuT - 1) * t.fh), t.PageMenuHWBack, , (0 * t.fw, 0)-((pop.mwidth - 1) * t.fw, pop.mheight * t.fh)
End If
cRow = t.InputLine
k1 = 1
LtInFld = t.FldL - 2
If t.PopupHardwareAceleration And pop.Show <> 0 Then
p1 = t.fw \ 2: j1 = 1
If cRow = pop.MenuB - 1 And pop.Shadow Then k1 = 3
End If
If pop.Show And cRow < pop.MenuT + j1 Or pop.Show And cRow > pop.MenuB - pop.Shadow - 1 Or pop.Show = 0 Then
_PutImage (LtInFld * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((t.FldR - t.FldL + 2) * t.fw, t.fh)
_PutImage (t.FldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
Else
If LtInFld < pop.MenuL Then _PutImage (LtInFld * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((pop.MenuL + 1 - t.FldL) * t.fw + p1 * k1, t.fh)
sx1 = (pop.MenuR - pop.MenuL + pop.MenuL - (t.FldL - 1)) * t.fw: sx2 = (t.FldR - t.FldL + 2) * t.fw + p1: sy1 = 0: sy2 = t.fh
_PutImage ((pop.MenuL + (pop.MenuR - pop.MenuL) - 1) * t.fw - p1, (cRow - 1) * t.fh), t.hwFieldFront, , (sx1, sy1)-(sx2, sy2)
_PutImage (t.FldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
End If
End Sub
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
Okay, added a cute little hardware image triangle to the popdown menu.
Code: (Select All)
$Resize:On
_ScreenMove 200, 20
ReDim Shared PageMap$(0)
Type GlobalVar
anum As Integer
MyScreen As Integer
UcaseKeys As String
LcaseKeys As String
CtrlKeys As String
AltKeys As String
End Type
Dim gbl As GlobalVar
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.
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
InputLine As Integer ' Records cursor row.
hwFieldPresent As Integer
hwFieldFront As Long
hwFieldBack As Long
PopupHardwareAceleration As Integer
PageMenuHWFront As Long
PageMenuHWBack As Long
FldL As Integer
FldR As Integer
tri 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
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
PageMenuy As Integer
PageMenux As Integer
MenuBar As String
MenuBarLt As String
MenuBarRt As String
MenuBarRow As Integer
MenuModel As Integer
PMImageHeight As Integer
ID As String
SuckerFish 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
PageMenuFrg As Integer
PageFrg As Integer
PageBkg As Integer
ILF As Integer
ILB As Integer
PageMenuBkg As Integer
PageMenuHlFrg As Integer
PageMenuHlBkg As Integer
PageMenuBdr As Integer
End Type
Dim c As ColorVar
User_Defined_Variables gbl, t, pop, c
Color c.PageFrg, c.PageBkg: Cls
ReDim text$(1)
Do
_Limit 60
ScreenSize t, c
control t, in, pop, m, c, b$, text$()
Mouse_Keyboard m, b$
Menu_Bar gbl, t, pop, m, c, b$, SCopy()
Popup_Menu gbl, t, in, pop, m, c, b$, text$(), SCopy()
Page_Menus pop, m
HW_Input_Field t, pop
_Display
Loop Until pop.Show = 0 And b$ = Chr$(27)
System
Sub User_Defined_Variables (gbl As GlobalVar, t As TextVar, pop As PopupVar, c As ColorVar)
Static initiate
If initiate = 0 Then
MakeMyCase = 0 ' Non-zero to attach Select Case code to clipboard. ZERO to ignore.
t.PopupHardwareAceleration = 1 ' Hardware Acceleration On.
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.PageFrg = 15
c.PageBkg = 1
c.ILF = 14
c.ILB = 1
c.PageMenuFrg = 7
c.PageMenuBkg = 1
c.PageMenuHlFrg = 15
c.PageMenuHlBkg = 14
c.PageMenuBdr = 14
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
PageMenuData:
Data "Single-Spaced No Lines Popup Menu"
Data "Double-Spaced No Lines Popup Menu"
Data "Single-Spaced Lined Popup Menu"
Data "Double-Spaced Lined Popup Menu"
Data "Single-Spaced No Lines Hardware Popup Menu"
Data "Double-Spaced No Lines Hardware Popup Menu"
Data "Single-Spaced Lined Hardware Popup Menu"
Data "Double-Spaced Lined Hardware Popup Menu"
Data eof
Data eom
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 everything 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
PopupMenuBarData:
Data Open|Ctrl+O|>Open File
Data Save|Ctrl+S|>Save File
Data Save As|Ctrl+A|>Save As
Data Exit|>Quit
Data eof
Data Cut|Ctrl+X|>Cut
Data Copy|Ctrl+C|>Copy
Data Paste|Ctrl+V|>Paste
Data Clear|Delete|>Clear
Data Select All|Ctrl+A|>Select All
Data Close|Esc|>Close
Data eof
Data Subs|Shift+F2|>View Subs
Data Line Numbers||>Show Lines
Data Compiler Warnings|Ctrl+W|>Warnings
Data eof
Data Find|Ctrl+F3|>Find
Data Repeat Last Find|Shift+F3|>Repeat Find
Data Change|Alt+F3|>Change
Data Clear Search History|Alt+Lt|>History
Data Add / Remove Bookmark|Alt+Rt|>Remove Bookmark
Data Previous Bookmark|Alt+Dn|>Previous Bookmark
Data Go To Line|Ctrl+G|>Go to LIne
Data eof
Data View|Shift+F1|>View Help
Data About||>About
Data eof
Data eom
SuckerfishMenus:
Data Show Line Numbers|>Display Line Numbers
Data Hide Line Numbers|>Hide Line Numbers
Data Show Separator|>Show Separator
Data eof
Data Show Copyright|>Display Copyright
Data Hide Copyright|>Hide Copyright
Data Give Pete Rep Points!|>Pete is Tremendous
Data eof
Data eom
gbl.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"
gbl.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.
gbl.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 -"
gbl.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 MakeMyCase Then
Restore PopupMenuBarData
_Clipboard$ = "Select Case pop.ID" + Chr$(10) + Chr$(13)
Do
Read tmp$
If tmp$ = "eom" Then
Exit Do
ElseIf tmp$ = "eof" Then _Continue
Else
nomi = nomi + 1
j = InStr(tmp$, "|>") + 2
If j Then
_Clipboard$ = _Clipboard$ + " Case " + Chr$(34) + Mid$(tmp$, j) + Chr$(34) + Chr$(10) + Chr$(13) + Chr$(10) + Chr$(13)
End If
End If
Loop
_Clipboard$ = _Clipboard$ + "End Select"
End If
initiate = 0
End If
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 (gbl As GlobalVar, t As TextVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$, SCopy())
If Len(pop.MenuBarLt) + Len(pop.MenuBarRt) = 0 Then Exit Sub
Static initiate, altmx, oldmy, oldmx, pcopyhack, AltBlocker, AltException, nomi, map$, shortcut$, sc$(), id$()
y = CsrLin: x = Pos(0)
pop.ID = "" ' Needed here as well as in popup menu sub. Reason: Shortcut keys used without an open menu will not trigger a negative pop.MenuModel value to nullify this variable in the popup sub.
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
Restore PopupMenuBarData
Do
Read tmp$
If tmp$ = "eom" Then
x$ = "": a$ = "": tmp$ = "": Exit Do
ElseIf tmp$ = "eof" Then _Continue
Else
nomi = nomi + 1
ReDim _Preserve sc$(nomi), id$(nomi)
sc$(nomi) = Chr$(3) + "0" + Chr$(4) + "0" + Chr$(5) + "0" + Space$(10)
If InStr(tmp$, "|>") Then
id$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2))
x$ = Mid$(tmp$, 1, InStr(tmp$, "|>") - 1)
Else
x$ = tmp$
End If
If InStr(x$, "|") Then x$ = LCase$(Mid$(x$, InStr(x$, "|") + 1)) Else x$ = ""
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$, "+"))
End If
Loop
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
Else
If pop.Show = 0 Then
If m.alt Then ' Search for a valid shortcut key.
x$ = gbl.AltKeys
ElseIf m.ctrl Then x$ = gbl.CtrlKeys
ElseIf m.shift Then x$ = gbl.UcaseKeys Else x$ = gbl.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 h = 1 To nomi
If m.shift And Mid$(sc$(h), 2, 1) = "1" Or m.shift = 0 And Mid$(sc$(h), 2, 1) = "0" Then
If m.ctrl And Mid$(sc$(h), 4, 1) = "1" Or m.ctrl = 0 And Mid$(sc$(h), 4, 1) = "0" Then
If m.alt And Mid$(sc$(h), 6, 1) = "1" Or m.alt = 0 And Mid$(sc$(h), 6, 1) = "0" Then
If RTrim$(Mid$(sc$(h), 7)) = LCase$(key$) Then
pop.ID = id$(h) ' Valid Shortcut key found.
Exit For
End If
End If
End If
End If
Next h
End If
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
If pop.SuckerFish Then pop.SuckerFish = -1: gbl.anum = -2: FreeCopy gbl, SCopy(): gbl.anum = -1: FreeCopy gbl, SCopy()
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 (gbl As GlobalVar, t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$, text$(), SCopy())
Static initiate, SFMenuMap, nomi, oldmy, oldmx, myalt, RtClkRedo, SFCounter, SFReversed
Static menu$(), sc$(), MenuID$(), SFMenu(), MenuRestrict(), y, x, atmp As String
Static SFParentT, SFParentR, SFParentB, SFParentL, SFParentW, SFParentH, SFParentNomi, SFParentMenuHL, SFhwWindow&, InsideSFParent, SFParentMenu$(), SFParentSc$(), SFParentID$()
If pop.MenuModel = 5 Then
If initiate = 0 Then
j = _Width: t.fw = _FontWidth: t.fh = _FontHeight
CRed = 255: CGrn = 255: CBlu = 255: pop.PMImageHeight = 30
t1 = _NewImage((j + 1) * t.fw, 31 * t.fh, 32)
_Dest t1
Line (0, 0)-(0, pop.PMImageHeight * t.fh), _RGB32(CRed, CGrn, CBlu), B
t.PageMenuHWBack = _CopyImage(t1, 33)
Line (0, pop.PMImageHeight * t.fh)-(j * t.fw, pop.PMImageHeight * t.fh), _RGB32(CRed, CGrn, CBlu), B
t.PageMenuHWFront = _CopyImage(t1, 33)
_Dest 0
_FreeImage t1
Restore PageMenuData: pop.mheight = 0: ReDim menu$(0)
For i = 1 To pop.Show
Do: Read tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ = "eof" Then If cnt + 1 = pop.Show Then Exit Do Else cnt = cnt + 1: _Continue
If cnt + 1 = pop.Show Then
pop.mheight = pop.mheight + 1: ReDim _Preserve menu$(pop.mheight): menu$(pop.mheight) = tmp$
If k < Len(tmp$) Then k = Len(tmp$)
End If
Loop
Next
pop.mwidth = k + 2
cnt = 0: k = 0: mxalt = 0
x$ = Mid$(PageMap$(m.y), m.x, 1)
pop.MenuL = InStr(PageMap$(m.y), x$) - 1
pop.MenuR = pop.MenuL + pop.mwidth
pop.MenuB = pop.MenuT + pop.mheight
Locate pop.MenuT, pop.MenuL
Color c.PageMenuBdr, c.PageMenuBkg
If t.PopupHardwareAceleration Then
For i = 0 To pop.mheight - 1
Locate pop.MenuT + i, pop.MenuL
Print Space$(pop.mwidth + 1);
Next
Else
For i = 1 To pop.mheight
Locate , pop.MenuL
Print Chr$(179); Space$(pop.mwidth - 2) + Chr$(179)
Next
Color c.PageMenuBdr, c.PageMenuBkg: Locate , pop.MenuL
Print Chr$(192) + String$(pop.mwidth - 2, 196) + Chr$(217);
End If
Color c.PageMenuFrg, c.PageMenuBkg
For i = 0 To pop.mheight - 1
Locate pop.MenuT + i, pop.MenuL + 1
Print menu$(i + 1);
Next
initiate = 1
Else
While -1
Do
If t.ScrnResize = 1 Then pop.Choice = -1: Exit Do ' Force popup to close when resizing app.
If m.y >= pop.MenuT And m.y < pop.MenuB And m.x >= pop.MenuL And m.x <= pop.MenuR Then
InsideMenu = _TRUE
Else
InsideMenu = _FALSE
End If
mxalt = 0
If b$ = Chr$(0) + "H" Or m.mw = -1 Then
If pop.MenuHL - pop.MenuT > 0 Then
myalt = pop.MenuHL - 1: mxalt = -1
End If
ElseIf b$ = Chr$(0) + "P" Or m.mw = 1 Then
If pop.MenuHL = 0 Then
myalt = pop.MenuT: mxalt = -1
Else
If (pop.MenuHL - pop.MenuT + 1) < nomi Then
myalt = pop.MenuHL + 1: mxalt = -1
End If
End If
ElseIf b$ = Chr$(13) And pop.MenuHL Or m.lb = 2 And InsideMenu = _TRUE Or m.mb = 2 And pop.MenuHL Then
pop.Choice = pop.MenuHL - pop.MenuT + 1
Exit Do
ElseIf b$ = Chr$(27) Then
Exit Do
End If
' Popup is present.
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
i = myalt <> oldmy Or myalt = oldmy And m.x <> oldmx Or pop.MenuHL And m.lb = 2
If i Or mxalt = -1 Then ' Works for odd or even number top margins.
If t.PopupHardwareAceleration Then j = 0: k = 1 Else j = 2: k = 0
If pop.MenuHL Then ' Remove highlighting from previous hover.
atmp = Space$(pop.mwidth + k - j)
Mid$(atmp, Abs(j - 2 + j / 2), Len(menu$(pop.MenuHL + 1 - pop.MenuT))) = menu$(pop.MenuHL + 1 - pop.MenuT)
Locate pop.MenuHL, pop.MenuL + j / 2
Color c.PageMenuFrg, c.PageMenuBkg
Print atmp;
End If
atmp = Space$(pop.mwidth + k - j)
Mid$(atmp, Abs(j - 2 + j / 2), Len(menu$(myalt + 1 - pop.MenuT))) = menu$(myalt + 1 - pop.MenuT)
Locate myalt, pop.MenuL + j / 2
Color c.PageMenuHlFrg, c.PageMenuHlBkg
Print atmp;
Color c.PageMenuFrg, c.PageMenuBkg
pop.MenuHL = myalt
End If
Else
' Toggle close popup menu.
If m.lb = 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
End If
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.
mxalt = 0: initiate = 0: pop.Show = 0: pop.MenuModel = -pop.MenuModel
pop.MenuT = 0: pop.MenuL = 0: pop.MenuR = 0: pop.MenuB = 0: pop.MenuHL = 0: pop.mwidth = 0: pop.mheight = 0
gbl.anum = -1: FreeCopy gbl, SCopy()
b$ = ""
If pop.Choice > 0 Then
j = pop.mwidth - 2
Rem pop.ID = MenuID$(pop.Choice)
Color c.ILF, c.ILB
Locate pop.PageMenuy, pop.PageMenux: Print Space$(j);
Locate pop.PageMenuy, pop.PageMenux: Print menu$(pop.Choice);
End If
Exit While
Wend
End If
Else
If pop.MenuModel < 0 Then
pop.PageMenuy = 0: pop.PageMenux = 0: oldmy = 0: myalt = 0: pop.MenuHL = 0: pop.MenuT = 0: pop.MenuB = 0: pop.MenuL = 0: pop.MenuR = 0
pop.MenuModel = 0: pop.Choice = 0: pop.ChoiceName = "": pop.ID = "" ' Completed cycle.
Erase menu$: ReDim MenuID$(0): ReDim sc$(0) ' Note: Can't erase because it isn't defined until later in the code.
End If
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.SuckerFish = -1 Then ' Closed by slider in Menubar sub.
pop.SuckerFish = 0: SFParentT = 0: SFParentR = 0: SFParentB = 0: SFParentL = 0
SFParentW = 0: SFParentH = 0: SFParentNomi = 0: SFParentMenuHL = 0: InsideSFParent = 0: SFhwWindow& = 0
ReDim SFParentMenu$(0), SFParentSc$(0), SFParentID$(0), SFMenuRestrict(0)
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
End If
If pop.Show Then
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
y = CsrLin: x = Pos(0)
If SFMenuMap = 0 Then
SFMenuMap = 1: SFCounter = 0
Restore PopupMenuBarData
Do
Read tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ <> "eof" Then
SFCounter = SFCounter + 1: ReDim _Preserve SFMenu(SFCounter)
If InStr(tmp$, Chr$(16)) Then j = j + 1: SFMenu(SFCounter) = j
End If
Loop
SFCounter = 0
End If
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
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
Restore PopupMenuBarData: SFCounter = 0
For i = 1 To pop.Show - 1
Do
Read tmp$
If tmp$ = "eof" Then Exit Do Else SFCounter = SFCounter + 1
Loop
Next
Case 4
Restore SuckerfishMenus
For i = 1 To pop.SuckerFish - 1
Do: Read tmp$: If tmp$ = "eof" Then Exit Do
Loop
Next
End Select
ReDim menu$(0), sc$(0), MenuID$(0)
Do
Read tmp$
If tmp$ = "eof" Then Exit Do
nomi = nomi + 1
ReDim _Preserve menu$(nomi), sc$(nomi), MenuID$(nomi)
If InStr(tmp$, "|") Then
If InStr(tmp$, "|>") Then MenuID$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2)): tmp$ = _Trim$(Mid$(tmp$, 1, InStr(tmp$, "|>") - 1))
If InStr(tmp$, "|") Then
short$ = _Trim$(Mid$(tmp$, InStr(tmp$, "|") + 1))
tmp$ = Mid$(tmp$, 1, InStr(tmp$, "|") - 1)
End If
x$ = tmp$: If Len(short$) Then x$ = x$ + Chr$(4) + short$
menu$(nomi) = x$: If jj < Len(x$) Then jj = Len(x$)
Else
menu$(nomi) = tmp$
End If
sc$(nomi) = Chr$(3) + "0" + Chr$(4) + "0" + Chr$(5) + "0" + Space$(10)
If InStr(tmp$, "|>") Then
MenuID$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2))
x$ = Mid$(tmp$, 1, InStr(tmp$, "|>") - 1)
Else
x$ = tmp$
End If
If InStr(x$, "|") Then x$ = LCase$(Mid$(x$, InStr(x$, "|") + 1)) Else x$ = ""
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
x$ = LCase$(short$)
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$(LCase$(short$), _InStrRev("+" + LCase$(short$), "+"))
short$ = "": x$ = ""
Loop
For i = 1 To nomi
If InStr(menu$(i), Chr$(4)) Then
k = jj - Len(menu$(i))
x$ = Mid$(menu$(i), 1, InStr(menu$(i), Chr$(4)) - 1) + String$(k + 3, ".") + Mid$(menu$(i), InStr(menu$(i), Chr$(4)) + 1)
Else
x$ = menu$(i)
End If
menu$(i) = x$
Next
ReDim MenuRestrict(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: MenuRestrict(i) = 1: Next
Else
If t.hl = 0 Then ' Unhighlighted text - Cut/Copy/Paste/Clear unavilable. Select All available.
For i = 1 To 4: MenuRestrict(i) = 1: Next
End If
End If
If text$(in.fld) = "" Then MenuRestrict(5) = 1 ' Cannot Select All on a blank input line.
If Len(_Clipboard$) Then MenuRestrict(3) = 0 Else MenuRestrict(3) = 1 ' Paste available if clipboard is loaded.
End If
' Open popup.
If pop.SuckerFish Then gbl.anum = 2 Else gbl.anum = 1
FreeCopy gbl, SCopy()
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
Case 4
pop.MenuL = SFParentR
If pop.MenuL + pop.mwidth >= t.mr - pop.Shadow Then
pop.MenuL = SFParentL - pop.mwidth
SFReversed = _TRUE
Else
SFReversed = 0
End If
pop.MenuT = pop.MenuBarRow + 1
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 Or pop.MenuModel = 4 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 And pop.MenuModel <> 4 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.
If pop.MenuModel = 1 Then k = 2 Else k = 1
Line (pop.mwidth * t.fw - hWth + 1, hHgt * k)-((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 ' Space between menu items.
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
If pop.SuckerFish = 0 Or pop.SuckerFish And SFReversed = 0 Then
Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Else
If SFReversed Then
If i >= SFParentH And pop.VSpacing = 2 Or i > SFParentH And pop.VSpacing = 1 Then Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1)) Else Print
Else
Print
End If
End If
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 MenuRestrict(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 ' Allow print statement to move cursor to next row.
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
If m.lb = 2 And pop.SuckerFish Then
If InsideSFParent = _TRUE Then
pop.MenuT = SFParentT: pop.MenuR = SFParentR + 1: pop.MenuB = SFParentB + 1: pop.MenuL = SFParentL
pop.MenuModel = 2: pop.Show = pop.SuckerFish
pop.mwidth = SFParentW: nomi = SFParentNomi
pop.mheight = SFParentH
pop.SuckerFish = 0: m.lb = 0
InsideSFParent = 0
ReDim menu$(nomi), sc$(nomi), MenuID$(nomi), SFMenuRestrict(nomi)
For i = 1 To SFParentNomi
menu$(i) = SFParentMenu$(i): sc$(i) = SFParentSc$(i)
MenuID$(i) = SFParentID$(i): MenuRestrict(i) = SFMenuRestrict(i)
Next
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
pop.MenuHL = SFParentMenuHL: oldy = 0
pop.hwWindow = SFhwWindow&
gbl.anum = -2: FreeCopy gbl, SCopy()
End If
End If
If m.y > pop.MenuT And m.y < pop.MenuB And m.x >= pop.MenuL And m.x <= pop.MenuR Then
InsideMenu = _TRUE
Else
InsideMenu = _FALSE
End If
If pop.SuckerFish Then
If m.y >= SFParentT And m.y <= SFParentB And m.x >= SFParentL And m.x <= SFParentR Then
InsideSFParent = _TRUE
Else
InsideSFParent = _FALSE
End If
End If
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.lb = 2 And InsideMenu = _TRUE Or m.mb = 2 And pop.MenuHL Then
If pop.MenuHL = 0 Then pop.MenuHL = m.y ' Happens if a click is made when a menu opens up over the mouse before the mouse is moved.
j = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
If MenuRestrict(j) = 0 Then
If InStr(menu$(j), Chr$(16)) And pop.MenuModel = 2 Then ' Suckerfish menu pointer.
If pop.SuckerFish = 0 Then
pop.SuckerFish = SFMenu(SFCounter + j): pop.MenuModel = 4: pop.CloseReOpen = pop.Show
SFParentT = pop.MenuT: SFParentR = pop.MenuR - 1: SFParentB = pop.MenuB - 1
SFParentL = pop.MenuL: SFParentW = pop.mwidth: SFParentH = pop.mheight
ReDim SFParentMenu$(nomi), SFParentSc$(nomi), SFParentID$(nomi), SFMenuRestrict(nomi)
For i = 1 To nomi
SFParentMenu$(i) = menu$(i): SFParentSc$(i) = sc$(i)
SFParentID$(i) = MenuID$(i): SFMenuRestrict(i) = MenuRestrict(i)
Next
SFParentNomi = nomi: SFParentMenuHL = pop.MenuHL: SFhwWindow& = pop.hwWindow
End If
Exit Do
Else
pop.Choice = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
pop.ID = MenuID$(pop.Choice): Exit Do
End If
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 MenuRestrict((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 MenuRestrict((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
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$ = gbl.AltKeys
ElseIf m.ctrl Then x$ = gbl.CtrlKeys
ElseIf m.shift Then x$ = gbl.UcaseKeys Else x$ = gbl.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): pop.ID = MenuID$(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
If SFhwWindow& Then _PutImage ((SFParentL - 1) * t.fw, (SFParentT - 1) * t.fh), SFhwWindow&
End If
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 ' Adding initiate here prevents a pop.Show -1 call that was first positive to open the popup and copy the screen.
If pop.SuckerFish = 0 Or pop.SuckerFish And pop.CloseReOpen = 0 Then
If pop.SuckerFish And pop.CloseReOpen = 0 Then gbl.anum = -2: FreeCopy gbl, SCopy()
gbl.anum = -1: FreeCopy gbl, SCopy()
End If
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
pop.SuckerFish = 0: SFParentT = 0: SFParentR = 0: SFParentB = 0: SFParentL = 0: SFhwWindow& = 0
SFParentW = 0: SFParentH = 0: SFParentNomi = 0: SFParentMenuHL = 0: InsideSFParent = 0: SFhwWindow& = 0
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
Exit While
End If
Wend
End If
End If
End Sub
Sub control (t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, 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 pop.Choice > 0 And pop.MenuModel = -5 Then m.autokey = Chr$(0) + Chr$(58 + pop.Choice)
If Mid$(b$, 2, 1) >= Chr$(59) And Mid$(b$, 2, 1) <= Chr$(66) Then
If pop.MenuModel = 2 And pop.Show Or pop.MenuModel = 4 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.MenuModel < 0 Then Locate _Height - 1, 1: Color c.PageFrg, c.PageBkg: Print Space$(_Width);
If Len(pop.ID) Then
Sound 1000, .1
Select Case pop.ID
Case "Open File"
pop.ChoiceName = "You selected Open File."
Case "Save File"
pop.ChoiceName = "You selected Save File."
Case "Save As"
pop.ChoiceName = "You selected Save File As..."
Case "Quit"
pop.ChoiceName = "Are you sure you want to quit??? "
Case "Cut"
pop.ChoiceName = "You selected Cut Text."
Case "Copy"
pop.ChoiceName = "You selected Copy Text."
Case "Paste"
pop.ChoiceName = "You selected Paste Text."
Case "Clear"
pop.ChoiceName = "You selected Clear Text."
Case "Select All"
pop.ChoiceName = "You selected all text."
Case "Close"
pop.ChoiceName = "You selected to close the menu."
Case "View Subs"
pop.ChoiceName = "You selected to view the subs."
Case "Show Lines"
pop.ChoiceName = "You selected to Show Lines."
Case "Warnings"
pop.ChoiceName = "You selected to view compiler warnings."
Case "Find"
pop.ChoiceName = "You selected to Find Text."
Case "Repeat Find"
pop.ChoiceName = "You selected to Repeat Text Find."
Case "Change"
pop.ChoiceName = "You selected to Change Text."
Case "History"
pop.ChoiceName = "You selected to View History."
Case "Remove Bookmark"
pop.ChoiceName = "You selected to Remove a Bookmark."
Case "Previous Bookmark"
pop.ChoiceName = "You selected to go to Previous Bookmark"
Case "Go to LIne"
pop.ChoiceName = "You selected to go to a line number."
Case "View Help"
pop.ChoiceName = "You selected to View Help."
Case "About"
pop.ChoiceName = "You selected to view info about this app."
End Select
Locate _Height - 1, 1: Color c.PageFrg, c.PageBkg: Print Space$(_Width);
Locate _Height - 1, 2: Print pop.ChoiceName;
Else
If pop.Choice > 0 Then
Sound 1000, .1
seen = 1
Locate _Height - 1, 1: Color c.PageFrg, c.PageBkg: 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 c.PageFrg, c.PageBkg: Print Space$(_Width);: seen = 0
End If
End If
End If
Exit Sub '===============================>
Menu_Layout:
Color c.PageFrg, c.PageBkg: 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 c.ILF, c.ILB
insert t, a$
Locate CsrLin + 2, 1
Color 1, 3
For i = 1 To 20
Print String$(_Width, Chr$(177))
Next
Color c.ILF, c.ILB
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
Sub FreeCopy (gbl As GlobalVar, SCopy())
Static fcopy$
Dim i As Integer
If gbl.anum > 0 Then
i = 0
Do
i = i + 1
i$ = LTrim$(Str$(i)) + "|"
If InStr(fcopy$, i$) = 0 Then Exit Do
Loop
fcopy$ = fcopy$ + i$
SCopy(gbl.anum) = i
PCopy gbl.MyScreen, SCopy(gbl.anum)
ElseIf gbl.anum < 0 Then
i$ = LTrim$(Str$(SCopy(Abs(gbl.anum)))) + "|"
j = InStr(fcopy$, i$) - 1
fcopy$ = Mid$(fcopy$, 1, j) + Mid$(fcopy$, j + Len(i$) + 1)
PCopy SCopy(Abs(gbl.anum)), gbl.MyScreen
End If
Rem _Title Str$(gbl.MyScreen) + " " + Str$(gbl.anum) + " " + Str$(SCopy(Abs(gbl.anum))) + " " + Str$(i) + " fcopy = " + fcopy$
End Sub
Sub insert (t As TextVar, ins$)
Static initiate, MapID As Integer, k
y = CsrLin: x = Pos(0): restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If initiate = 0 Then
initiate = 1
ReDim _Preserve PageMap$(222)
t.fw = _FontWidth: t.fh = _FontHeight
tt = _NewImage(16, 16, 32)
_Dest tt
a = 6: c = 0: w = a * 2: h = a ' Draw a triangle.
For i = 0 To 6
Line (a, c)-(a + i * 2, c), _RGB32(255, 255, 255, 150)
a = a - 1: c = c + 1
Next
t.tri = _CopyImage(tt, 33)
_Dest 0
_FreeImage tt
j = 200 ' Make Input Field
CRed = 255: CGrn = 255: CBlu = 255
t1 = _NewImage((j + 1) * t.fw, 2 * t.fh, 32)
_Dest t1
Line (0, 0)-(j * t.fw, t.fh), _RGB32(CRed, CGrn, CBlu), B
t.hwFieldFront = _CopyImage(t1, 33)
_FreeImage t1
j = 1
t1 = _NewImage((j + 1) * t.fw, 2 * t.fh, 32)
_Dest t1
Line (0, 0)-(0, t.fh), _RGB32(CRed, CGrn, CBlu), B
t.hwFieldBack = _CopyImage(t1, 33)
_FreeImage t1
_Dest 0
End If
If LTrim$(PageMap$(CsrLin)) = "" Then ' Prevents duplication if this sub is called multiple times.
MapID = MapID + 1
Restore PageMenuData
For i = 1 To MapID
Do
Read tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ = "eof" Then If cnt + 1 = MapID Then Exit Do Else cnt = cnt + 1: _Continue
If cnt + 1 = MapID Then
If k < Len(tmp$) Then k = Len(tmp$)
End If
Loop
Next
If MapID = 222 Then ' Hard Limit
_MessageBox "Configuration Error", "The maximun number of PageMap arrays (222) has been reached.", "error"
System
End If
PageMap$(CsrLin) = Space$(_Width)
Mid$(PageMap$(y), x, k + 2) = String$(k + 2, Asc(Chr$(MapID + 33)))
t.InputLine = y: t.FldL = x: t.FldR = x + k + 1 ' One added to extend input box to include triangle down symbol.
End If
If t.PopupHardwareAceleration = 0 Then
Locate y - 1, x - 1: Print Chr$(218) + String$(k, 196) + Chr$(191)
Locate y, x - 1: Print Chr$(179);: Locate y, x + k: Print Chr$(179);
Locate y + 1, x - 1: Print Chr$(192) + String$(k, 196) + Chr$(217);
Locate y, x + k - 1: Print Chr$(25);
End If
Locate y, x: Print ins$;
Locate y, x
Color restore_color1, restore_color2
End Sub
Sub Page_Menus (pop As PopupVar, m As MouseVar)
If m.lb = 2 And pop.MenuModel = 0 Then
x$ = LTrim$(Mid$(PageMap$(m.y), m.x, 1))
If Len(x$) Then
pop.MenuModel = 5: pop.Show = Asc(x$) - 33: pop.MenuT = m.y + 1
pop.PageMenuy = m.y
k = Asc(x$)
pop.PageMenux = InStr(PageMap$(m.y), Chr$(k))
End If
End If
End Sub
Sub HW_Input_Field (t As TextVar, pop As PopupVar)
If t.PopupHardwareAceleration = 0 Then Exit Sub '========================>
If pop.MenuModel = 5 And pop.PMImageHeight Then
dx1 = (pop.MenuL - 1) * t.fw: dy1 = (pop.MenuT - 1) * t.fh
sx1 = 0: sy1 = (pop.PMImageHeight - pop.mheight) * t.fh
sx2 = (pop.mwidth + 1) * t.fw: sy2 = pop.PMImageHeight * t.fh
_PutImage (dx1, dy1), t.PageMenuHWFront, , (sx1, sy1)-(sx2, sy2)
_PutImage ((pop.MenuL + pop.mwidth) * t.fw, (pop.MenuT - 1) * t.fh), t.PageMenuHWBack, , (0 * t.fw, 0)-((pop.mwidth - 1) * t.fw, pop.mheight * t.fh)
End If
cRow = t.InputLine
k1 = 1
LtInFld = t.FldL - 2
If t.PopupHardwareAceleration And pop.Show <> 0 Then
p1 = t.fw \ 2: j1 = 1
If cRow = pop.MenuB - 1 And pop.Shadow Then k1 = 3
End If
If pop.Show And cRow < pop.MenuT + j1 Or pop.Show And cRow > pop.MenuB - pop.Shadow - 1 Or pop.Show = 0 Then
_PutImage (LtInFld * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((t.FldR - t.FldL + 2) * t.fw, t.fh)
_PutImage (t.FldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
_PutImage ((t.FldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
Else
If LtInFld < pop.MenuL Then
_PutImage (LtInFld * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((pop.MenuL + 1 - t.FldL) * t.fw + p1 * k1, t.fh)
End If
sx1 = (pop.MenuR - pop.MenuL + pop.MenuL - (t.FldL - 1)) * t.fw: sx2 = (t.FldR - t.FldL + 2) * t.fw + p1: sy1 = 0: sy2 = t.fh
If pop.MenuR - 1 <= t.FldR Then
_PutImage ((pop.MenuL + (pop.MenuR - pop.MenuL) - 1) * t.fw - p1, (cRow - 1) * t.fh), t.hwFieldFront, , (sx1, sy1)-(sx2, sy2)
_PutImage (t.FldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
If pop.MenuR - 1 < t.FldR Then _PutImage ((t.FldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
End If
End If
End Sub
I'm not sure if anyone else has a differrent way of dealing with layering, but I like the method I created of separating the _putimage components of a hardware image when a comination hardware and software popup image places itself over portion of the hardware image. Now if it were strictly all software image, I'd recommend the coder just swap the display order from hardware over software to software over hardware until the popup is removed.
Well, the next thing needed is to expand the single popdown menu to either 222 possible popdown menus or to unlimited. I'll have to add an extra array for the unlimited method. Again, the only inconvenience of adding arrays is the inability to pass the in a UDT. I know, I need to have a look at John's solution for that this weekend. before the playoff games begin.
Pete
Shoot first and shoot people who ask questions, later.
Posts: 347
Threads: 45
Joined: Jun 2024
Reputation:
32
@Pete Mate, ANYTHING YOU NEED I WILL HAPPILY ASSITS YOU IF I CAN!
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
Okay, here is a nice demo of multiple hardware fields in the menu mix.
Code: (Select All)
$Resize:On
_ScreenMove 200, 20
ReDim Shared PageMap$(0)
Type GlobalVar
anum As Integer
MyScreen As Integer
UcaseKeys As String
LcaseKeys As String
CtrlKeys As String
AltKeys As String
End Type
Dim gbl As GlobalVar
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.
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
InputLine As Integer ' Records cursor row.
hwFieldPresent As Integer
hwFieldFront As Long
hwFieldBack As Long
PopupHardwareAceleration As Integer
PageMenuHWFront As Long
PageMenuHWBack As Long
FldL As Integer
FldR As Integer
tri 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
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
PageMenuy As Integer
PageMenux As Integer
MenuBar As String
MenuBarLt As String
MenuBarRt As String
MenuBarRow As Integer
MenuModel As Integer
PMImageHeight As Integer
ID As String
SuckerFish 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
PageMenuFrg As Integer
PageFrg As Integer
PageBkg As Integer
ILF As Integer
ILB As Integer
PageMenuBkg As Integer
PageMenuHlFrg As Integer
PageMenuHlBkg As Integer
PageMenuBdr As Integer
End Type
Dim c As ColorVar
User_Defined_Variables gbl, t, pop, c
Color c.PageFrg, c.PageBkg: Cls
ReDim text$(1)
Do
_Limit 60
ScreenSize t, c
control t, in, pop, m, c, b$, text$()
Mouse_Keyboard m, b$
Menu_Bar gbl, t, pop, m, c, b$, SCopy()
Popup_Menu gbl, t, in, pop, m, c, b$, text$(), SCopy()
Page_Menus pop, m
HW_Input_Field t, pop
_Display
Loop Until pop.Show = 0 And b$ = Chr$(27)
System
Sub User_Defined_Variables (gbl As GlobalVar, t As TextVar, pop As PopupVar, c As ColorVar)
Static initiate
If initiate = 0 Then
MakeMyCase = 0 ' Non-zero to attach Select Case code to clipboard. ZERO to ignore.
t.PopupHardwareAceleration = 1 ' Hardware Acceleration On.
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 = 39
t.ScrnResizeMinW = 80
t.ScrnResizeMinH = 39
pop.MenuBarRow = 1
pop.MenuBarLt = " File Edit View Search"
pop.MenuBarRt = "Help "
pop.FixMenuT = 18
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.PageFrg = 15
c.PageBkg = 1
c.ILF = 14
c.ILB = 1
c.PageMenuFrg = 7
c.PageMenuBkg = 1
c.PageMenuHlFrg = 15
c.PageMenuHlBkg = 14
c.PageMenuBdr = 14
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
PageMenuData:
Data "Single-Spaced No Lines Popup Menu"
Data "Double-Spaced No Lines Popup Menu"
Data "Single-Spaced Lined Popup Menu"
Data "Double-Spaced Lined Popup Menu"
Data "Single-Spaced No Lines Hardware Popup Menu"
Data "Double-Spaced No Lines Hardware Popup Menu"
Data "Single-Spaced Lined Hardware Popup Menu"
Data "Double-Spaced Lined Hardware Popup Menu"
Data eof
Data On,Off,eof
Data 5-Star,4-Star,3-Star,2-Star,1-Star,Zero Stars for You!,eof
Data eom
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 everything 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
PopupMenuBarData:
Data Open|Ctrl+O|>Open File
Data Save|Ctrl+S|>Save File
Data Save As|Ctrl+A|>Save As
Data Exit|>Quit
Data eof
Data Cut|Ctrl+X|>Cut
Data Copy|Ctrl+C|>Copy
Data Paste|Ctrl+V|>Paste
Data Clear|Delete|>Clear
Data Select All|Ctrl+A|>Select All
Data Close|Esc|>Close
Data eof
Data Subs|Shift+F2|>View Subs
Data Line Numbers||>Show Lines
Data Compiler Warnings|Ctrl+W|>Warnings
Data eof
Data Find|Ctrl+F3|>Find
Data Repeat Last Find|Shift+F3|>Repeat Find
Data Change|Alt+F3|>Change
Data Clear Search History|Alt+Lt|>History
Data Add / Remove Bookmark|Alt+Rt|>Remove Bookmark
Data Previous Bookmark|Alt+Dn|>Previous Bookmark
Data Go To Line|Ctrl+G|>Go to LIne
Data eof
Data View|Shift+F1|>View Help
Data About||>About
Data eof
Data eom
SuckerfishMenus:
Data Show Line Numbers|>Display Line Numbers
Data Hide Line Numbers|>Hide Line Numbers
Data Show Separator|>Show Separator
Data eof
Data Show Copyright|>Display Copyright
Data Hide Copyright|>Hide Copyright
Data Give Pete Rep Points!|>Pete is Tremendous
Data eof
Data eom
gbl.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"
gbl.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.
gbl.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 -"
gbl.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 MakeMyCase Then
Restore PopupMenuBarData
_Clipboard$ = "Select Case pop.ID" + Chr$(10) + Chr$(13)
Do
Read tmp$
If tmp$ = "eom" Then
Exit Do
ElseIf tmp$ = "eof" Then _Continue
Else
nomi = nomi + 1
j = InStr(tmp$, "|>") + 2
If j Then
_Clipboard$ = _Clipboard$ + " Case " + Chr$(34) + Mid$(tmp$, j) + Chr$(34) + Chr$(10) + Chr$(13) + Chr$(10) + Chr$(13)
End If
End If
Loop
_Clipboard$ = _Clipboard$ + "End Select"
End If
initiate = 0
End If
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 (gbl As GlobalVar, t As TextVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$, SCopy())
If Len(pop.MenuBarLt) + Len(pop.MenuBarRt) = 0 Then Exit Sub
Static initiate, altmx, oldmy, oldmx, pcopyhack, AltBlocker, AltException, nomi, map$, shortcut$, sc$(), id$()
y = CsrLin: x = Pos(0)
pop.ID = "" ' Needed here as well as in popup menu sub. Reason: Shortcut keys used without an open menu will not trigger a negative pop.MenuModel value to nullify this variable in the popup sub.
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
Restore PopupMenuBarData
Do
Read tmp$
If tmp$ = "eom" Then
x$ = "": a$ = "": tmp$ = "": Exit Do
ElseIf tmp$ = "eof" Then _Continue
Else
nomi = nomi + 1
ReDim _Preserve sc$(nomi), id$(nomi)
sc$(nomi) = Chr$(3) + "0" + Chr$(4) + "0" + Chr$(5) + "0" + Space$(10)
If InStr(tmp$, "|>") Then
id$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2))
x$ = Mid$(tmp$, 1, InStr(tmp$, "|>") - 1)
Else
x$ = tmp$
End If
If InStr(x$, "|") Then x$ = LCase$(Mid$(x$, InStr(x$, "|") + 1)) Else x$ = ""
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$, "+"))
End If
Loop
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
Else
If pop.Show = 0 Then
If m.alt Then ' Search for a valid shortcut key.
x$ = gbl.AltKeys
ElseIf m.ctrl Then x$ = gbl.CtrlKeys
ElseIf m.shift Then x$ = gbl.UcaseKeys Else x$ = gbl.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 h = 1 To nomi
If m.shift And Mid$(sc$(h), 2, 1) = "1" Or m.shift = 0 And Mid$(sc$(h), 2, 1) = "0" Then
If m.ctrl And Mid$(sc$(h), 4, 1) = "1" Or m.ctrl = 0 And Mid$(sc$(h), 4, 1) = "0" Then
If m.alt And Mid$(sc$(h), 6, 1) = "1" Or m.alt = 0 And Mid$(sc$(h), 6, 1) = "0" Then
If RTrim$(Mid$(sc$(h), 7)) = LCase$(key$) Then
pop.ID = id$(h) ' Valid Shortcut key found.
Exit For
End If
End If
End If
End If
Next h
End If
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
If pop.SuckerFish Then pop.SuckerFish = -1: gbl.anum = -2: FreeCopy gbl, SCopy(): gbl.anum = -1: FreeCopy gbl, SCopy()
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 (gbl As GlobalVar, t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$, text$(), SCopy())
Static initiate, SFMenuMap, nomi, oldmy, oldmx, myalt, RtClkRedo, SFCounter, SFReversed
Static menu$(), sc$(), MenuID$(), SFMenu(), MenuRestrict(), y, x, atmp As String
Static SFParentT, SFParentR, SFParentB, SFParentL, SFParentW, SFParentH, SFParentNomi, SFParentMenuHL, SFhwWindow&, InsideSFParent, SFParentMenu$(), SFParentSc$(), SFParentID$()
If pop.MenuModel = 5 Then
If initiate = 0 Then
If t.PageMenuHWBack = 0 Then ' Only make this universal use image template one time.
j = _Width: t.fw = _FontWidth: t.fh = _FontHeight
CRed = 255: CGrn = 255: CBlu = 255: pop.PMImageHeight = 30
t1 = _NewImage((j + 1) * t.fw, 31 * t.fh, 32)
_Dest t1
Line (0, 0)-(0, pop.PMImageHeight * t.fh), _RGB32(CRed, CGrn, CBlu), B
t.PageMenuHWBack = _CopyImage(t1, 33)
Line (0, pop.PMImageHeight * t.fh)-(j * t.fw, pop.PMImageHeight * t.fh), _RGB32(CRed, CGrn, CBlu), B
t.PageMenuHWFront = _CopyImage(t1, 33)
_Dest 0
_FreeImage t1
End If
gbl.anum = 1: FreeCopy gbl, SCopy()
Restore PageMenuData: pop.mheight = 0: ReDim menu$(0)
For i = 1 To pop.Show
Do: Read tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ = "eof" Then If cnt + 1 = pop.Show Then Exit For Else cnt = cnt + 1: _Continue
If cnt + 1 = pop.Show Then
pop.mheight = pop.mheight + 1: ReDim _Preserve menu$(pop.mheight): menu$(pop.mheight) = tmp$
If k < Len(tmp$) Then k = Len(tmp$)
End If
Loop
Next
pop.mwidth = k + 2
cnt = 0: k = 0: mxalt = 0
x$ = Mid$(PageMap$(m.y), m.x, 1)
pop.MenuL = InStr(PageMap$(m.y), x$) - 1
pop.MenuR = pop.MenuL + pop.mwidth
pop.MenuB = pop.MenuT + pop.mheight
Locate pop.MenuT, pop.MenuL
Color c.PageMenuBdr, c.PageMenuBkg
If t.PopupHardwareAceleration Then
For i = 0 To pop.mheight - 1
Locate pop.MenuT + i, pop.MenuL
Print Space$(pop.mwidth + 1);
Next
Else
For i = 1 To pop.mheight
Locate , pop.MenuL
Print Chr$(179); Space$(pop.mwidth - 2) + Chr$(179)
Next
Color c.PageMenuBdr, c.PageMenuBkg: Locate , pop.MenuL
Print Chr$(192) + String$(pop.mwidth - 2, 196) + Chr$(217);
End If
Color c.PageMenuFrg, c.PageMenuBkg
For i = 0 To pop.mheight - 1
Locate pop.MenuT + i, pop.MenuL + 1
Print menu$(i + 1);
Next
initiate = 1
Else
While -1
Do
If t.ScrnResize = 1 Then pop.Choice = -1: Exit Do ' Force popup to close when resizing app.
If m.y >= pop.MenuT And m.y < pop.MenuB And m.x >= pop.MenuL And m.x <= pop.MenuR Then
InsideMenu = _TRUE
Else
InsideMenu = _FALSE
End If
mxalt = 0
If b$ = Chr$(0) + "H" Or m.mw = -1 Then
If pop.MenuHL - pop.MenuT > 0 Then
myalt = pop.MenuHL - 1: mxalt = -1
End If
ElseIf b$ = Chr$(0) + "P" Or m.mw = 1 Then
If pop.MenuHL = 0 Then
myalt = pop.MenuT: mxalt = -1
Else
If (pop.MenuHL - pop.MenuT + 1) < nomi Then
myalt = pop.MenuHL + 1: mxalt = -1
End If
End If
ElseIf b$ = Chr$(13) And pop.MenuHL Or m.lb = 2 And InsideMenu = _TRUE Or m.mb = 2 And pop.MenuHL Then
pop.Choice = pop.MenuHL - pop.MenuT + 1
Exit Do
ElseIf b$ = Chr$(27) Then
Exit Do
End If
' Popup is present.
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
i = myalt <> oldmy Or myalt = oldmy And m.x <> oldmx Or pop.MenuHL And m.lb = 2
If i Or mxalt = -1 Then ' Works for odd or even number top margins.
If t.PopupHardwareAceleration Then j = 0: k = 1 Else j = 2: k = 0
If pop.MenuHL Then ' Remove highlighting from previous hover.
atmp = Space$(pop.mwidth + k - j)
Mid$(atmp, Abs(j - 2 + j / 2), Len(menu$(pop.MenuHL + 1 - pop.MenuT))) = menu$(pop.MenuHL + 1 - pop.MenuT)
Locate pop.MenuHL, pop.MenuL + j / 2
Color c.PageMenuFrg, c.PageMenuBkg
Print atmp;
End If
atmp = Space$(pop.mwidth + k - j)
Mid$(atmp, Abs(j - 2 + j / 2), Len(menu$(myalt + 1 - pop.MenuT))) = menu$(myalt + 1 - pop.MenuT)
Locate myalt, pop.MenuL + j / 2
Color c.PageMenuHlFrg, c.PageMenuHlBkg
Print atmp;
Color c.PageMenuFrg, c.PageMenuBkg
pop.MenuHL = myalt
End If
Else
' Toggle close popup menu.
If m.lb = 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
End If
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.
gbl.anum = -1: FreeCopy gbl, SCopy()
If pop.Choice > 0 Then
j = pop.mwidth - 2
Rem pop.ID = MenuID$(pop.Choice)
Color c.ILF, c.ILB
Locate pop.PageMenuy, pop.PageMenux: Print Space$(j);
Locate pop.PageMenuy, pop.PageMenux: Print menu$(pop.Choice);
End If
mxalt = 0: initiate = 0: pop.MenuModel = -pop.MenuModel
pop.MenuT = 0: pop.MenuL = 0: pop.MenuR = 0: pop.MenuB = 0: pop.MenuHL = 0: pop.mwidth = 0: pop.mheight = 0
b$ = ""
Exit While
Wend
End If
Else
If pop.MenuModel < 0 Then
pop.Show = 0: pop.PageMenuy = 0: pop.PageMenux = 0: oldmy = 0: myalt = 0: pop.MenuHL = 0: pop.MenuT = 0: pop.MenuB = 0: pop.MenuL = 0: pop.MenuR = 0
pop.MenuModel = 0: pop.Choice = 0: pop.ChoiceName = "": pop.ID = "" ' Completed cycle.
Erase menu$: ReDim MenuID$(0): ReDim sc$(0) ' Note: Can't erase because it isn't defined until later in the code.
End If
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.SuckerFish = -1 Then ' Closed by slider in Menubar sub.
pop.SuckerFish = 0: SFParentT = 0: SFParentR = 0: SFParentB = 0: SFParentL = 0
SFParentW = 0: SFParentH = 0: SFParentNomi = 0: SFParentMenuHL = 0: InsideSFParent = 0: SFhwWindow& = 0
ReDim SFParentMenu$(0), SFParentSc$(0), SFParentID$(0), SFMenuRestrict(0)
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
End If
If pop.Show Then
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
y = CsrLin: x = Pos(0)
If SFMenuMap = 0 Then
SFMenuMap = 1: SFCounter = 0
Restore PopupMenuBarData
Do
Read tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ <> "eof" Then
SFCounter = SFCounter + 1: ReDim _Preserve SFMenu(SFCounter)
If InStr(tmp$, Chr$(16)) Then j = j + 1: SFMenu(SFCounter) = j
End If
Loop
SFCounter = 0
End If
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
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
Restore PopupMenuBarData: SFCounter = 0
For i = 1 To pop.Show - 1
Do
Read tmp$
If tmp$ = "eof" Then Exit Do Else SFCounter = SFCounter + 1
Loop
Next
Case 4
Restore SuckerfishMenus
For i = 1 To pop.SuckerFish - 1
Do: Read tmp$: If tmp$ = "eof" Then Exit Do
Loop
Next
End Select
ReDim menu$(0), sc$(0), MenuID$(0)
Do
Read tmp$
If tmp$ = "eof" Then Exit Do
nomi = nomi + 1
ReDim _Preserve menu$(nomi), sc$(nomi), MenuID$(nomi)
If InStr(tmp$, "|") Then
If InStr(tmp$, "|>") Then MenuID$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2)): tmp$ = _Trim$(Mid$(tmp$, 1, InStr(tmp$, "|>") - 1))
If InStr(tmp$, "|") Then
short$ = _Trim$(Mid$(tmp$, InStr(tmp$, "|") + 1))
tmp$ = Mid$(tmp$, 1, InStr(tmp$, "|") - 1)
End If
x$ = tmp$: If Len(short$) Then x$ = x$ + Chr$(4) + short$
menu$(nomi) = x$: If jj < Len(x$) Then jj = Len(x$)
Else
menu$(nomi) = tmp$
End If
sc$(nomi) = Chr$(3) + "0" + Chr$(4) + "0" + Chr$(5) + "0" + Space$(10)
If InStr(tmp$, "|>") Then
MenuID$(nomi) = _Trim$(Mid$(tmp$, InStr(tmp$, "|>") + 2))
x$ = Mid$(tmp$, 1, InStr(tmp$, "|>") - 1)
Else
x$ = tmp$
End If
If InStr(x$, "|") Then x$ = LCase$(Mid$(x$, InStr(x$, "|") + 1)) Else x$ = ""
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
x$ = LCase$(short$)
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$(LCase$(short$), _InStrRev("+" + LCase$(short$), "+"))
short$ = "": x$ = ""
Loop
For i = 1 To nomi
If InStr(menu$(i), Chr$(4)) Then
k = jj - Len(menu$(i))
x$ = Mid$(menu$(i), 1, InStr(menu$(i), Chr$(4)) - 1) + String$(k + 3, ".") + Mid$(menu$(i), InStr(menu$(i), Chr$(4)) + 1)
Else
x$ = menu$(i)
End If
menu$(i) = x$
Next
ReDim MenuRestrict(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: MenuRestrict(i) = 1: Next
Else
If t.hl = 0 Then ' Unhighlighted text - Cut/Copy/Paste/Clear unavilable. Select All available.
For i = 1 To 4: MenuRestrict(i) = 1: Next
End If
End If
If text$(in.fld) = "" Then MenuRestrict(5) = 1 ' Cannot Select All on a blank input line.
If Len(_Clipboard$) Then MenuRestrict(3) = 0 Else MenuRestrict(3) = 1 ' Paste available if clipboard is loaded.
End If
' Open popup.
If pop.SuckerFish Then gbl.anum = 2 Else gbl.anum = 1
FreeCopy gbl, SCopy()
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
Case 4
pop.MenuL = SFParentR
If pop.MenuL + pop.mwidth >= t.mr - pop.Shadow Then
pop.MenuL = SFParentL - pop.mwidth
SFReversed = _TRUE
Else
SFReversed = 0
End If
pop.MenuT = pop.MenuBarRow + 1
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 Or pop.MenuModel = 4 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 And pop.MenuModel <> 4 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.
If pop.MenuModel = 1 Then k = 2 Else k = 1
Line (pop.mwidth * t.fw - hWth + 1, hHgt * k)-((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 ' Space between menu items.
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
If pop.SuckerFish = 0 Or pop.SuckerFish And SFReversed = 0 Then
Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Else
If SFReversed Then
If i >= SFParentH And pop.VSpacing = 2 Or i > SFParentH And pop.VSpacing = 1 Then Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1)) Else Print
Else
Print
End If
End If
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 MenuRestrict(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 ' Allow print statement to move cursor to next row.
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
If m.lb = 2 And pop.SuckerFish Then
If InsideSFParent = _TRUE Then
pop.MenuT = SFParentT: pop.MenuR = SFParentR + 1: pop.MenuB = SFParentB + 1: pop.MenuL = SFParentL
pop.MenuModel = 2: pop.Show = pop.SuckerFish
pop.mwidth = SFParentW: nomi = SFParentNomi
pop.mheight = SFParentH
pop.SuckerFish = 0: m.lb = 0
InsideSFParent = 0
ReDim menu$(nomi), sc$(nomi), MenuID$(nomi), SFMenuRestrict(nomi)
For i = 1 To SFParentNomi
menu$(i) = SFParentMenu$(i): sc$(i) = SFParentSc$(i)
MenuID$(i) = SFParentID$(i): MenuRestrict(i) = SFMenuRestrict(i)
Next
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
pop.MenuHL = SFParentMenuHL: oldy = 0
pop.hwWindow = SFhwWindow&
gbl.anum = -2: FreeCopy gbl, SCopy()
End If
End If
If m.y > pop.MenuT And m.y < pop.MenuB And m.x >= pop.MenuL And m.x <= pop.MenuR Then
InsideMenu = _TRUE
Else
InsideMenu = _FALSE
End If
If pop.SuckerFish Then
If m.y >= SFParentT And m.y <= SFParentB And m.x >= SFParentL And m.x <= SFParentR Then
InsideSFParent = _TRUE
Else
InsideSFParent = _FALSE
End If
End If
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.lb = 2 And InsideMenu = _TRUE Or m.mb = 2 And pop.MenuHL Then
If pop.MenuHL = 0 Then pop.MenuHL = m.y ' Happens if a click is made when a menu opens up over the mouse before the mouse is moved.
j = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
If MenuRestrict(j) = 0 Then
If InStr(menu$(j), Chr$(16)) And pop.MenuModel = 2 Then ' Suckerfish menu pointer.
If pop.SuckerFish = 0 Then
pop.SuckerFish = SFMenu(SFCounter + j): pop.MenuModel = 4: pop.CloseReOpen = pop.Show
SFParentT = pop.MenuT: SFParentR = pop.MenuR - 1: SFParentB = pop.MenuB - 1
SFParentL = pop.MenuL: SFParentW = pop.mwidth: SFParentH = pop.mheight
ReDim SFParentMenu$(nomi), SFParentSc$(nomi), SFParentID$(nomi), SFMenuRestrict(nomi)
For i = 1 To nomi
SFParentMenu$(i) = menu$(i): SFParentSc$(i) = sc$(i)
SFParentID$(i) = MenuID$(i): SFMenuRestrict(i) = MenuRestrict(i)
Next
SFParentNomi = nomi: SFParentMenuHL = pop.MenuHL: SFhwWindow& = pop.hwWindow
End If
Exit Do
Else
pop.Choice = (pop.MenuHL - pop.MenuT + Abs(pop.VSpacing) - 1) \ Abs(pop.VSpacing)
pop.ID = MenuID$(pop.Choice): Exit Do
End If
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 MenuRestrict((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 MenuRestrict((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
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$ = gbl.AltKeys
ElseIf m.ctrl Then x$ = gbl.CtrlKeys
ElseIf m.shift Then x$ = gbl.UcaseKeys Else x$ = gbl.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): pop.ID = MenuID$(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
If SFhwWindow& Then _PutImage ((SFParentL - 1) * t.fw, (SFParentT - 1) * t.fh), SFhwWindow&
End If
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.
If initiate Then ' Adding initiate here prevents a pop.Show -1 call that was first positive to open the popup and copy the screen.
If pop.SuckerFish = 0 Or pop.SuckerFish And pop.CloseReOpen = 0 Then
If pop.SuckerFish And pop.CloseReOpen = 0 Then gbl.anum = -2: FreeCopy gbl, SCopy()
gbl.anum = -1: FreeCopy gbl, SCopy()
End If
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
pop.SuckerFish = 0: SFParentT = 0: SFParentR = 0: SFParentB = 0: SFParentL = 0: SFhwWindow& = 0
SFParentW = 0: SFParentH = 0: SFParentNomi = 0: SFParentMenuHL = 0: InsideSFParent = 0: SFhwWindow& = 0
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
Exit While
End If
Wend
End If
End If
End Sub
Sub control (t As TextVar, in As InputVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$, text$())
Static initiate, seen, getmenu, MChoice, HWChoice, rating
If initiate = 0 Or t.ScrnResize = 2 Then
t.HardwareMenus = 1: pop.VSpacing = 2: MChoice = 8: HWChoice = 1: rating = 1
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 And pop.MenuModel < 2 Then
If m.lb = -1 Then m.autokey = Chr$(0) + Chr$(59 + m.y - 3): pop.Show = -1
End If
If pop.Choice > 0 And pop.MenuModel = -5 Then
Select Case pop.Show
Case 1: m.autokey = Chr$(0) + Chr$(58 + pop.Choice)
Case 2: HWChoice = pop.Choice
End Select
End If
If Mid$(b$, 2, 1) >= Chr$(59) And Mid$(b$, 2, 1) <= Chr$(66) Then
If pop.MenuModel = 2 And pop.Show Or pop.MenuModel = 4 And pop.Show Then
Else
getmenu = 1
Select Case b$
Case Chr$(0) + Chr$(59): t.HardwareMenus = 0: pop.VSpacing = -1: MChoice = 1
Case Chr$(0) + Chr$(60): t.HardwareMenus = 0: pop.VSpacing = -2: MChoice = 2
Case Chr$(0) + Chr$(61): t.HardwareMenus = 0: pop.VSpacing = 1: MChoice = 3
Case Chr$(0) + Chr$(62): t.HardwareMenus = 0: pop.VSpacing = 2: MChoice = 4
Case Chr$(0) + Chr$(63): t.HardwareMenus = 1: pop.VSpacing = -1: MChoice = 5
Case Chr$(0) + Chr$(64): t.HardwareMenus = 1: pop.VSpacing = -2: MChoice = 6
Case Chr$(0) + Chr$(65): t.HardwareMenus = 1: pop.VSpacing = 1: MChoice = 7
Case Chr$(0) + Chr$(66): t.HardwareMenus = 1: pop.VSpacing = 2: MChoice = 8
End Select
End If
End If
If getmenu = 1 Then pop.Show = -1: getmenu = 2: Exit Sub
If getmenu = 2 Then
pop.Show = 2: pop.MenuModel = 1: pop.ForceInitiate = 1
getmenu = 0
End If
If pop.MenuModel < 0 Then Locate _Height - 1, 1: Color c.PageFrg, c.PageBkg: Print Space$(_Width);
If Len(pop.ID) Then
Sound 1000, .1
Select Case pop.ID
Case "Open File"
pop.ChoiceName = "You selected Open File."
Case "Save File"
pop.ChoiceName = "You selected Save File."
Case "Save As"
pop.ChoiceName = "You selected Save File As..."
Case "Quit"
pop.ChoiceName = "Are you sure you want to quit??? "
Case "Cut"
pop.ChoiceName = "You selected Cut Text."
Case "Copy"
pop.ChoiceName = "You selected Copy Text."
Case "Paste"
pop.ChoiceName = "You selected Paste Text."
Case "Clear"
pop.ChoiceName = "You selected Clear Text."
Case "Select All"
pop.ChoiceName = "You selected all text."
Case "Close"
pop.ChoiceName = "You selected to close the menu."
Case "View Subs"
pop.ChoiceName = "You selected to view the subs."
Case "Show Lines"
pop.ChoiceName = "You selected to Show Lines."
Case "Warnings"
pop.ChoiceName = "You selected to view compiler warnings."
Case "Find"
pop.ChoiceName = "You selected to Find Text."
Case "Repeat Find"
pop.ChoiceName = "You selected to Repeat Text Find."
Case "Change"
pop.ChoiceName = "You selected to Change Text."
Case "History"
pop.ChoiceName = "You selected to View History."
Case "Remove Bookmark"
pop.ChoiceName = "You selected to Remove a Bookmark."
Case "Previous Bookmark"
pop.ChoiceName = "You selected to go to Previous Bookmark"
Case "Go to LIne"
pop.ChoiceName = "You selected to go to a line number."
Case "View Help"
pop.ChoiceName = "You selected to View Help."
Case "About"
pop.ChoiceName = "You selected to view info about this app."
End Select
Locate _Height - 1, 1: Color c.PageFrg, c.PageBkg: Print Space$(_Width);
Locate _Height - 1, 2: Print pop.ChoiceName;
Else
If pop.Choice > 0 Then
Sound 1000, .1
seen = 1
Locate _Height - 1, 1: Color c.PageFrg, c.PageBkg: 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 c.PageFrg, c.PageBkg: Print Space$(_Width);: seen = 0
End If
End If
End If
If HWChoice = 1 Then t.PopupHardwareAceleration = 1 Else t.PopupHardwareAceleration = 0
Exit Sub '===============================>
Menu_Layout:
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: ": Print a$;
j = MChoice: GoSub getdata
Color c.ILF, c.ILB
insert t, a$
Locate CsrLin + 3, 2
Color c.PageFrg, c.PageBkg: a$ = "Hardware Fields: ": Print a$;
j = HWChoice: GoSub getdata
Color c.ILF, c.ILB: insert t, a$
Locate , Pos(0) + 10
Color c.PageFrg, c.PageBkg: a$ = "Rate Pete's Demo as: ": Print a$;
j = rating: GoSub getdata
Color c.ILF, c.ILB: insert t, a$
Locate CsrLin + 2, 1
Color 1, 3
For i = 1 To 20
Print String$(_Width, Chr$(177))
Next
Color c.ILF, c.ILB
Return
getdata:
Restore PageMenuData: i = 0: cnt = 0
Do
i = i + 1
Read tmp$
If i = j And cnt = menunum Then a$ = tmp$
If tmp$ = "eom" Then Exit Do
If tmp$ = "eof" Then If cnt = menunum Then menunum = menunum + 1: cnt = 0: Exit Do Else cnt = cnt + 1: i = 0
Loop
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
Sub FreeCopy (gbl As GlobalVar, SCopy())
Static fcopy$
Dim i As Integer
If gbl.anum > 0 Then
i = 0
Do
i = i + 1
i$ = LTrim$(Str$(i)) + "|"
If InStr(fcopy$, i$) = 0 Then Exit Do
Loop
fcopy$ = fcopy$ + i$
SCopy(gbl.anum) = i
PCopy gbl.MyScreen, SCopy(gbl.anum)
Rem _Title "Pcopy Away" + Str$(gbl.MyScreen) + " to" + Str$(Abs(gbl.anum))
ElseIf gbl.anum < 0 Then
i$ = LTrim$(Str$(SCopy(Abs(gbl.anum)))) + "|"
j = InStr(fcopy$, i$) - 1
fcopy$ = Mid$(fcopy$, 1, j) + Mid$(fcopy$, j + Len(i$) + 1)
PCopy SCopy(Abs(gbl.anum)), gbl.MyScreen
Screen gbl.MyScreen, 0, Abs(gbl.anum), gbl.MyScreen: Cls: Screen gbl.MyScreen, 0, gbl.MyScreen, gbl.MyScreen ' Clear pcopy memory.
Rem _Title "Pcopy Home" + Str$(Abs(gbl.anum)) + " to" + Str$(gbl.MyScreen)
End If
End Sub
Sub insert (t As TextVar, ins$)
Static initiate, MapID As Integer, k
y = CsrLin: x = Pos(0): restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If initiate = 0 Then
initiate = 1
ReDim _Preserve PageMap$(222)
t.fw = _FontWidth: t.fh = _FontHeight
tt = _NewImage(16, 16, 32)
_Dest tt
a = 6: c = 0: w = a * 2: h = a ' Draw a triangle.
For i = 0 To 6
Line (a, c)-(a + i * 2, c), _RGB32(255, 255, 255, 150)
a = a - 1: c = c + 1
Next
t.tri = _CopyImage(tt, 33)
_Dest 0
_FreeImage tt
j = 200 ' Make Input Field
CRed = 255: CGrn = 255: CBlu = 255
t1 = _NewImage((j + 1) * t.fw, 2 * t.fh, 32)
_Dest t1
Line (0, 0)-(j * t.fw, t.fh), _RGB32(CRed, CGrn, CBlu), B
t.hwFieldFront = _CopyImage(t1, 33)
_FreeImage t1
j = 1
t1 = _NewImage((j + 1) * t.fw, 2 * t.fh, 32)
_Dest t1
Line (0, 0)-(0, t.fh), _RGB32(CRed, CGrn, CBlu), B
t.hwFieldBack = _CopyImage(t1, 33)
_FreeImage t1
_Dest 0
End If
MapID = MapID + 1
Restore PageMenuData
For i = 1 To MapID
Do
Read tmp$
If tmp$ = "eom" Then Exit For
If tmp$ = "eof" Then If cnt + 1 = MapID Then Exit For Else cnt = cnt + 1: k = 0: _Continue
If cnt + 1 = MapID Then
If k < Len(tmp$) Then k = Len(tmp$)
End If
Loop
Next
If MapID = 222 Then ' Hard Limit
_MessageBox "Configuration Error", "The maximun number of PageMap arrays (222) has been reached.", "error"
System
End If
If LTrim$(PageMap$(CsrLin)) = "" Then PageMap$(CsrLin) = Space$(_Width)
Mid$(PageMap$(y), x, k + 2) = String$(k + 2, Asc(Chr$(MapID + 33)))
t.InputLine = y: t.FldL = x: t.FldR = x + k + 1 ' One added to extend input box to include triangle down symbol.
If t.PopupHardwareAceleration = 0 Then
Locate y - 1, x - 1: Print Chr$(218) + String$(k, 196) + Chr$(191)
Locate y, x - 1: Print Chr$(179);: Locate y, x + k: Print Chr$(179);
Locate y + 1, x - 1: Print Chr$(192) + String$(k, 196) + Chr$(217);
Locate y, x + k - 1: Print Chr$(25);
End If
Locate y, x: Print ins$;
Locate y, x
Color restore_color1, restore_color2
End Sub
Sub Page_Menus (pop As PopupVar, m As MouseVar)
If m.lb = 2 And pop.MenuModel = 0 Then
x$ = LTrim$(Mid$(PageMap$(m.y), m.x, 1))
If Len(x$) Then
pop.MenuModel = 5: pop.Show = Asc(x$) - 33: pop.MenuT = m.y + 1
pop.PageMenuy = m.y
pop.PageMenux = InStr(PageMap$(m.y), x$)
End If
End If
End Sub
Sub HW_Input_Field (t As TextVar, pop As PopupVar)
If t.PopupHardwareAceleration = 0 Then Exit Sub '========================>
If pop.MenuModel = 5 And pop.PMImageHeight Then
dx1 = (pop.MenuL - 1) * t.fw: dy1 = (pop.MenuT - 1) * t.fh
sx1 = 0: sy1 = (pop.PMImageHeight - pop.mheight) * t.fh
sx2 = (pop.mwidth + 1) * t.fw: sy2 = pop.PMImageHeight * t.fh
_PutImage (dx1, dy1), t.PageMenuHWFront, , (sx1, sy1)-(sx2, sy2)
_PutImage ((pop.MenuL + pop.mwidth) * t.fw, (pop.MenuT - 1) * t.fh), t.PageMenuHWBack, , (0 * t.fw, 0)-((pop.mwidth - 1) * t.fw, pop.mheight * t.fh)
End If
For i = 1 To _Height
If Len(LTrim$(PageMap$(i))) Then
seed = 0
Do
cRow = i: k1 = 1
tmp$ = Mid$(PageMap$(i), seed): x$ = Left$(LTrim$(tmp$), 1)
t.FldL = InStr(PageMap$(i), x$): t.FldR = _InStrRev(PageMap$(i), x$)
LtInFld = t.FldL - 2: RtInFld = t.FldR: seed = RtInFld + 1
If t.PopupHardwareAceleration And pop.Show <> 0 Then
p1 = t.fw \ 2: j1 = 1
If cRow = pop.MenuB - 1 And pop.Shadow Then k1 = 3
End If
If pop.Show And cRow < pop.MenuT + j1 Or pop.Show And cRow > pop.MenuB - pop.Shadow - 1 Or pop.Show = 0 Then
_PutImage (LtInFld * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((t.FldR - t.FldL + 2) * t.fw, t.fh)
_PutImage (t.FldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
_PutImage ((t.FldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
Else
sx1 = (pop.MenuR - pop.MenuL + pop.MenuL - (t.FldL - 1)) * t.fw
If pop.MenuModel = 5 Then
dx1 = pop.MenuR * t.fw: k1 = 0
sx2 = (t.FldR - t.FldL + 1) * t.fw
Else
dx1 = (pop.MenuR - 1) * t.fw - p1
sx2 = (t.FldR - t.FldL + 2) * t.fw + p1
End If
If LtInFld < pop.MenuL Then _PutImage (LtInFld * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((pop.MenuL + 1 - t.FldL) * t.fw + p1 * k1, t.fh)
dy1 = (cRow - 1) * t.fh: sy1 = 0: sy2 = t.fh
If pop.MenuR - 1 <= t.FldR Then
_PutImage (dx1, dy1), t.hwFieldFront, , (sx1, sy1)-(sx2, sy2)
_PutImage (t.FldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
If pop.MenuR - 1 < t.FldR Then _PutImage ((t.FldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
End If
End If
Loop Until LTrim$(Mid$(PageMap$(i), seed)) = ""
End If
Next
End Sub
Posts: 347
Threads: 45
Joined: Jun 2024
Reputation:
32
First look over i think...why not use _BYTE for flags rather than integers?
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
01-26-2026, 05:44 AM
(01-26-2026, 05:22 AM)Unseen Machine Wrote: First look over i think...why not use _BYTE for flags rather than integers?
I could, and for the ones that are just zero or one I'd love to use _bit, but we can't use _bit in a QB64 UDT.
I usually do Integer and when the project gets closer to completion, I look for ways to optimize the code. For instance, the hardware sub can be made to only look for the specific lines that display input fields, instead of the whole page.
Pete
|
