Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
01-26-2026, 04:47 PM
(This post was last modified: 01-27-2026, 10:57 PM by Pete.)
OKAY, OKAY, FINE.... Here it is with _Byte! 
Code: (Select All)
$Resize:On
_ScreenMove 200, 20
ReDim Shared PageMap$(0)
Type GlobalVar
anum As _Byte
MyScreen As _Byte
UcaseKeys As String
LcaseKeys As String
CtrlKeys As String
AltKeys As String
End Type
Dim gbl As GlobalVar
Type TextVar
HardwareMenus As _Byte ' 0 or 1.
FormStyle As _Byte
InptMthd As _Byte ' 2 is for creating an input field when csrlin is activated by mouse or keyboard.
mt As _Byte
mr As _Byte
mb As _Byte
ml As _Byte
bsTop As _Byte
bsRight As _Byte
bsBottom As _Byte
bsLeft As _Byte
noe As _Byte
nol As _Byte
scr As _Byte
oldscr As _Byte
wide As _Byte
tall As _Byte
fw As _Byte
fh As _Byte
redisplay As _Byte
hl As _Byte
HlFind As _Byte
ScreenEstablished As _Byte
ScrnW As _Byte
ScrnH As _Byte
ScrnResize As _Byte
ScrnResizeMinW As _Byte
ScrnResizeMinH As _Byte
ScrnResizeInputRow As _Byte
ScrnResizeInputCol As _Byte
RollupEvent As _Byte
RollupStatus As _Byte
HoldScr As _Byte
persistency As _Byte ' 1 or 0
UseDefaultDisplay As _Byte ' 1 or 0
InputActive As _Byte ' Records cursor row.
redo As _Byte
undo As _Byte
RedoText As String
UndoText As String
MarkerOn As _Byte
marker As _Byte
EncodeOn As _Byte
remakeIDX As _Byte
hideshow As String
AddDelete As _Byte ' 1 Add, -1 Delete, or 0 inactive.
OpenInput As _Byte ' 1 Open input line pase colon or 2 Open entire input line.
hgltPos1 As _Byte
hwUnderlineShow As _Byte
hwUnderlineImage As Long
InputLine As String ' Records cursor row.
hwFieldPresent As _Byte
hwFieldFront As Long
hwFieldBack As Long
PopupHardwareAceleration As _Byte
PageMenuHWFront As Long
PageMenuHWBack As Long
FldL As _Byte
FldR As _Byte
tri As Long
End Type
Dim t As TextVar
Type InputVar
CurStyle As _Byte
CurShow As _Byte
fld As _Byte
mtop As _Byte
mleft As _Byte
myclose As _Byte
mxclose As _Byte
End Type
Dim in As InputVar
Type PopupVar
ForceInitiate As _Byte
Show As _Byte ' Number of window to show.
CloseReOpen As _Byte ' Number of window to show after previous window gets closed.
hwWindow As Long
mwidth As _Byte
mheight As _Byte
FixMenuT As _Byte
FixMenuL As _Byte
MenuT As _Byte
MenuB As _Byte
MenuL As _Byte
MenuR As _Byte
MenuHL As _Byte
MarginRt As _Byte
BoundsLt As _Byte
BoundsRt As _Byte
Shadow As _Byte ' 0 or 1.
VSpacing As _Byte
Choice As _Byte
ChoiceName As String
PageMenuy As _Byte
PageMenux As _Byte
MenuBar As String
MenuBarLt As String
MenuBarRt As String
MenuBarRow As _Byte
MenuModel As _Byte
PMImageHeight As _Byte
ID As String
SuckerFish As _Byte
End Type
Dim pop As PopupVar
Type MouseVar
x As _Byte
y As _Byte
lb As _Byte
rb As _Byte
mb As _Byte
mw As _Byte
clkcnt As _Byte
caps As _Byte
shift As _Byte
ctrl As _Byte
alt As _Byte
AltSwitch As _Byte
prevx As _Byte
prevy As _Byte
drag As _Byte
sbar As _Byte
sbRow As _Byte
oldsbRow As _Byte
ThumbTop As _Byte
ThumbSize As _Byte
ThumbDrag As _Byte
autokey As String
End Type
Dim m As MouseVar
Type ColorVar
pal1 As _Byte
pal2 As _Byte
pal3 As _Byte
pal4 As _Byte
PageColor As _Byte
SkinFrg As _Byte
SkinBkg As _Byte
InputFrg As _Byte
InputFrg2 As _Byte
InputBkg As _Byte
InputHl As _Byte
InputH2 As _Byte
SkinShadowFrg As _Byte
SkinShadowBkg As _Byte
PopupFrg As _Byte
PopupBkg As _Byte
PopupUnavail As _Byte
PopupShadowFrg As _Byte
PopupShadowBkg As _Byte
PopupMenuBarFrg As _Byte
PopupMenuBarBkg As _Byte
FixedMenuFrg As _Byte
FixedMenuBkg As _Byte
FixedMenuHlFrg As _Byte
FixedMenuHlBkg As _Byte
FixedMenuScFrg As _Byte
PageMenuFrg As _Byte
PageFrg As _Byte
PageBkg As _Byte
ILF As _Byte
ILB As _Byte
PageMenuBkg As _Byte
PageMenuHlFrg As _Byte
PageMenuHlBkg As _Byte
PageMenuBdr As _Byte
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 For
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 Clear Search 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 _Byte
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 _Byte, 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)))
If InStr(t.InputLine, Chr$(y + 32)) = 0 Then t.InputLine = t.InputLine + Chr$(y + 32)
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)
Static InFldL, InfldR
If t.PopupHardwareAceleration = 0 Then Exit Sub '========================>
If pop.MenuModel = 5 And pop.MenuL Then ' Note: Menu model and top are assigned before other menu borders
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, 0)-((pop.mwidth - 1) * t.fw, pop.mheight * t.fh)
End If
h = 0
Do
seed = 0: h = h + 1: x$ = Mid$(t.InputLine, h, 1): If Len(x$) Then i = Asc(x$) - 32 Else Exit Do
Do
cRow = i: k1 = 1
tmp$ = Mid$(PageMap$(i), seed): x$ = Left$(LTrim$(tmp$), 1)
InFldL = InStr(PageMap$(i), x$): InfldR = _InStrRev(PageMap$(i), x$)
LtInFld = InFldL - 2: RtInFld = InfldR: 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)-((InfldR - InFldL + 2) * t.fw, t.fh)
_PutImage (InfldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
_PutImage ((InfldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
Else
sx1 = (pop.MenuR - pop.MenuL + pop.MenuL - (InFldL - 1)) * t.fw
If pop.MenuModel = 5 Then
dx1 = pop.MenuR * t.fw: k1 = 0
sx2 = (InfldR - InFldL + 1) * t.fw
Else
dx1 = (pop.MenuR - 1) * t.fw - p1
sx2 = (InfldR - InFldL + 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 - InFldL) * t.fw + p1 * k1, t.fh)
dy1 = (cRow - 1) * t.fh: sy1 = 0: sy2 = t.fh
If pop.MenuR - 1 <= InfldR Then
_PutImage (dx1, dy1), t.hwFieldFront, , (sx1, sy1)-(sx2, sy2)
_PutImage (InfldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
If pop.MenuR - 1 < InfldR Then _PutImage ((InfldR - 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)) = ""
Loop
End Sub
@Unseen Machine - You know I wish this was available in QuickBasic, because it would have helped with the memory limits issues. I ran a mem check, and this conversion saves abut 85. That's pretty cool.
I also optimized the hardware display (Last sub) so it finds the mappings immmediately instead of scans the whole page. Tricks like this I employ after I get the guts of the thing working.
Well the next evolution will be to add the SCREEN 0 underlined hyperlinks I created in a former program.
Thanks for bringing up _Byte,
Pete
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
Okay, added two different kinds clickable links...
Code: (Select All)
$Resize:On
_ScreenMove 200, 10
ReDim Shared PageMap$(0)
Type GlobalVar
anum As _Byte
MyScreen As _Byte
UcaseKeys As String
LcaseKeys As String
CtrlKeys As String
AltKeys As String
End Type
Dim gbl As GlobalVar
Type TextVar
HardwareMenus As _Byte ' 0 or 1.
FormStyle As _Byte
InptMthd As _Byte ' 2 is for creating an input field when csrlin is activated by mouse or keyboard.
mt As _Byte
mr As _Byte
mb As _Byte
ml As _Byte
bsTop As _Byte
bsRight As _Byte
bsBottom As _Byte
bsLeft As _Byte
noe As _Byte
nol As _Byte
scr As _Byte
oldscr As _Byte
wide As _Byte
tall As _Byte
fw As _Byte
fh As _Byte
redisplay As _Byte
hl As _Byte
HlFind As _Byte
ScreenEstablished As _Byte
ScrnW As _Byte
ScrnH As _Byte
ScrnResize As _Byte
ScrnResizeMinW As _Byte
ScrnResizeMinH As _Byte
ScrnResizeInputRow As _Byte
ScrnResizeInputCol As _Byte
RollupEvent As _Byte
RollupStatus As _Byte
HoldScr As _Byte
persistency As _Byte ' 1 or 0
UseDefaultDisplay As _Byte ' 1 or 0
InputActive As _Byte ' Records cursor row.
redo As _Byte
undo As _Byte
RedoText As String
UndoText As String
MarkerOn As _Byte
marker As _Byte
EncodeOn As _Byte
remakeIDX As _Byte
hideshow As String
AddDelete As _Byte ' 1 Add, -1 Delete, or 0 inactive.
OpenInput As _Byte ' 1 Open input line pase colon or 2 Open entire input line.
hgltPos1 As _Byte
hwUnderlineShow As _Byte
hwUnderlineImage As Long
InputLine As String ' Records cursor row.
hwFieldPresent As _Byte
hwFieldFront As Long
hwFieldBack As Long
PopupHardwareAceleration As _Byte
PageMenuHWFront As Long
PageMenuHWBack As Long
tri As Long
HLnk As Long
End Type
Dim t As TextVar
Type InputVar
CurStyle As _Byte
CurShow As _Byte
fld As _Byte
mtop As _Byte
mleft As _Byte
myclose As _Byte
mxclose As _Byte
End Type
Dim in As InputVar
Type PopupVar
ForceInitiate As _Byte
Show As _Byte ' Number of window to show.
CloseReOpen As _Byte ' Number of window to show after previous window gets closed.
hwWindow As Long
mwidth As _Byte
mheight As _Byte
FixMenuT As _Byte
FixMenuL As _Byte
MenuT As _Byte
MenuB As _Byte
MenuL As _Byte
MenuR As _Byte
MenuHL As _Byte
MarginRt As _Byte
BoundsLt As _Byte
BoundsRt As _Byte
Shadow As _Byte ' 0 or 1.
VSpacing As _Byte
Choice As _Byte
ChoiceName As String
PageMenuy As _Byte
PageMenux As _Byte
MenuBar As String
MenuBarLt As String
MenuBarRt As String
MenuBarRow As _Byte
MenuModel As _Byte
PMImageHeight As _Byte
ID As String
SuckerFish As _Byte
End Type
Dim pop As PopupVar
Type MouseVar
x As _Byte
y As _Byte
lb As _Byte
rb As _Byte
mb As _Byte
mw As _Byte
clkcnt As _Byte
caps As _Byte
shift As _Byte
ctrl As _Byte
alt As _Byte
AltSwitch As _Byte
prevx As _Byte
prevy As _Byte
drag As _Byte
sbar As _Byte
sbRow As _Byte
oldsbRow As _Byte
ThumbTop As _Byte
ThumbSize As _Byte
ThumbDrag As _Byte
autokey As String
End Type
Dim m As MouseVar
Type ColorVar
pal1 As _Byte
pal2 As _Byte
pal3 As _Byte
pal4 As _Byte
PageColor As _Byte
SkinFrg As _Byte
SkinBkg As _Byte
InputFrg As _Byte
InputFrg2 As _Byte
InputBkg As _Byte
InputHl As _Byte
InputH2 As _Byte
SkinShadowFrg As _Byte
SkinShadowBkg As _Byte
PopupFrg As _Byte
PopupBkg As _Byte
PopupUnavail As _Byte
PopupShadowFrg As _Byte
PopupShadowBkg As _Byte
PopupMenuBarFrg As _Byte
PopupMenuBarBkg As _Byte
FixedMenuFrg As _Byte
FixedMenuBkg As _Byte
FixedMenuHlFrg As _Byte
FixedMenuHlBkg As _Byte
FixedMenuScFrg As _Byte
PageMenuFrg As _Byte
PageFrg As _Byte
PageBkg As _Byte
ILF As _Byte
ILB As _Byte
PageMenuBkg As _Byte
PageMenuHlFrg As _Byte
PageMenuHlBkg As _Byte
PageMenuBdr As _Byte
HyperFrg As _Byte
HyperBkg As _Byte
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_Links 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 = 42
t.ScrnResizeMinW = 80
t.ScrnResizeMinH = 42
pop.MenuBarRow = 1
pop.MenuBarLt = " File Edit View Search"
pop.MenuBarRt = "Help "
pop.FixMenuT = 21
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.HyperFrg = 11
c.HyperBkg = 1
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
PageHyperLinks:
Data QB64Phoenix.com,"https://qb64phoenix.com/forum/showthread.php?tid=4256",1
Data This is a message box test,"The link you clicked generated+chr$(13)+chr$(10)+This message box popup.",2
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 For
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.MenuT = m.y + 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, MCursor As _Byte, oldMCursor As _Byte
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
x$ = ""
If InStr(PageMap$(m.y), " ") Then
If InStr(Mid$(PageMap$(m.y), m.x, 1), " ") = 0 Then
x$ = Mid$(PageMap$(m.y), m.x, 1)
End If
End If
If Len(x$) Then
If Asc(x$) - 32 > 111 Then MCursor = -1 Else MCursor = 1
Else
MCursor = 0
End If
If MCursor <> oldMCursor Then If MCursor = -1 Then _MouseShow "Link" Else _MouseShow "Default"
oldMCursor = MCursor
If MCursor = -1 And m.lb = 2 Then
Restore PageHyperLinks: i = 0
Do
i = i + 1
Read a$, mylink$, j
Loop Until i = Asc(x$) - 144
If j = 1 Then Shell _DontWait mylink$
If j = 2 Then
If InStr(LCase$(mylink$), "chr$(13)") Then
a$ = "": x$ = mylink$
Do
a$ = a$ + Mid$(x$, 1, InStr(LCase$(x$), "+") - 1) + Chr$(13) + Chr$(10)
x$ = Mid$(mylink$, InStr(LCase$(mylink$), "chr$(10)") + 9)
Loop Until InStr(LCase$(x$), "chr$(13)") = 0
mylink$ = a$ + x$: a$ = "": x$ = ""
End If
_MessageBox "User Message", mylink$, "info"
End If
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 Clear Search 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$
Color c.PageFrg, c.PageBkg: a$ = "Visit this project: ": Locate CsrLin + 3, 2: Print a$;
Color c.HyperFrg, c.HyperBkg: Link t
Color c.PageFrg, c.PageBkg: Locate , Pos(0) + 10: a$ = "Message: ": Print a$;
Color c.HyperFrg, c.HyperBkg: Link t
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 _Byte
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, MapIDMenu As _Byte, 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
MapIDMenu = MapIDMenu + 1
Restore PageMenuData
For i = 1 To MapIDMenu
Do
Read tmp$
If tmp$ = "eom" Then Exit For
If tmp$ = "eof" Then If cnt + 1 = MapIDMenu Then Exit For Else cnt = cnt + 1: k = 0: _Continue
If cnt + 1 = MapIDMenu Then
If k < Len(tmp$) Then k = Len(tmp$)
End If
Loop
Next
If MapIDMenu = 111 Then ' Hard Limit
_MessageBox "Configuration Error", "The maximun number of PageMap arrays (111) 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$(MapIDMenu + 33)))
If InStr(t.InputLine, Chr$(y + 32)) = 0 Then t.InputLine = t.InputLine + Chr$(y + 32)
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 Link (t As TextVar)
Static initiate, MapIDLink As _Byte
y = CsrLin: x = Pos(0)
If initiate = 0 Then
t1 = _NewImage(1200, 1, 32)
_Dest t1
Line (0, 0)-(1200, 0), _RGB32(255, 255, 255), B
t.HLnk = _CopyImage(t1, 33)
_Dest 0
_FreeImage t1
End If
MapIDLink = MapIDLink + 1
Restore PageHyperLinks: i = 0
Do
i = i + 1
Read a$, tmp$, tmp$
Loop Until i = MapIDLink
k = Len(a$)
If MapIDLink = 111 Then ' Hard Limit
_MessageBox "Configuration Error", "The maximun number of hyperlink arrays (111) has been reached.", "error"
System
End If
If LTrim$(PageMap$(CsrLin)) = "" Then PageMap$(CsrLin) = Space$(_Width)
Mid$(PageMap$(y), x, k) = String$(k, Asc(Chr$(MapIDLink + 144)))
If InStr(t.InputLine, Chr$(y + 143)) = 0 Then t.InputLine = t.InputLine + Chr$(y + 143)
Print a$;
End Sub
Sub Page_Menus_Links (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
If Asc(x$) > 110 Then
Sound 500, 1: ' Hyperlink
Else
pop.MenuModel = 5: pop.Show = Asc(x$) - 33
pop.PageMenuy = m.y
pop.PageMenux = InStr(PageMap$(m.y), x$)
End If
End If
End If
End Sub
Sub HW_Input_Field (t As TextVar, pop As PopupVar)
Static InFldL, InFldR
If t.PopupHardwareAceleration = 0 Then Exit Sub '========================>
If pop.MenuModel = 5 And pop.MenuL Then ' Note: MenuL indicates the cycle is past the point of te menu opening.
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, 0)-((pop.mwidth - 1) * t.fw, pop.mheight * t.fh)
End If
h = 0
Do
seed = 0: h = h + 1: x$ = Mid$(t.InputLine, h, 1): If Len(x$) Then i = Asc(x$) - 32 Else Exit Do
If i > 111 Then i = i - 111: mylink = 1 Else mylink = 0
Do
cRow = i: k1 = 1
tmp$ = Mid$(PageMap$(i), seed): x$ = Left$(LTrim$(tmp$), 1)
InFldL = InStr(PageMap$(i), x$): If mylink = 0 Then InFldL = InFldL - 2
InFldR = _InStrRev(PageMap$(i), x$)
seed = InFldR + 1
If pop.Show Then
If cRow >= pop.MenuT And cRow < pop.MenuB And InFldR >= pop.MenuL And InFldL <= pop.MenuR Then
MenuOverlap = _TRUE
Else
MenuOverlap = _FALSE
End If
End If
If mylink Then
If Not MenuOverlap Then
_PutImage ((InFldL - 1) * t.fw, cRow * t.fh - 2), t.HLnk, , (0, 0)-((InFldR - InFldL + 1) * t.fw, 0)
Else
dy1 = cRow * t.fh - 2: sy1 = 0: sy2 = 0
sx1 = (pop.MenuR - (InFldL - 1)) * t.fw
If pop.MenuModel = 5 Then
dx1 = pop.MenuR * t.fw: k1 = 0
sx2 = (InFldR - InFldL + 1) * t.fw
Else
dx1 = (pop.MenuR - 1) * t.fw - p1: k1 = t.fw / 2
sx2 = (InFldR - InFldL + 2) * t.fw + p1
End If
If InFldL < pop.MenuL Then _PutImage ((InFldL - 1) * t.fw, cRow * t.fh - 2), t.HLnk, , (0, 0)-((pop.MenuL - InFldL) * t.fw + k1, 0)
If pop.MenuR - 1 <= InFldR Then
_PutImage (dx1, dy1), t.HLnk, , (sx1, sy1)-(sx2, sy2)
End If
End If
Else
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 Not MenuOverlap Then
_PutImage (InFldL * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((InFldR - InFldL) * t.fw, t.fh)
_PutImage (InFldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
_PutImage ((InFldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
Else
dy1 = (cRow - 1) * t.fh: sy1 = 0: sy2 = t.fh
sx1 = (pop.MenuR - (InFldL - 1)) * t.fw
If pop.MenuModel = 5 Then
dx1 = pop.MenuR * t.fw: k1 = 0
sx2 = (InFldR - InFldL + 1) * t.fw
Else
dx1 = (pop.MenuR - 1) * t.fw - p1
sx2 = (InFldR - InFldL + 2) * t.fw + p1
End If
If InFldL < pop.MenuL Then _PutImage (InFldL * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((pop.MenuL - InFldL - 1) * t.fw + p1 * k1, t.fh)
If pop.MenuR - 1 <= InFldR Then
_PutImage (dx1, dy1), t.hwFieldFront, , (sx1, sy1)-(sx2, sy2)
_PutImage (InFldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
If pop.MenuR - 1 < InFldR Then _PutImage ((InFldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
End If
End If
End If
Loop Until LTrim$(Mid$(PageMap$(i), seed)) = ""
Loop
End Sub
I might add some html like special effects to the link clicking, later. Next step, after a break, will either be adding documentation or page scrolling.
Pete
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
Fiddling around with a bit of optmizing, but I also had to redo a little of the resize routine to handle the newer stuff. The resize routine includes a min height and width, which fr this demo is the same as the starting diminsions. If you make it smaller, it no longer changes the actual screen size. It just collimates in.
Code: (Select All)
$Resize:On
_ScreenMove 200, 10
ReDim Shared PageMap$(0), MapIDMenu, MapIDLink
Type GlobalVar
anum As _Byte
MyScreen As _Byte
UcaseKeys As String
LcaseKeys As String
CtrlKeys As String
AltKeys As String
End Type
Dim gbl As GlobalVar
Type TextVar
HardwareMenus As _Byte ' 0 or 1.
FormStyle As _Byte
InptMthd As _Byte ' 2 is for creating an input field when csrlin is activated by mouse or keyboard.
mt As _Byte
mr As _Byte
mb As _Byte
ml As _Byte
bsTop As _Byte
bsRight As _Byte
bsBottom As _Byte
bsLeft As _Byte
noe As _Byte
nol As _Byte
scr As _Byte
oldscr As _Byte
wide As _Byte
tall As _Byte
fw As _Byte
fh As _Byte
redisplay As _Byte
hl As _Byte
HlFind As _Byte
ScreenEstablished As _Byte
ScrnW As _Byte
ScrnH As _Byte
ScrnResize As _Byte
ScrnResizeMinW As _Byte
ScrnResizeMinH As _Byte
ScrnResizeInputRow As _Byte
ScrnResizeInputCol As _Byte
RollupEvent As _Byte
RollupStatus As _Byte
HoldScr As _Byte
persistency As _Byte ' 1 or 0
UseDefaultDisplay As _Byte ' 1 or 0
InputActive As _Byte ' Records cursor row.
redo As _Byte
undo As _Byte
RedoText As String
UndoText As String
MarkerOn As _Byte
marker As _Byte
EncodeOn As _Byte
remakeIDX As _Byte
hideshow As String
AddDelete As _Byte ' 1 Add, -1 Delete, or 0 inactive.
OpenInput As _Byte ' 1 Open input line pase colon or 2 Open entire input line.
hgltPos1 As _Byte
hwUnderlineShow As _Byte
hwUnderlineImage As Long
InputLine As String ' Records cursor row.
hwFieldPresent As _Byte
hwFieldFront As Long
hwFieldBack As Long
PopupHardwareAceleration As _Byte
PageMenuHWFront As Long
PageMenuHWBack As Long
tri As Long
HLnk As Long
End Type
Dim t As TextVar
Type InputVar
CurStyle As _Byte
CurShow As _Byte
fld As _Byte
mtop As _Byte
mleft As _Byte
myclose As _Byte
mxclose As _Byte
End Type
Dim in As InputVar
Type PopupVar
ForceInitiate As _Byte
Show As _Byte ' Number of window to show.
CloseReOpen As _Byte ' Number of window to show after previous window gets closed.
hwWindow As Long
mwidth As _Byte
mheight As _Byte
FixMenuT As _Byte
FixMenuL As _Byte
MenuT As _Byte
MenuB As _Byte
MenuL As _Byte
MenuR As _Byte
MenuHL As _Byte
MarginRt As _Byte
BoundsLt As _Byte
BoundsRt As _Byte
Shadow As _Byte ' 0 or 1.
VSpacing As _Byte
Choice As _Byte
ChoiceName As String
PageMenuy As _Byte
PageMenux As _Byte
MenuBar As String
MenuBarLt As String
MenuBarRt As String
MenuBarRow As _Byte
MenuModel As _Byte
PMImageHeight As _Byte
ID As String
SuckerFish As _Byte
End Type
Dim pop As PopupVar
Type MouseVar
x As _Byte
y As _Byte
lb As _Byte
rb As _Byte
mb As _Byte
mw As _Byte
clkcnt As _Byte
caps As _Byte
shift As _Byte
ctrl As _Byte
alt As _Byte
AltSwitch As _Byte
prevx As _Byte
prevy As _Byte
drag As _Byte
sbar As _Byte
sbRow As _Byte
oldsbRow As _Byte
ThumbTop As _Byte
ThumbSize As _Byte
ThumbDrag As _Byte
autokey As String
Pointer As _Byte
End Type
Dim m As MouseVar
Type ColorVar
pal1 As _Byte
pal2 As _Byte
pal3 As _Byte
pal4 As _Byte
PageColor As _Byte
SkinFrg As _Byte
SkinBkg As _Byte
InputFrg As _Byte
InputFrg2 As _Byte
InputBkg As _Byte
InputHl As _Byte
InputH2 As _Byte
SkinShadowFrg As _Byte
SkinShadowBkg As _Byte
PopupFrg As _Byte
PopupBkg As _Byte
PopupUnavail As _Byte
PopupShadowFrg As _Byte
PopupShadowBkg As _Byte
PopupMenuBarFrg As _Byte
PopupMenuBarBkg As _Byte
FixedMenuFrg As _Byte
FixedMenuBkg As _Byte
FixedMenuHlFrg As _Byte
FixedMenuHlBkg As _Byte
FixedMenuScFrg As _Byte
PageMenuFrg As _Byte
PageFrg As _Byte
PageBkg As _Byte
ILF As _Byte
ILB As _Byte
PageMenuBkg As _Byte
PageMenuHlFrg As _Byte
PageMenuHlBkg As _Byte
PageMenuBdr As _Byte
HyperFrg As _Byte
HyperBkg As _Byte
End Type
Dim c As ColorVar
User_Defined_Variables gbl, t, pop, c
ReDim text$(1)
Do
_Limit 60
ScreenSize t, m, 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_Links 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 = 42
t.ScrnResizeMinW = 90
t.ScrnResizeMinH = 42
pop.MenuBarRow = 1
pop.MenuBarLt = " File Edit View Search"
pop.MenuBarRt = "Help "
pop.FixMenuT = 21
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.HyperFrg = 11
c.HyperBkg = 1
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
PageHyperLinks:
Data QB64Phoenix.com,"https://qb64phoenix.com/forum/showthread.php?tid=4256",1
Data This is a message box test,"The link you clicked generated+chr$(13)+chr$(10)+This message box popup.",2
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 For
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.MenuT = m.y + 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)
_Dest 0
_FreeImage t1
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.Pointer = -1 And m.lb = 2 Then
Restore PageHyperLinks: i = 0
x$ = Mid$(PageMap$(m.y), m.x, 1)
Do
i = i + 1
Read a$, mylink$, j
Loop Until i = Asc(x$) - 144
If j = 1 Then Shell _DontWait mylink$
If j = 2 Then
If InStr(LCase$(mylink$), "chr$(13)") Then
a$ = "": x$ = mylink$
Do
a$ = a$ + Mid$(x$, 1, InStr(LCase$(x$), "+") - 1) + Chr$(13) + Chr$(10)
x$ = Mid$(mylink$, InStr(LCase$(mylink$), "chr$(10)") + 9)
Loop Until InStr(LCase$(x$), "chr$(13)") = 0
mylink$ = a$ + x$: a$ = "": x$ = ""
End If
_MessageBox "User Message", mylink$, "info"
End If
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 Clear Search 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:
Color c.PageFrg, c.PageBkg
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
insert t, c, a$
Locate CsrLin + 3, 2
a$ = "Hardware Fields: ": Print a$;
j = HWChoice: GoSub getdata
insert t, c, a$
Locate , Pos(0) + 10
a$ = "Rate Pete's Demo as: ": Print a$;
j = rating: GoSub getdata
insert t, c, a$
a$ = "Visit this project: ": Locate CsrLin + 3, 2: Print a$;
Link t, c
Locate , Pos(0) + 10: a$ = "Message: ": Print a$;
Link t, c
Locate CsrLin + 2, 1
Color 1, 3
For i = 1 To 20
Print String$(_Width, Chr$(177))
Next
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, m As MouseVar, c As ColorVar)
Static initiate, oldMPointer
y = CsrLin: x = Pos(0)
x$ = ""
If InStr(PageMap$(m.y), " ") Then
If InStr(Mid$(PageMap$(m.y), m.x, 1), " ") = 0 Then x$ = Mid$(PageMap$(m.y), m.x, 1)
End If
If Len(x$) Then
If Asc(x$) - 32 > 111 Then m.Pointer = -1 Else m.Pointer = 1
Else
m.Pointer = 0
End If
If m.Pointer <> oldMPointer Then If m.Pointer = -1 Then _MouseShow "Link" Else _MouseShow "Default"
oldMPointer = m.Pointer
Do
If initiate = 0 Then
_Resize On: w = t.ScrnW: h = t.ScrnH
ElseIf t.ScrnResize = 1 Then t.ScrnResize = 2
ElseIf t.ScrnResize = 2 Then t.ScrnResize = 0: Exit Do ' Resize cycle complete.
End If
If initiate Then
Select Case t.ScrnResize
Case 2
i = _ResizeWidth \ t.fw: j = _ResizeHeight \ t.fh: k = 0
If i < x Or i < t.ScrnResizeMinW Or i = _Width Then k = k + 1: w = _Width Else w = i
If j < y Or j < t.ScrnResizeMinH Or j = _Height Then k = k + 1: h = _Height Else h = j
If k = 2 Then t.ScrnResize = 0: Exit Do ' Resize cycle force complete.
Case Else
j = _ResizeWidth \ _FontWidth: k = _ResizeHeight \ _FontHeight
If j >= t.ScrnResizeMinW And j <> _Width Or k >= t.ScrnResizeMinH And k <> _Height Then t.ScrnResize = 1: Exit Do
End Select
End If
If initiate = 0 Or t.ScrnResize = 2 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
initiate = 1: MapIDMenu = 0: MapIDLink = 0
End If
Exit Do
Loop
Locate y, x
End Sub
Sub FreeCopy (gbl As GlobalVar, SCopy())
Static fcopy$
Dim i As _Byte
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, c As ColorVar, ins$)
Static initiate
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
t1 = _NewImage(16, 16, 32)
_Dest t1
a1 = 6: c1 = 0: w = a1 * 2: h = a ' Draw a triangle.
For i = 0 To 6
Line (a1, c1)-(a1 + i * 2, c1), _RGB32(255, 255, 255, 150)
a1 = a1 - 1: c1 = c1 + 1
Next
t.tri = _CopyImage(t1, 33)
_FreeImage t1
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)
_Dest 0
_FreeImage t1
End If
MapIDMenu = MapIDMenu + 1
Restore PageMenuData
For i = 1 To MapIDMenu
Do
Read tmp$
If tmp$ = "eom" Then Exit For
If tmp$ = "eof" Then If cnt + 1 = MapIDMenu Then Exit For Else cnt = cnt + 1: k = 0: _Continue
If cnt + 1 = MapIDMenu And k < Len(tmp$) Then k = Len(tmp$)
Loop
Next
If MapIDMenu = 111 Then ' Hard Limit
_MessageBox "Configuration Error", "The maximun number of PageMap arrays (111) 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$(MapIDMenu + 33)))
If InStr(t.InputLine, Chr$(y + 32)) = 0 Then t.InputLine = t.InputLine + Chr$(y + 32)
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
Color c.ILF, c.ILB
Locate y, x: Print ins$;: Locate y, x
Color restore_color1, restore_color2
End Sub
Sub Link (t As TextVar, c As ColorVar)
Static initiate
y = CsrLin: x = Pos(0)
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If initiate = 0 Then
t1 = _NewImage(1200, 1, 32)
_Dest t1
Line (0, 0)-(1200, 0), _RGB32(0, 144, 211)
t.HLnk = _CopyImage(t1, 33)
_Dest 0
_FreeImage t1
End If
MapIDLink = MapIDLink + 1
Restore PageHyperLinks: i = 0
Do
i = i + 1
Read a$, tmp$, tmp$
Loop Until i = MapIDLink
k = Len(a$)
If MapIDLink = 111 Then ' Hard Limit
_MessageBox "Configuration Error", "The maximun number of hyperlink arrays (111) has been reached.", "error"
System
End If
If LTrim$(PageMap$(CsrLin)) = "" Then PageMap$(CsrLin) = Space$(_Width)
Mid$(PageMap$(y), x, k) = String$(k, Asc(Chr$(MapIDLink + 144)))
If InStr(t.InputLine, Chr$(y + 143)) = 0 Then t.InputLine = t.InputLine + Chr$(y + 143)
Color c.HyperFrg, c.HyperBkg: Print a$;
Color restore_color1, restore_color2
End Sub
Sub Page_Menus_Links (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
If Asc(x$) > 110 Then
' Hyperlink
Else
pop.MenuModel = 5: pop.Show = Asc(x$) - 33
pop.PageMenuy = m.y
pop.PageMenux = InStr(PageMap$(m.y), x$)
End If
End If
End If
End Sub
Sub HW_Input_Field (t As TextVar, pop As PopupVar)
Static InFldL, InFldR
If t.PopupHardwareAceleration = 0 Then Exit Sub '========================>
If pop.MenuModel = 5 And pop.MenuL Then ' Note: MenuL indicates the cycle is past the point of te menu opening.
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, 0)-((pop.mwidth - 1) * t.fw, pop.mheight * t.fh)
End If
h = 0
Do
seed = 0: h = h + 1: x$ = Mid$(t.InputLine, h, 1): If Len(x$) Then i = Asc(x$) - 32 Else Exit Do
If i > 111 Then i = i - 111: mylink = 1 Else mylink = 0
Do
cRow = i: k1 = 1
tmp$ = Mid$(PageMap$(i), seed): x$ = Left$(LTrim$(tmp$), 1)
InFldL = InStr(PageMap$(i), x$): If mylink = 0 Then InFldL = InFldL - 2
InFldR = _InStrRev(PageMap$(i), x$)
seed = InFldR + 1
If pop.Show Then
If cRow >= pop.MenuT And cRow < pop.MenuB And InFldR >= pop.MenuL And InFldL <= pop.MenuR Then
MenuOverlap = _TRUE
Else
MenuOverlap = _FALSE
End If
End If
If mylink Then
If Not MenuOverlap Then
_PutImage ((InFldL - 1) * t.fw, cRow * t.fh - 2), t.HLnk, , (0, 0)-((InFldR - InFldL + 1) * t.fw, 0)
Else
dy1 = cRow * t.fh - 2: sy1 = 0: sy2 = 0
sx1 = (pop.MenuR - (InFldL - 1)) * t.fw
If pop.MenuModel = 5 Then
dx1 = pop.MenuR * t.fw: k1 = 0
sx2 = (InFldR - InFldL + 1) * t.fw
Else
dx1 = (pop.MenuR - 1) * t.fw - p1: k1 = t.fw / 2
sx2 = (InFldR - InFldL + 2) * t.fw + p1
End If
If InFldL < pop.MenuL Then _PutImage ((InFldL - 1) * t.fw, cRow * t.fh - 2), t.HLnk, , (0, 0)-((pop.MenuL - InFldL) * t.fw + k1, 0)
If pop.MenuR - 1 <= InFldR Then
_PutImage (dx1, dy1), t.HLnk, , (sx1, sy1)-(sx2, sy2)
End If
End If
Else
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 Not MenuOverlap Then
_PutImage (InFldL * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((InFldR - InFldL) * t.fw, t.fh)
_PutImage (InFldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
_PutImage ((InFldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
Else
dy1 = (cRow - 1) * t.fh: sy1 = 0: sy2 = t.fh
sx1 = (pop.MenuR - (InFldL - 1)) * t.fw
If pop.MenuModel = 5 Then
dx1 = pop.MenuR * t.fw: k1 = 0
sx2 = (InFldR - InFldL + 1) * t.fw
Else
dx1 = (pop.MenuR - 1) * t.fw - p1
sx2 = (InFldR - InFldL + 2) * t.fw + p1
End If
If InFldL < pop.MenuL Then _PutImage (InFldL * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((pop.MenuL - InFldL - 1) * t.fw + p1 * k1, t.fh)
If pop.MenuR - 1 <= InFldR Then
_PutImage (dx1, dy1), t.hwFieldFront, , (sx1, sy1)-(sx2, sy2)
_PutImage (InFldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
If pop.MenuR - 1 < InFldR Then _PutImage ((InFldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
End If
End If
End If
Loop Until LTrim$(Mid$(PageMap$(i), seed)) = ""
Loop
End Sub
Pete
Posts: 3,446
Threads: 376
Joined: Apr 2022
Reputation:
345
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
Posts: 4,695
Threads: 222
Joined: Apr 2022
Reputation:
322
Well I am not ignoring this project. I look in from time to time to see how many LOC hes up to now, currently less that 400 LOC from my entire Interpreter! Just the UDT's are too overwhelming to consider actually using all this stuff for myself but I am not as big a fan of Screen 0 as Pete.
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
01-29-2026, 06:45 PM
(This post was last modified: 01-29-2026, 07:01 PM by Pete.)
Nah, Steve and I are just poking fun at one another. It's our bit, and I'd miss him if my sites were off if he wasn't here.
If it makes you feel any better, that long list of UDT's drives me batchit, too! I think if I made an IDE, I'd have an option to hide/show them like Steve hides quotes.
The code is longer due to the option of running hardware or regular SCREEN 0 menus. Also options like line-spacing or including separators in menus. It would be about 30% reduced without these options, and 35% reduced without other options like color choices.
Now later I might add a font sizer. It also needs an option to retrieve data from a database instead of just data fields.
My hat's off to Sam for... @a740g
Making
Zero
Fun
Again
Too bad it doesn't spell anything like Make America For Italians Again. Took off well in New York and Las Vegas.
Pete
Posts: 346
Threads: 45
Joined: Jun 2024
Reputation:
32
l agree with @BPlus as to do this i'd have either wrapped the windows api or gone a separate route with C++. I do though think that once Pete finalises this, the commands to make, update and use menus will be like @Pete , SIMPLE!
I offered my help, provided other avenues, etc so i HOPE that me not replying isnt seen as me ignoring. In fact we are in the same boat, we make massive libs and functionality but based on how vast and complicated it is to others we get little feedback...
Me
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
Steve's just stirring the pot, because my arms got tired.
Well did some debugging, found out something interesting about hardware handles, and added the font sizing to work with the hand in hand with the _RESIZE feature.
Alt +(+ or -) to change text size. Use Alt + Backspace for default font.
Code: (Select All)
$Resize:On
_ScreenMove 200, 10
ReDim Shared PageMap$(0), MapIDMenu, MapIDLink
Type GlobalVar
anum As _Byte
MyScreen As _Byte
UcaseKeys As String
LcaseKeys As String
CtrlKeys As String
AltKeys As String
End Type
Dim gbl As GlobalVar
Type TextVar
HardwareMenus As _Byte ' 0 or 1.
FormStyle As _Byte
InptMthd As _Byte ' 2 is for creating an input field when csrlin is activated by mouse or keyboard.
mt As _Byte
mr As _Byte
mb As _Byte
ml As _Byte
bsTop As _Byte
bsRight As _Byte
bsBottom As _Byte
bsLeft As _Byte
noe As _Byte
nol As _Byte
scr As _Byte
oldscr As _Byte
wide As _Byte
tall As _Byte
fw As _Byte
fh As _Byte
redisplay As _Byte
hl As _Byte
HlFind As _Byte
ScreenEstablished As _Byte
ScrnW As _Byte
ScrnH As _Byte
ScrnResize As _Byte
ScrnResizeMinW As _Byte
ScrnResizeMinH As _Byte
ScrnResizeInputRow As _Byte
ScrnResizeInputCol As _Byte
RollupEvent As _Byte
RollupStatus As _Byte
HoldScr As _Byte
persistency As _Byte ' 1 or 0
UseDefaultDisplay As _Byte ' 1 or 0
InputActive As _Byte ' Records cursor row.
redo As _Byte
undo As _Byte
RedoText As String
UndoText As String
MarkerOn As _Byte
marker As _Byte
EncodeOn As _Byte
remakeIDX As _Byte
hideshow As String
AddDelete As _Byte ' 1 Add, -1 Delete, or 0 inactive.
OpenInput As _Byte ' 1 Open input line pase colon or 2 Open entire input line.
hgltPos1 As _Byte
hwUnderlineShow As _Byte
hwUnderlineImage As Long
HWPgMuTracker As String ' Records cursor row.
hwFieldPresent As _Byte
hwFieldFront As Long
hwFieldBack As Long
PopupHardwareAceleration As _Byte
PageMenuHWFront As Long
PageMenuHWBack As Long
tri As Long
HLnk As Long
WinFont As String
MyFont As String
NewFont As _Byte
FSize As _Byte
End Type
Dim t As TextVar
Type InputVar
CurStyle As _Byte
CurShow As _Byte
fld As _Byte
mtop As _Byte
mleft As _Byte
myclose As _Byte
mxclose As _Byte
End Type
Dim in As InputVar
Type PopupVar
ForceInitiate As _Byte
Show As _Byte ' Number of window to show.
CloseReOpen As _Byte ' Number of window to show after previous window gets closed.
hwWindow As Long
mwidth As _Byte
mheight As _Byte
FixMenuT As _Byte
FixMenuL As _Byte
MenuT As _Byte
MenuB As _Byte
MenuL As _Byte
MenuR As _Byte
MenuHL As _Byte
MarginRt As _Byte
BoundsLt As _Byte
BoundsRt As _Byte
Shadow As _Byte ' 0 or 1.
VSpacing As _Byte
Choice As _Byte
ChoiceName As String
PageMenuy As _Byte
PageMenux As _Byte
MenuBar As String
MenuBarLt As String
MenuBarRt As String
MenuBarRow As _Byte
MenuModel As _Byte
PMImageHeight As _Byte
ID As String
SuckerFish As _Byte
End Type
Dim pop As PopupVar
Type MouseVar
x As _Byte
y As _Byte
lb As _Byte
rb As _Byte
mb As _Byte
mw As _Byte
clkcnt As _Byte
caps As _Byte
shift As _Byte
ctrl As _Byte
alt As _Byte
AltSwitch As _Byte
prevx As _Byte
prevy As _Byte
drag As _Byte
sbar As _Byte
sbRow As _Byte
oldsbRow As _Byte
ThumbTop As _Byte
ThumbSize As _Byte
ThumbDrag As _Byte
autokey As String
Pointer As _Byte
End Type
Dim m As MouseVar
Type ColorVar
pal1 As _Byte
pal2 As _Byte
pal3 As _Byte
pal4 As _Byte
PageColor As _Byte
SkinFrg As _Byte
SkinBkg As _Byte
InputFrg As _Byte
InputFrg2 As _Byte
InputBkg As _Byte
InputHl As _Byte
InputH2 As _Byte
SkinShadowFrg As _Byte
SkinShadowBkg As _Byte
PopupFrg As _Byte
PopupBkg As _Byte
PopupUnavail As _Byte
PopupShadowFrg As _Byte
PopupShadowBkg As _Byte
PopupMenuBarFrg As _Byte
PopupMenuBarBkg As _Byte
FixedMenuFrg As _Byte
FixedMenuBkg As _Byte
FixedMenuHlFrg As _Byte
FixedMenuHlBkg As _Byte
FixedMenuScFrg As _Byte
PageMenuFrg As _Byte
PageFrg As _Byte
PageBkg As _Byte
ILF As _Byte
ILB As _Byte
PageMenuBkg As _Byte
PageMenuHlFrg As _Byte
PageMenuHlBkg As _Byte
PageMenuBdr As _Byte
HyperFrg As _Byte
HyperBkg As _Byte
End Type
Dim c As ColorVar
User_Defined_Variables gbl, t, pop, c
ReDim text$(1)
Do
_Limit 60
ScrnActions t, pop, m, c, b$
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()
Follow_Links pop, m
HW_Display 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.WinFont = "lucon.ttf"
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 = 42
t.ScrnResizeMinW = 84
t.ScrnResizeMinH = 42
pop.MenuBarRow = 1
pop.MenuBarLt = " File Edit View Search"
pop.MenuBarRt = "Help "
pop.FixMenuT = 21
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.HyperFrg = 11
c.HyperBkg = 1
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
PageHyperLinks:
Data QB64Phoenix.com,"https://qb64phoenix.com/forum/showthread.php?tid=4256",1
Data This is a message box test,"The link you clicked generated+chr$(13)+chr$(10)+This message box popup.",2
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() ' Note: Only close the suckerfish. The parent menu is colsed in the popup sub.
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$()
y = CsrLin: x = Pos(0): restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If pop.MenuModel = 5 Then
If initiate = 0 Then
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 For
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.MenuT = m.y + 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 Or t.NewFont = -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
If SFhwWindow& Then _FreeImage SFhwWindow&: SFhwWindow& = 0
ReDim SFParentMenu$(0), SFParentSc$(0), SFParentID$(0), SFMenuRestrict(0)
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
End If
If pop.Show Then
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
in.CurShow = 0: Locate , , in.CurShow ' Hide cursor
nomi = 0: oldmy = 0: oldmx = 0: myalt = 0: pop.MenuHL = 0
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
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
If pop.SuckerFish Then
SFhwWindow& = _CopyImage(t1, 33)
Swap pop.hwWindow, SFhwWindow&
Else
If pop.hwWindow Then _FreeImage pop.hwWindow
pop.hwWindow = _CopyImage(t1, 33)
End If
_Dest 0
_FreeImage t1
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 Or t.NewFont = -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
Swap pop.hwWindow, SFhwWindow&
_FreeImage SFhwWindow&: SFhwWindow& = 0
gbl.anum = -2: FreeCopy gbl, SCopy()
oldmy = -1: oldmx = -1 ' Allows highlighting to follow mouse when suckerfish menu closes.
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
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
If SFhwWindow& Then _FreeImage SFhwWindow&: SFhwWindow& = 0
If pop.hwWindow Then _FreeImage pop.hwWindow: pop.hwWindow = 0
pop.MenuModel = -pop.MenuModel
pop.SuckerFish = 0: SFParentT = 0: SFParentR = 0: SFParentB = 0: SFParentL = 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.Pointer = -1 And m.lb = 2 Then
Restore PageHyperLinks: i = 0
x$ = Mid$(PageMap$(m.y), m.x, 1)
Do
i = i + 1
Read a$, mylink$, j
Loop Until i = Asc(x$) - 144
If j = 1 Then Shell _DontWait mylink$
If j = 2 Then
If InStr(LCase$(mylink$), "chr$(13)") Then
a$ = "": x$ = mylink$
Do
a$ = a$ + Mid$(x$, 1, InStr(LCase$(x$), "+") - 1) + Chr$(13) + Chr$(10)
x$ = Mid$(mylink$, InStr(LCase$(mylink$), "chr$(10)") + 9)
Loop Until InStr(LCase$(x$), "chr$(13)") = 0
mylink$ = a$ + x$: a$ = "": x$ = ""
End If
_MessageBox "User Message", mylink$, "info"
End If
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 Clear Search 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:
Color c.PageFrg, c.PageBkg
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"
Locate CsrLin + 1, 2
a$ = "Current Menu Type: ": Print a$;: j = MChoice: GoSub getdata: PgMu t, c, a$
Locate CsrLin + 3, 2
a$ = "Hardware Fields: ": Print a$;: j = HWChoice: GoSub getdata: PgMu t, c, a$
Locate , Pos(0) + 10
a$ = "Rate Pete's Demo as: ": Print a$;: j = rating: GoSub getdata: PgMu t, c, a$
a$ = "Visit this project: ": Locate CsrLin + 3, 2: Print a$;: Link t, c
Locate , Pos(0) + 10
a$ = "Message: ": Print a$;: Link t, c
Locate CsrLin + 2, 1
Color 1, 3: For i = 1 To 20: Print String$(_Width, Chr$(177)): Next
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 ScrnActions (t As TextVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$)
Static initiate, oldMPointer, FontResize
y = CsrLin: x = Pos(0)
If t.NewFont Then t.NewFont = 0: Font_Size t, pop
If m.alt Then
Select Case b$
Case Chr$(0) + Chr$(14)
If Len(t.MyFont) And t.MyFont <> "Default" Then
t.MyFont = "Default": t.NewFont = -1: FontResize = -1: Exit Sub
End If
Case Chr$(0) + Chr$(130), Chr$(0) + Chr$(131)
If t.FSize = 0 Then t.FSize = 15
Select Case b$
Case Chr$(0) + Chr$(131): If t.FSize < 31 Then j = 1 Else j = 0
Case Chr$(0) + Chr$(130): If t.FSize > 8 Then j = -1 Else j = 0
End Select
If j Then t.FSize = t.FSize + j: t.MyFont = t.WinFont: t.NewFont = -1: FontResize = -1: Exit Sub
Case Else
If Len(b$) Then FontResize = 0
End Select
Else
FontResize = 0
End If
_Title Str$(FontResize)
x$ = ""
If InStr(PageMap$(m.y), " ") Then
If InStr(Mid$(PageMap$(m.y), m.x, 1), " ") = 0 Then x$ = Mid$(PageMap$(m.y), m.x, 1)
End If
If Len(x$) Then
If Asc(x$) - 32 > 111 Then m.Pointer = -1 Else m.Pointer = 1
Else
m.Pointer = 0
End If
If m.Pointer <> oldMPointer Then If m.Pointer = -1 Then _MouseShow "Link" Else _MouseShow "Default"
oldMPointer = m.Pointer
Do
If initiate = 0 Then
_Resize On: w = t.ScrnW: h = t.ScrnH
ElseIf t.ScrnResize = 1 Then t.ScrnResize = 2
ElseIf t.ScrnResize = 2 Then t.ScrnResize = 0: Exit Do ' Resize cycle complete.
End If
If initiate Then
Select Case t.ScrnResize
Case 2
i = _ResizeWidth \ t.fw: j = _ResizeHeight \ t.fh: k = 0
If i < x Or i < t.ScrnResizeMinW Or i = _Width Then k = k + 1: w = _Width Else w = i
If j < y Or j < t.ScrnResizeMinH Or j = _Height Then k = k + 1: h = _Height Else h = j
If k = 2 Then t.ScrnResize = 0: Exit Do ' Resize cycle force complete.
Case Else
If _Resize And FontResize = 0 Then
j = _ResizeWidth \ _FontWidth: k = _ResizeHeight \ _FontHeight
If j >= t.ScrnResizeMinW And j <> _Width Or k >= t.ScrnResizeMinH And k <> _Height Then t.ScrnResize = 1: Exit Do
End If
End Select
End If
If initiate = 0 Or t.ScrnResize = 2 Then
Width w, h
If initiate = 0 Then
_Font 16
Else
Font_Size t, pop
End If
t.fw = _FontWidth: t.fh = _FontHeight: t.mr = _Width
Palette c.InputFrg2, c.pal2: Palette c.SkinBkg, c.pal3: Palette c.PopupShadowBkg, c.pal4
Color , c.PageColor: Cls
initiate = 1: MapIDMenu = 0: MapIDLink = 0
Hardware_Images t, pop
End If
Exit Do
Loop
Locate y, x
End Sub
Sub FreeCopy (gbl As GlobalVar, SCopy())
Static fcopy$
Dim i As _Byte
Select Case gbl.anum
Case Is > 0
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$(SCopy(Abs(gbl.anum)))
Case Is < 0
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, SCopy(Abs(gbl.anum)), gbl.MyScreen: Cls: Screen gbl.MyScreen, 0, gbl.MyScreen, gbl.MyScreen ' Clear pcopy memory.
Rem _Title "Pcopy Home" + Str$(SCopy(Abs(gbl.anum))) + " to" + Str$(gbl.MyScreen)
End Select
End Sub
Sub PgMu (t As TextVar, c As ColorVar, ins$)
Static initiate
y = CsrLin: x = Pos(0)
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If initiate = 0 Then
initiate = 1
ReDim _Preserve PageMap$(222)
End If
MapIDMenu = MapIDMenu + 1
Restore PageMenuData
For i = 1 To MapIDMenu
Do
Read tmp$
If tmp$ = "eom" Then Exit For
If tmp$ = "eof" Then If cnt + 1 = MapIDMenu Then Exit For Else cnt = cnt + 1: k = 0: _Continue
If cnt + 1 = MapIDMenu And k < Len(tmp$) Then k = Len(tmp$)
Loop
Next
If MapIDMenu = 111 Then ' Hard Limit
_MessageBox "Configuration Error", "The maximun number of PageMap arrays (111) 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$(MapIDMenu + 33)))
If InStr(t.HWPgMuTracker, Chr$(y + 32)) = 0 Then t.HWPgMuTracker = t.HWPgMuTracker + Chr$(y + 32)
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
Color c.ILF, c.ILB
Locate y, x: Print ins$;: Locate y, x
Color restore_color1, restore_color2
End Sub
Sub Link (t As TextVar, c As ColorVar)
y = CsrLin: x = Pos(0)
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
MapIDLink = MapIDLink + 1
Restore PageHyperLinks: i = 0
Do
i = i + 1
Read a$, tmp$, tmp$
Loop Until i = MapIDLink
k = Len(a$)
If MapIDLink = 111 Then ' Hard Limit
_MessageBox "Configuration Error", "The maximun number of hyperlink arrays (111) has been reached.", "error"
System
End If
If LTrim$(PageMap$(CsrLin)) = "" Then PageMap$(CsrLin) = Space$(_Width)
Mid$(PageMap$(y), x, k) = String$(k, Asc(Chr$(MapIDLink + 144)))
If InStr(t.HWPgMuTracker, Chr$(y + 143)) = 0 Then t.HWPgMuTracker = t.HWPgMuTracker + Chr$(y + 143)
Color c.HyperFrg, c.HyperBkg: Print a$;
Color restore_color1, restore_color2
End Sub
Sub Follow_Links (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
If Asc(x$) > 110 Then
' Hyperlink
Else
pop.MenuModel = 5: pop.Show = Asc(x$) - 33
pop.PageMenuy = m.y
pop.PageMenux = InStr(PageMap$(m.y), x$)
End If
End If
End If
End Sub
Sub HW_Display (t As TextVar, pop As PopupVar)
Static InFldL, InFldR
If t.PopupHardwareAceleration = 0 Then Exit Sub '========================>
If pop.MenuModel = 5 And pop.MenuL Then ' Note: MenuL indicates the cycle is past the point of te menu opening.
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 (dx1, dy1), t.PageMenuHWFront, , (sx1, sy1)-(sx2, sy2)
_PutImage ((pop.MenuL + pop.mwidth) * t.fw, (pop.MenuT - 1) * t.fh), t.PageMenuHWBack, , (0, 0)-((pop.mwidth - 1) * t.fw, pop.mheight * t.fh)
End If
h = 0
Do
seed = 0: h = h + 1: x$ = Mid$(t.HWPgMuTracker, h, 1): If Len(x$) Then i = Asc(x$) - 32 Else Exit Do
If i > 111 Then i = i - 111: mylink = 1 Else mylink = 0
Do
cRow = i: k1 = 1
tmp$ = Mid$(PageMap$(i), seed): x$ = Left$(LTrim$(tmp$), 1)
InFldL = InStr(PageMap$(i), x$): If mylink = 0 Then InFldL = InFldL - 2
InFldR = _InStrRev(PageMap$(i), x$)
seed = InFldR + 1
If pop.Show Then
If cRow >= pop.MenuT And cRow < pop.MenuB And InFldR >= pop.MenuL And InFldL <= pop.MenuR Then
MenuOverlap = _TRUE
Else
MenuOverlap = _FALSE
End If
End If
If mylink Then
If Not MenuOverlap Then
_PutImage ((InFldL - 1) * t.fw, cRow * t.fh - 2), t.HLnk, , (0, 0)-((InFldR - InFldL + 1) * t.fw, 0)
Else
dy1 = cRow * t.fh - 2: sy1 = 0: sy2 = 0
sx1 = (pop.MenuR - (InFldL - 1)) * t.fw
If pop.MenuModel = 5 Then
dx1 = pop.MenuR * t.fw: k1 = 0
sx2 = (InFldR - InFldL + 1) * t.fw
Else
dx1 = (pop.MenuR - 1) * t.fw - p1: k1 = t.fw / 2
sx2 = (InFldR - InFldL + 2) * t.fw + p1
End If
If InFldL < pop.MenuL Then _PutImage ((InFldL - 1) * t.fw, cRow * t.fh - 2), t.HLnk, , (0, 0)-((pop.MenuL - InFldL) * t.fw + k1, 0)
If pop.MenuR - 1 <= InFldR Then
_PutImage (dx1, dy1), t.HLnk, , (sx1, sy1)-(sx2, sy2)
End If
End If
Else
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 Not MenuOverlap Then
_PutImage (InFldL * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((InFldR - InFldL) * t.fw, t.fh)
_PutImage (InFldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
_PutImage ((InFldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
Else
dy1 = (cRow - 1) * t.fh: sy1 = 0: sy2 = t.fh
sx1 = (pop.MenuR - (InFldL - 1)) * t.fw
If pop.MenuModel = 5 Then
dx1 = pop.MenuR * t.fw: k1 = 0
sx2 = (InFldR - InFldL + 1) * t.fw
Else
dx1 = (pop.MenuR - 1) * t.fw - p1
sx2 = (InFldR - InFldL + 2) * t.fw + p1
End If
If InFldL < pop.MenuL Then _PutImage (InFldL * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((pop.MenuL - InFldL - 1) * t.fw + p1 * k1, t.fh)
If pop.MenuR - 1 <= InFldR Then
_PutImage (dx1, dy1), t.hwFieldFront, , (sx1, sy1)-(sx2, sy2)
_PutImage (InFldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
If pop.MenuR - 1 < InFldR Then _PutImage ((InFldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
End If
End If
End If
Loop Until LTrim$(Mid$(PageMap$(i), seed)) = ""
Loop
End Sub
Sub Font_Size (t As TextVar, pop As PopupVar)
Static CurrentFont&
If t.MyFont = "Default" Or t.MyFont = "" Then
_Font 16: t.MyFont = "Default"
If CurrentFont& Then _FreeFont CurrentFont&
CurrentFont& = 0: t.FSize = 0
Else
f& = _LoadFont(Environ$("SYSTEMROOT") + "\Fonts\" + t.WinFont, t.FSize, "monospace")
_Font f&
If CurrentFont& Then _FreeFont CurrentFont&
CurrentFont& = f&
End If
t.fw = _FontWidth: t.fh = _FontHeight
Hardware_Images t, pop
End Sub
Sub Hardware_Images (t As TextVar, pop As PopupVar)
If t.tri Then
_FreeImage t.tri
_FreeImage t.hwFieldFront
_FreeImage t.hwFieldBack
_FreeImage t.HLnk
_FreeImage t.PageMenuHWFront
_FreeImage t.PageMenuHWBack
End If
t1 = _NewImage(16, 16, 32)
_Dest t1
a1 = 6: c1 = 0: w = a1 * 2: h = a ' Draw a triangle.
For i = 0 To 6
Line (a1, c1)-(a1 + i * 2, c1), _RGB32(255, 255, 255, 150)
a1 = a1 - 1: c1 = c1 + 1
Next
t.tri = _CopyImage(t1, 33)
_Dest 0
_FreeImage t1
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)
_Dest 0
_FreeImage t1
t1 = _NewImage(1200, 1, 32)
_Dest t1
Line (0, 0)-(1200, 0), _RGB32(0, 144, 211)
t.HLnk = _CopyImage(t1, 33)
_Dest 0
_FreeImage t1
j = _Width
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 Sub
Pete
Posts: 2,910
Threads: 305
Joined: Apr 2022
Reputation:
167
The menus, links, etc. are all working well. I like the code but do not like how the responses got jumbled up. I separated those into a separate sub called "decision" and when I get some more time, I'm going to optimize it in a way that works in an orderly fashion with the rest of the menu system. There are more actions I want to include, so the sooner I get this part of the routine in shape, the better.
Code: (Select All)
$Resize:On
_ScreenMove 200, 10
ReDim Shared PageMap$(0), MapIDMenu, MapIDLink
Type GlobalVar
anum As _Byte
MyScreen As _Byte
UcaseKeys As String
LcaseKeys As String
CtrlKeys As String
AltKeys As String
End Type
Dim gbl As GlobalVar
Type TextVar
FormStyle As _Byte
InptMthd As _Byte ' 2 is for creating an input field when csrlin is activated by mouse or keyboard.
mt As _Byte
mr As _Byte
mb As _Byte
ml As _Byte
bsTop As _Byte
bsRight As _Byte
bsBottom As _Byte
bsLeft As _Byte
noe As _Byte
nol As _Byte
scr As _Byte
oldscr As _Byte
wide As _Byte
tall As _Byte
fw As _Byte
fh As _Byte
redisplay As _Byte
hl As _Byte
HlFind As _Byte
ScreenEstablished As _Byte
ScrnW As _Byte
ScrnH As _Byte
ScrnRefresh As _Byte
ScrnResize As _Byte
ScrnResizeMinW As _Byte
ScrnResizeMinH As _Byte
ScrnResizeInputRow As _Byte
ScrnResizeInputCol As _Byte
RollupEvent As _Byte
RollupStatus As _Byte
HoldScr As _Byte
persistency As _Byte ' 1 or 0
UseDefaultDisplay As _Byte ' 1 or 0
InputActive As _Byte ' Records cursor row.
redo As _Byte
undo As _Byte
RedoText As String
UndoText As String
MarkerOn As _Byte
marker As _Byte
EncodeOn As _Byte
remakeIDX As _Byte
hideshow As String
AddDelete As _Byte ' 1 Add, -1 Delete, or 0 inactive.
OpenInput As _Byte ' 1 Open input line pase colon or 2 Open entire input line.
hgltPos1 As _Byte
hwUnderlineShow As _Byte
hwUnderlineImage As Long
HWPgMuTracker As String ' Records cursor row.
hwFieldPresent As _Byte
hwFieldFront As Long
hwFieldBack As Long
HardwareAcceleration As _Byte
PageMenuHWFront As Long
PageMenuHWBack As Long
tri As Long
HLnk As Long
WinFont As String
MyFont As String
NewFont As _Byte
FSize As _Byte
End Type
Dim t As TextVar
Type InputVar
CurStyle As _Byte
CurShow As _Byte
fld As _Byte
mtop As _Byte
mleft As _Byte
myclose As _Byte
mxclose As _Byte
End Type
Dim in As InputVar
Type PopupVar
ForceInitiate As _Byte
Show As _Byte ' Number of window to show.
CloseReOpen As _Byte ' Number of window to show after previous window gets closed.
hwWindow As Long
mwidth As _Byte
mheight As _Byte
FixMenuT As _Byte
FixMenuL As _Byte
MenuT As _Byte
MenuB As _Byte
MenuL As _Byte
MenuR As _Byte
MenuHL As _Byte
MarginRt As _Byte
BoundsLt As _Byte
BoundsRt As _Byte
Shadow As _Byte ' 0 or 1.
VSpacing As _Byte
Choice As _Byte
ChoiceName As String
PageMenuy As _Byte
PageMenux As _Byte
MenuBar As String
MenuBarLt As String
MenuBarRt As String
MenuBarRow As _Byte
MenuModel As _Byte
PMImageHeight As _Byte
ID As String
SuckerFish As _Byte
End Type
Dim pop As PopupVar
Type MouseVar
x As _Byte
y As _Byte
lb As _Byte
rb As _Byte
mb As _Byte
mw As _Byte
clkcnt As _Byte
caps As _Byte
shift As _Byte
ctrl As _Byte
alt As _Byte
AltSwitch As _Byte
prevx As _Byte
prevy As _Byte
drag As _Byte
sbar As _Byte
sbRow As _Byte
oldsbRow As _Byte
ThumbTop As _Byte
ThumbSize As _Byte
ThumbDrag As _Byte
autokey As String
Pointer As _Byte
End Type
Dim m As MouseVar
Type ColorVar
pal1 As _Byte
pal2 As _Byte
pal3 As _Byte
pal4 As _Byte
PageColor As _Byte
SkinFrg As _Byte
SkinBkg As _Byte
InputFrg As _Byte
InputFrg2 As _Byte
InputBkg As _Byte
InputHl As _Byte
InputH2 As _Byte
SkinShadowFrg As _Byte
SkinShadowBkg As _Byte
PopupFrg As _Byte
PopupBkg As _Byte
PopupUnavail As _Byte
PopupShadowFrg As _Byte
PopupShadowBkg As _Byte
PopupMenuBarFrg As _Byte
PopupMenuBarBkg As _Byte
FixedMenuFrg As _Byte
FixedMenuBkg As _Byte
FixedMenuHlFrg As _Byte
FixedMenuHlBkg As _Byte
FixedMenuScFrg As _Byte
PageMenuFrg As _Byte
PageFrg As _Byte
PageBkg As _Byte
ILF As _Byte
ILB As _Byte
PageMenuBkg As _Byte
PageMenuHlFrg As _Byte
PageMenuHlBkg As _Byte
PageMenuBdr As _Byte
HyperFrg As _Byte
HyperBkg As _Byte
End Type
Dim c As ColorVar
User_Defined_Variables gbl, t, pop, c
ReDim text$(1)
Do
_Limit 60
ScrnActions t, pop, m, c, b$
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()
Follow_Links pop, m
HW_Display 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.WinFont = "lucon.ttf"
t.HardwareAcceleration = 1 ' Hardware Acceleration On.
t.ml = 1: t.mr = _Width: t.mt = 1: t.mb = _Height
t.ScrnW = 90
t.ScrnH = 42
t.ScrnResizeMinW = 84
t.ScrnResizeMinH = 42
pop.MenuBarRow = 1
pop.MenuBarLt = " File Edit View Search"
pop.MenuBarRt = "Help "
pop.FixMenuT = 21
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.HyperFrg = 11
c.HyperBkg = 1
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
PageClickData:
Data "Press F1 for a Single-Spaced No Lines Popup Menu"
Data "Press F2 for a Double-Spaced No Lines Popup Menu"
Data "Press F3 for a Single-Spaced Lined Popup Menu"
Data "Press F4 for a Double-Spaced Lined Popup Menu"
Data "Press F5 for a Single-Spaced No Lines Hardware Popup Menu"
Data "Press F6 for a Double-Spaced No Lines Hardware Popup Menu"
Data "Press F7 for a Single-Spaced Lined Hardware Popup Menu"
Data "Press F8 for a Double-Spaced Lined Hardware Popup Menu"
Data eof
Data eom
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
PageHyperLinks:
Data QB64Phoenix.com,"https://qb64phoenix.com/forum/showthread.php?tid=4256",1
Data This is a message box test,"The link you clicked generated+chr$(13)+chr$(10)+This message box popup.",2
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() ' Note: Only close the suckerfish. The parent menu is colsed in the popup sub.
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$()
y = CsrLin: x = Pos(0): restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If pop.MenuModel = 5 Then
If initiate = 0 Then
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 For
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.MenuT = m.y + 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.HardwareAcceleration 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 Or t.NewFont = -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.HardwareAcceleration 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
If SFhwWindow& Then _FreeImage SFhwWindow&: SFhwWindow& = 0
ReDim SFParentMenu$(0), SFParentSc$(0), SFParentID$(0), SFMenuRestrict(0)
Erase SFParentMenu$, SFParentSc$, SFParentID$, SFMenuRestrict
End If
If pop.Show Then
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
in.CurShow = 0: Locate , , in.CurShow ' Hide cursor
nomi = 0: oldmy = 0: oldmx = 0: myalt = 0: pop.MenuHL = 0
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.HardwareAcceleration 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
If pop.SuckerFish Then
SFhwWindow& = _CopyImage(t1, 33)
Swap pop.hwWindow, SFhwWindow&
Else
If pop.hwWindow Then _FreeImage pop.hwWindow
pop.hwWindow = _CopyImage(t1, 33)
End If
_Dest 0
_FreeImage t1
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.HardwareAcceleration = 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 Or t.NewFont = -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
Swap pop.hwWindow, SFhwWindow&
_FreeImage SFhwWindow&: SFhwWindow& = 0
gbl.anum = -2: FreeCopy gbl, SCopy()
oldmy = -1: oldmx = -1 ' Allows highlighting to follow mouse when suckerfish menu closes.
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
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.HardwareAcceleration 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
If SFhwWindow& Then _FreeImage SFhwWindow&: SFhwWindow& = 0
If pop.hwWindow Then _FreeImage pop.hwWindow: pop.hwWindow = 0
pop.MenuModel = -pop.MenuModel
pop.SuckerFish = 0: SFParentT = 0: SFParentR = 0: SFParentB = 0: SFParentL = 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
If initiate = 0 Or t.ScrnResize = 2 Or t.ScrnRefresh Then
If t.ScrnRefresh Then
t.ScrnRefresh = 0: MapIDMenu = 0: MapIDLink = 0
Color , c.PageColor: View Print 2 To _Height: Cls: View Print
Else
If initiate = 0 Then pop.VSpacing = 2: MChoice = 8: ResizeControl = 1: rating = 1
initiate = 1
ReDim text$(1): in.fld = 1: text$(in.fld) = "Test!"
End If
Color c.PageFrg, c.PageBkg
Restore PageClickData: Locate 3
Do: Read a$: If a$ = "eof" Then Exit Do
Locate , 2: Print a$
Loop
Locate CsrLin + 1, 2
a$ = "Current Menu Type: ": Print a$;: j = MChoice: GoSub getdata: PgMu t, c, a$
Locate CsrLin + 3, 2
a$ = "Screen Resizing: ": Print a$;: j = ResizeControl: GoSub getdata: PgMu t, c, a$
Locate , Pos(0) + 10
a$ = "Rate Pete's Demo as: ": Print a$;: j = rating: GoSub getdata: PgMu t, c, a$
a$ = "Visit this project: ": Locate CsrLin + 3, 2: Print a$;: Link t, c
Locate , Pos(0) + 10
a$ = "Message: ": Print a$;: Link t, c
Locate CsrLin + 2, 1
Color 1, 3: For i = 1 To 20: Print String$(_Width, Chr$(177)): Next
End If
decision pop, m, c, b$
Exit Sub '===============================>
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 ScrnActions (t As TextVar, pop As PopupVar, m As MouseVar, c As ColorVar, b$)
Static initiate, oldMPointer, FontResize As _Bit
y = CsrLin: x = Pos(0)
If t.NewFont Then t.NewFont = 0: Font_Size t, pop
If m.alt Then
Select Case b$
Case Chr$(0) + Chr$(14)
If Len(t.MyFont) And t.MyFont <> "Default" Then
t.MyFont = "Default": t.NewFont = -1: FontResize = -1: Exit Sub
End If
Case Chr$(0) + Chr$(130), Chr$(0) + Chr$(131)
If t.FSize = 0 Then t.FSize = 15
Select Case b$
Case Chr$(0) + Chr$(131): If t.FSize < 31 Then j = 1 Else j = 0
Case Chr$(0) + Chr$(130): If t.FSize > 8 Then j = -1 Else j = 0
End Select
If j Then t.FSize = t.FSize + j: t.MyFont = t.WinFont: t.NewFont = -1: FontResize = -1: Exit Sub
Case Else
If Len(b$) Then FontResize = 0
End Select
Else
FontResize = 0
End If
x$ = ""
If InStr(PageMap$(m.y), " ") Then
If InStr(Mid$(PageMap$(m.y), m.x, 1), " ") = 0 Then x$ = Mid$(PageMap$(m.y), m.x, 1)
End If
If Len(x$) Then
If Asc(x$) - 32 > 111 Then m.Pointer = -1 Else m.Pointer = 1
Else
m.Pointer = 0
End If
If m.Pointer <> oldMPointer Then If m.Pointer = -1 Then _MouseShow "Link" Else _MouseShow "Default"
oldMPointer = m.Pointer
Do
If initiate = 0 Then
_Resize On: w = t.ScrnW: h = t.ScrnH
ElseIf t.ScrnResize = 1 Then t.ScrnResize = 2
ElseIf t.ScrnResize = 2 Then t.ScrnResize = 0: Exit Do ' Resize cycle complete.
End If
If initiate Then
Select Case t.ScrnResize
Case 2
i = _ResizeWidth \ t.fw: j = _ResizeHeight \ t.fh: k = 0
If i < x Or i < t.ScrnResizeMinW Or i = _Width Then k = k + 1: w = _Width Else w = i
If j < y Or j < t.ScrnResizeMinH Or j = _Height Then k = k + 1: h = _Height Else h = j
If k = 2 Then t.ScrnResize = 0: Exit Do ' Resize cycle force complete.
Case Else
If _Resize And FontResize = 0 Then
j = _ResizeWidth \ _FontWidth: k = _ResizeHeight \ _FontHeight
If j >= t.ScrnResizeMinW And j <> _Width Or k >= t.ScrnResizeMinH And k <> _Height Then t.ScrnResize = 1: Exit Do
End If
End Select
End If
If initiate = 0 Or t.ScrnResize = 2 Then
Width w, h
If initiate = 0 Then
_Font 16
Else
Font_Size t, pop
End If
t.fw = _FontWidth: t.fh = _FontHeight: t.mr = _Width
Palette c.InputFrg2, c.pal2: Palette c.SkinBkg, c.pal3: Palette c.PopupShadowBkg, c.pal4
Color , c.PageColor: Cls
initiate = 1: MapIDMenu = 0: MapIDLink = 0
Hardware_Images t, pop
End If
Exit Do
Loop
Locate y, x
End Sub
Sub FreeCopy (gbl As GlobalVar, SCopy())
Static fcopy$
Dim i As _Byte
Select Case gbl.anum
Case Is > 0
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$(SCopy(Abs(gbl.anum)))
Case Is < 0
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, SCopy(Abs(gbl.anum)), gbl.MyScreen: Cls: Screen gbl.MyScreen, 0, gbl.MyScreen, gbl.MyScreen ' Clear pcopy memory.
Rem _Title "Pcopy Home" + Str$(SCopy(Abs(gbl.anum))) + " to" + Str$(gbl.MyScreen)
End Select
End Sub
Sub PgMu (t As TextVar, c As ColorVar, ins$)
Static initiate
y = CsrLin: x = Pos(0)
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If initiate = 0 Then
initiate = 1
ReDim _Preserve PageMap$(222)
End If
MapIDMenu = MapIDMenu + 1
Restore PageMenuData
For i = 1 To MapIDMenu
Do
Read tmp$
If tmp$ = "eom" Then Exit For
If tmp$ = "eof" Then If cnt + 1 = MapIDMenu Then Exit For Else cnt = cnt + 1: k = 0: _Continue
If cnt + 1 = MapIDMenu And k < Len(tmp$) Then k = Len(tmp$)
Loop
Next
If MapIDMenu = 111 Then ' Hard Limit
_MessageBox "Configuration Error", "The maximun number of PageMap arrays (111) 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$(MapIDMenu + 33)))
If InStr(t.HWPgMuTracker, Chr$(y + 32)) = 0 Then t.HWPgMuTracker = t.HWPgMuTracker + Chr$(y + 32)
If t.HardwareAcceleration = 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
Color c.ILF, c.ILB
Locate y, x: Print ins$;: Locate y, x
Color restore_color1, restore_color2
End Sub
Sub Link (t As TextVar, c As ColorVar)
y = CsrLin: x = Pos(0)
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
MapIDLink = MapIDLink + 1
Restore PageHyperLinks: i = 0
Do
i = i + 1
Read a$, tmp$, tmp$
Loop Until i = MapIDLink
k = Len(a$)
If MapIDLink = 111 Then ' Hard Limit
_MessageBox "Configuration Error", "The maximun number of hyperlink arrays (111) has been reached.", "error"
System
End If
If LTrim$(PageMap$(CsrLin)) = "" Then PageMap$(CsrLin) = Space$(_Width)
Mid$(PageMap$(y), x, k) = String$(k, Asc(Chr$(MapIDLink + 144)))
If InStr(t.HWPgMuTracker, Chr$(y + 143)) = 0 Then t.HWPgMuTracker = t.HWPgMuTracker + Chr$(y + 143)
Color c.HyperFrg, c.HyperBkg: Print a$;
Color restore_color1, restore_color2
End Sub
Sub Follow_Links (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
If Asc(x$) > 110 Then
' Hyperlink
Else
pop.MenuModel = 5: pop.Show = Asc(x$) - 33
pop.PageMenuy = m.y
pop.PageMenux = InStr(PageMap$(m.y), x$)
End If
End If
End If
End Sub
Sub HW_Display (t As TextVar, pop As PopupVar)
Static InFldL, InFldR
If t.HardwareAcceleration = 0 Then Exit Sub '========================>
If pop.MenuModel = 5 And pop.MenuL Then ' Note: MenuL indicates the cycle is past the point of te menu opening.
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 (dx1, dy1), t.PageMenuHWFront, , (sx1, sy1)-(sx2, sy2)
_PutImage ((pop.MenuL + pop.mwidth) * t.fw, (pop.MenuT - 1) * t.fh), t.PageMenuHWBack, , (0, 0)-((pop.mwidth - 1) * t.fw, pop.mheight * t.fh)
End If
h = 0
Do
seed = 0: h = h + 1: x$ = Mid$(t.HWPgMuTracker, h, 1): If Len(x$) Then i = Asc(x$) - 32 Else Exit Do
If i > 111 Then i = i - 111: mylink = 1 Else mylink = 0
Do
cRow = i: k1 = 1
tmp$ = Mid$(PageMap$(i), seed): x$ = Left$(LTrim$(tmp$), 1)
InFldL = InStr(PageMap$(i), x$): If mylink = 0 Then InFldL = InFldL - 2
InFldR = _InStrRev(PageMap$(i), x$)
seed = InFldR + 1
If pop.Show Then
If cRow >= pop.MenuT And cRow < pop.MenuB And InFldR >= pop.MenuL And InFldL <= pop.MenuR Then
MenuOverlap = _TRUE
Else
MenuOverlap = _FALSE
End If
End If
If mylink Then
If Not MenuOverlap Then
_PutImage ((InFldL - 1) * t.fw, cRow * t.fh - 2), t.HLnk, , (0, 0)-((InFldR - InFldL + 1) * t.fw, 0)
Else
dy1 = cRow * t.fh - 2: sy1 = 0: sy2 = 0
sx1 = (pop.MenuR - (InFldL - 1)) * t.fw
If pop.MenuModel = 5 Then
dx1 = pop.MenuR * t.fw: k1 = 0
sx2 = (InFldR - InFldL + 1) * t.fw
Else
dx1 = (pop.MenuR - 1) * t.fw - p1: k1 = t.fw / 2
sx2 = (InFldR - InFldL + 2) * t.fw + p1
End If
If InFldL < pop.MenuL Then _PutImage ((InFldL - 1) * t.fw, cRow * t.fh - 2), t.HLnk, , (0, 0)-((pop.MenuL - InFldL) * t.fw + k1, 0)
If pop.MenuR - 1 <= InFldR Then
_PutImage (dx1, dy1), t.HLnk, , (sx1, sy1)-(sx2, sy2)
End If
End If
Else
If t.HardwareAcceleration 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 Not MenuOverlap Then
_PutImage (InFldL * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((InFldR - InFldL) * t.fw, t.fh)
_PutImage (InFldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
_PutImage ((InFldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
Else
dy1 = (cRow - 1) * t.fh: sy1 = 0: sy2 = t.fh
sx1 = (pop.MenuR - (InFldL - 1)) * t.fw
If pop.MenuModel = 5 Then
dx1 = pop.MenuR * t.fw: k1 = 0
sx2 = (InFldR - InFldL + 1) * t.fw
Else
dx1 = (pop.MenuR - 1) * t.fw - p1
sx2 = (InFldR - InFldL + 2) * t.fw + p1
End If
If InFldL < pop.MenuL Then _PutImage (InFldL * t.fw, (cRow - 1) * t.fh), t.hwFieldFront, , (0, 0)-((pop.MenuL - InFldL - 1) * t.fw + p1 * k1, t.fh)
If pop.MenuR - 1 <= InFldR Then
_PutImage (dx1, dy1), t.hwFieldFront, , (sx1, sy1)-(sx2, sy2)
_PutImage (InFldR * t.fw, (cRow - 1) * t.fh), t.hwFieldBack
If pop.MenuR - 1 < InFldR Then _PutImage ((InFldR - 1.75) * t.fw, (cRow - .7) * t.fh), t.tri, , (0, 6)-(12, 0)
End If
End If
End If
Loop Until LTrim$(Mid$(PageMap$(i), seed)) = ""
Loop
End Sub
Sub Font_Size (t As TextVar, pop As PopupVar)
Static CurrentFont&
If t.MyFont = "Default" Or t.MyFont = "" Then
_Font 16: t.MyFont = "Default"
If CurrentFont& Then _FreeFont CurrentFont&
CurrentFont& = 0: t.FSize = 0
Else
f& = _LoadFont(Environ$("SYSTEMROOT") + "\Fonts\" + t.WinFont, t.FSize, "monospace")
_Font f&
If CurrentFont& Then _FreeFont CurrentFont&
CurrentFont& = f&
End If
t.fw = _FontWidth: t.fh = _FontHeight
Hardware_Images t, pop
End Sub
Sub Hardware_Images (t As TextVar, pop As PopupVar)
If t.tri Then
_FreeImage t.tri
_FreeImage t.hwFieldFront
_FreeImage t.hwFieldBack
_FreeImage t.HLnk
_FreeImage t.PageMenuHWFront
_FreeImage t.PageMenuHWBack
End If
t1 = _NewImage(16, 16, 32)
_Dest t1
a1 = 6: c1 = 0: w = a1 * 2: h = a ' Draw a triangle.
For i = 0 To 6
Line (a1, c1)-(a1 + i * 2, c1), _RGB32(255, 255, 255, 150)
a1 = a1 - 1: c1 = c1 + 1
Next
t.tri = _CopyImage(t1, 33)
_Dest 0
_FreeImage t1
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)
_Dest 0
_FreeImage t1
t1 = _NewImage(1200, 1, 32)
_Dest t1
Line (0, 0)-(1200, 0), _RGB32(0, 144, 211)
t.HLnk = _CopyImage(t1, 33)
_Dest 0
_FreeImage t1
j = _Width
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 Sub
Sub decision (pop As PopupVar, m As MouseVar, c As ColorVar, b$)
Static initiate, seen, getmenu, MChoice, ResizeControl, rating
If initiate = 0 Then
initiate = 1
pop.VSpacing = 2: MChoice = 8: ResizeControl = 1: rating = 1
If t.ScrnResize = 0 Then getmenu = 1
End If
If m.Pointer = -1 And m.lb = 2 And pop.Show = 0 Then
Restore PageHyperLinks: i = 0
x$ = Mid$(PageMap$(m.y), m.x, 1)
Do
i = i + 1
Read a$, mylink$, j
Loop Until i = Asc(x$) - 144
If j = 1 Then Shell _DontWait mylink$
If j = 2 Then
If InStr(LCase$(mylink$), "chr$(13)") Then
a$ = "": x$ = mylink$
Do
a$ = a$ + Mid$(x$, 1, InStr(LCase$(x$), "+") - 1) + Chr$(13) + Chr$(10)
x$ = Mid$(mylink$, InStr(LCase$(mylink$), "chr$(10)") + 9)
Loop Until InStr(LCase$(x$), "chr$(13)") = 0
mylink$ = a$ + x$: a$ = "": x$ = ""
End If
_MessageBox "User Message", mylink$, "info"
End If
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: ResizeControl = pop.Choice
Case 3: rating = 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.HardwareAcceleration = 0: pop.VSpacing = -1: MChoice = 1: t.ScrnRefresh = -1
Case Chr$(0) + Chr$(60): t.HardwareAcceleration = 0: pop.VSpacing = -2: MChoice = 2: t.ScrnRefresh = -1
Case Chr$(0) + Chr$(61): t.HardwareAcceleration = 0: pop.VSpacing = 1: MChoice = 3: t.ScrnRefresh = -1
Case Chr$(0) + Chr$(62): t.HardwareAcceleration = 0: pop.VSpacing = 2: MChoice = 4: t.ScrnRefresh = -1
Case Chr$(0) + Chr$(63): t.HardwareAcceleration = 1: pop.VSpacing = -1: MChoice = 5: t.ScrnRefresh = -1
Case Chr$(0) + Chr$(64): t.HardwareAcceleration = 1: pop.VSpacing = -2: MChoice = 6: t.ScrnRefresh = -1
Case Chr$(0) + Chr$(65): t.HardwareAcceleration = 1: pop.VSpacing = 1: MChoice = 7: t.ScrnRefresh = -1
Case Chr$(0) + Chr$(66): t.HardwareAcceleration = 1: pop.VSpacing = 2: MChoice = 8: t.ScrnRefresh = -1
Case Else: getmenu = 0
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 Clear Search 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 ResizeControl = 1 Then _Resize On Else _Resize Off
End Sub
Pete
|
