1
1
Fork 0
mirror of https://github.com/FellippeHeitor/InForm.git synced 2024-05-12 06:50:12 +00:00

Compare commits

...

71 commits

Author SHA1 Message Date
Samuel Gomes fa00fa0f9b Update GIFPlayer to use new 3.10 CLS syntax 2024-01-11 19:18:38 +05:30
Samuel Gomes 33f896aaaa Cleanup INI library a bit 2024-01-11 19:01:18 +05:30
Samuel Gomes 022fd0a97f Add VERSIONINFO strings to UiEditor 2024-01-11 07:47:20 +05:30
Samuel Gomes 6f5546221d Integrate MessageBox and friends back into the main source 2024-01-11 07:20:24 +05:30
Samuel Gomes 07a2b55433 Reduce number of $INCLUDEs needed in user code 2024-01-11 05:36:34 +05:30
Samuel Gomes 0918df0d11 Major refactoring 2024-01-11 04:51:14 +05:30
Samuel Gomes 4e6a167f15 Add wiki as git submodule 2024-01-10 05:29:38 +05:30
Samuel Gomes c23c1e85d1 Move docs to top-level and add wiki as git submodule 2024-01-10 05:29:03 +05:30
Samuel Gomes 1b7ccb6891 Use Base64 library wherever Pack() & Unpack() were used 2024-01-10 04:47:01 +05:30
Samuel Gomes 79d319ee77 Move theme image data to use QB64-PE memory image load functionality 2024-01-09 15:26:26 +05:30
Samuel Gomes 347b7e07fe Remove remaining dead update code 2024-01-09 04:05:12 +05:30
Samuel Gomes a76449ad62 Update TextFetch example to use QB64-PE v3.11.0 features 2024-01-05 09:41:10 +05:30
Samuel Gomes b62e99935b Add GIF_GetElapsedTime & GIF_GetBackgroundColor 2023-12-02 21:42:38 +05:30
Samuel Gomes af6eb0957d Clear final render surface with correct 32-bit RGBA background color 2023-12-01 04:41:35 +05:30
Samuel Gomes db355486c1 Update GIFPlayer to not throw errors when bad Ids are passed 2023-12-01 03:12:40 +05:30
Samuel Gomes 08121bfb4f Update GIF_IsLoaded() to return true only when the GIF is fully loaded 2023-11-30 10:31:22 +05:30
Samuel Gomes 9e7b10b283 Fix decoder to work correctly with rotating-earth.gif 2023-11-30 04:58:41 +05:30
Samuel Gomes e02474e09f Clear surface before drawing final GIF frame 2023-11-29 23:43:14 +05:30
Samuel Gomes 85fec0c0fc Fix infinite loop issue when duration is zero 2023-11-29 23:34:27 +05:30
Samuel Gomes 80c99f5e90 Minor changes 2023-11-29 21:13:03 +05:30
Samuel Gomes 6ecde5b106 Improve compatibility with InForm-PE TIMERS 2023-11-29 12:08:44 +05:30
Samuel Gomes 006980987f Update GIFPlay 2023-11-29 11:54:06 +05:30
Samuel Gomes 338232bab2 Implement LZW decoder 2023-11-23 09:17:14 +05:30
Samuel Gomes 47f51909a8 Major refactoring. New GIFPlayer inbound 2023-11-22 05:17:06 +05:30
Samuel Gomes 3867088da3 GIFPlay cleanup 1 2023-11-20 12:16:45 +05:30
Samuel Gomes ce2d98fb3e Fix typos 2023-11-20 08:51:59 +05:30
Samuel Gomes b5bb8a6f5c Cleanup GIFPlay API and update documentation 2023-11-20 08:48:12 +05:30
Samuel Gomes e576210b9e More GIFPlay refactoring 2023-11-19 15:22:28 +05:30
Samuel Gomes 2de157987d LoadOverlayImage is now simpler and faster 2023-11-19 14:40:52 +05:30
Samuel Gomes 3cfec04cce Fix file name case 2023-11-19 10:23:36 +05:30
Samuel Gomes 1ad363bec8 Remove dir to fix file name case 2023-11-19 10:22:47 +05:30
Samuel Gomes 28d9a5b56b Refactor GIFPlay and add ThemePreview example 2023-11-19 10:19:21 +05:30
a740g ed6305b10c Improve .gitignore for macOS 2023-10-16 06:30:03 +05:30
Samuel Gomes a7df4058e0 Fix TextFetch example 2023-07-22 04:23:35 +05:30
Samuel Gomes 2bbd574a22 Update README.md 2023-06-30 01:19:08 +05:30
Samuel Gomes c34e514e18 Fix QB64-PE GitHub link 2023-06-24 08:20:13 +05:30
Samuel Gomes 0039fd6ade Update README.md 2023-06-24 08:17:41 +05:30
Samuel Gomes 6fe16f957c Add many examples. Add legacy MessageBox extension 2023-06-24 08:08:56 +05:30
Samuel Gomes e2ee59af0f Update UiEditor to remember QB64-PE compiler path 2023-06-21 15:03:23 +05:30
Samuel Gomes 4052343623 Add several InFrom example apps 2023-06-16 03:28:12 +05:30
Samuel Gomes a4166a9091 Update README.md 2023-06-04 22:05:45 +05:30
Samuel Gomes 71363923ce Add QB64-PE version (min. req.) check 2023-05-29 19:13:48 +05:30
Samuel Gomes e01342ef04 Update .gitignore 2023-05-10 13:50:17 +05:30
Samuel Gomes b6515f6ea8 Remove unneeded download.bas 2023-05-09 22:27:55 +05:30
Samuel Gomes a05d79f5b4 Fix typo in _MESSAGEBOX string options 2023-05-09 21:35:18 +05:30
Samuel Gomes 3ca90982c6 Add 0.1 sec. delay before calling common dialogs so the interface can redraw correctly 2023-05-09 18:43:43 +05:30
Samuel Gomes 7f39847ce2 Update README.md 2023-05-09 08:04:28 +05:30
Samuel Gomes e5b60db74d Update README.md 2023-05-09 07:50:08 +05:30
Samuel Gomes 10b66ac722 Update README.md 2023-05-09 04:56:33 +05:30
Samuel Gomes a15eb6f601 Change all keyword case to upper 2023-05-09 04:39:01 +05:30
Samuel Gomes 1451684677 Fix Declare Library declarations 2023-05-09 04:15:10 +05:30
Samuel Gomes 3ce23c8d1f Fix resource paths 2023-05-09 03:22:44 +05:30
Samuel Gomes 7305a3ecca Change keyword case to mixed 2023-05-09 03:00:44 +05:30
Samuel Gomes 8a7f850c93 Update README.md. Remove updater icon. 2023-05-09 02:48:11 +05:30
Samuel Gomes a3ba9a6feb Initial cleanup 2023-05-09 02:23:53 +05:30
Samuel Gomes fb177d6abf
Merge pull request #7 from GeorgeMcGinn/development
Update InForm to Install/Run on either QB64 or QB64pe
2022-11-02 06:04:03 +05:30
George McGinn fdf2e841ec
Merge branch 'a740g:master' into development 2022-11-01 23:40:46 +00:00
George McGinn 42a0b9d017
Update README.md
Changes made based on pull request #7, Issue #2
2022-11-01 19:37:06 -04:00
George McGinn fc4d90c25e Update InForm to Install/Run on either QB64 or QB64pe #2
Updates to v1.4.0 of InForm:
	* Runs with either QB64 or QB64/PE
	* Removed the defunct auto-update, develoer update & installer
	* InForm no longer internally compiles UiEditorPreview (All compiles done at setup time)
	* InForm now runs in the InForm directory instead of the QB64 directory
	* InForm is aware of which QB64 is installed (QB64 or QB64PE)
	* Will work with either the new Messagebox dialog (PE v.3.4.0) or older messagebox dialog.
	* Ensure library continues to work even if QB64-PE font library changes wink
        * Changed the setup scripts
2022-11-01 19:31:18 -04:00
Samuel Gomes 527e53143a Update .gitignore 2022-10-31 06:45:15 +05:30
Samuel Gomes ea659c62be Remove goal - common dialog now baked into QB64-PE 2022-10-26 03:35:51 +05:30
Samuel Gomes bea4115510 Look for QB64-PE instead of QB64. Hardcoded now. Will make it configurable later. 2022-10-26 03:30:05 +05:30
Samuel Gomes 72368e2ca2 Add Option _ExplicitArray to sources 2022-10-16 20:28:00 +05:30
Samuel Gomes 2719b4801a Add goals 2022-10-13 08:02:32 +05:30
Samuel Gomes c9ba19465b Add Linux & macOS executable to .gitignore 2022-10-13 07:21:29 +05:30
Samuel Gomes b0053228d8 Update falcon.h 2022-10-13 07:06:18 +05:30
Samuel Gomes dbb7a97a0c Update .gitignore to ignore .ini files 2022-10-13 06:15:34 +05:30
Samuel Gomes 5d833897ca And so it begins 2022-10-13 06:06:39 +05:30
Samuel Gomes 7780ac9ceb Cleanup. Add *.exe to .gitignore 2022-10-13 01:24:37 +05:30
Samuel Gomes 6309128821
Merge pull request #1 from a740g/development
Merge dev branch with master
2022-10-13 00:44:45 +05:30
FellippeHeitor 36a7f9a339 Add recompiled binaries for distribution 2021-10-12 21:58:10 -03:00
329 changed files with 139591 additions and 20955 deletions

2
.gitattributes vendored Normal file
View file

@ -0,0 +1,2 @@
# Auto detect text files and perform LF normalization
* text=auto

19
.gitignore vendored
View file

@ -1,2 +1,17 @@
/build.bat
/copy.bat
# Ignore all
*
# Unignore all with extensions
!*.*
# Unignore all dirs
!*/
# Unignore wiki
!docs/wiki
# Ignore all exe files
*.exe
# Ignore all ini files
*.ini
# Other temp files
*.frmbin
#Ignore macOS stuff
*.command
!setup_inform_osx.command

3
.gitmodules vendored Normal file
View file

@ -0,0 +1,3 @@
[submodule "docs/wiki"]
path = docs/wiki
url = https://github.com/a740g/InForm-PE.wiki

View file

@ -1,352 +1,118 @@
'InForm - GUI library for QB64
'Fellippe Heitor, 2016-2019 - fellippe@qb64.org - @fellippeheitor
'
'-----------------------------------------------------------------------------------------------------------------------
' InForm-PE GUI engine for QB64-PE
' Copyright (c) 2024 Samuel Gomes
' Copyright (c) 2023 George McGinn
' Copyright (c) 2022 Fellippe Heitor
'-----------------------------------------------------------------------------------------------------------------------
DECLARE LIBRARY
FUNCTION __UI_GetPID ALIAS getpid ()
END DECLARE
$IF INFORM_BI = UNDEFINED THEN
$LET INFORM_BI = TRUE
DECLARE CUSTOMTYPE LIBRARY
SUB __UI_MemCopy ALIAS memcpy (BYVAL dest AS _OFFSET, BYVAL source AS _OFFSET, BYVAL bytes AS LONG)
END DECLARE
$SCREENHIDE
_CONTROLCHR OFF
DECLARE LIBRARY "falcon"
SUB uprint_extra (BYVAL x&, BYVAL y&, BYVAL chars%&, BYVAL length%&, BYVAL kern&, BYVAL do_render&, txt_width&, BYVAL charpos%&, charcount&, BYVAL colour~&, BYVAL max_width&)
FUNCTION uprint (BYVAL x&, BYVAL y&, chars$, BYVAL txt_len&, BYVAL colour~&, BYVAL max_width&)
FUNCTION uprintwidth (chars$, BYVAL txt_len&, BYVAL max_width&)
FUNCTION uheight& ()
FUNCTION falcon_uspacing& ALIAS uspacing ()
FUNCTION uascension& ()
END DECLARE
'$INCLUDE:'InFormCommon.bi'
$IF WIN THEN
DECLARE LIBRARY
FUNCTION __UI_MB& ALIAS MessageBox (BYVAL ignore&, message$, title$, BYVAL type&)
FUNCTION GetSystemMetrics& (BYVAL WhichMetric&)
END DECLARE
'Control types: -----------------------------------------------
__UI_Type(__UI_Type_Form).Name = "Form"
__UI_Type(__UI_Type_Frame).Name = "Frame"
__UI_Type(__UI_Type_Frame).DefaultWidth = 230
__UI_Type(__UI_Type_Frame).DefaultHeight = 150
__UI_Type(__UI_Type_Button).Name = "Button"
__UI_Type(__UI_Type_Button).DefaultWidth = 80
__UI_Type(__UI_Type_Button).DefaultHeight = 23
__UI_Type(__UI_Type_Label).Name = "Label"
__UI_Type(__UI_Type_Label).DefaultWidth = 150
__UI_Type(__UI_Type_Label).DefaultHeight = 23
__UI_Type(__UI_Type_CheckBox).Name = "CheckBox"
__UI_Type(__UI_Type_CheckBox).DefaultWidth = 150
__UI_Type(__UI_Type_CheckBox).DefaultHeight = 23
__UI_Type(__UI_Type_CheckBox).TurnsInto = __UI_Type_ToggleSwitch
__UI_Type(__UI_Type_RadioButton).Name = "RadioButton"
__UI_Type(__UI_Type_RadioButton).DefaultWidth = 150
__UI_Type(__UI_Type_RadioButton).DefaultHeight = 23
__UI_Type(__UI_Type_TextBox).Name = "TextBox"
__UI_Type(__UI_Type_TextBox).DefaultWidth = 120
__UI_Type(__UI_Type_TextBox).DefaultHeight = 23
__UI_Type(__UI_Type_ProgressBar).Name = "ProgressBar"
__UI_Type(__UI_Type_ProgressBar).DefaultWidth = 300
__UI_Type(__UI_Type_ProgressBar).DefaultHeight = 23
__UI_Type(__UI_Type_ListBox).Name = "ListBox"
__UI_Type(__UI_Type_ListBox).DefaultWidth = 200
__UI_Type(__UI_Type_ListBox).DefaultHeight = 200
__UI_Type(__UI_Type_ListBox).TurnsInto = __UI_Type_DropdownList
__UI_Type(__UI_Type_DropdownList).Name = "DropdownList"
__UI_Type(__UI_Type_DropdownList).DefaultWidth = 200
__UI_Type(__UI_Type_DropdownList).DefaultHeight = 23
__UI_Type(__UI_Type_DropdownList).TurnsInto = __UI_Type_ListBox
__UI_Type(__UI_Type_MenuBar).Name = "MenuBar"
__UI_Type(__UI_Type_MenuBar).TurnsInto = __UI_Type_ContextMenu
__UI_Type(__UI_Type_MenuBar).RestrictResize = __UI_CantResizeV
__UI_Type(__UI_Type_MenuItem).Name = "MenuItem"
__UI_Type(__UI_Type_MenuItem).RestrictResize = __UI_CantResizeV
__UI_Type(__UI_Type_MenuPanel).Name = "MenuPanel"
__UI_Type(__UI_Type_PictureBox).Name = "PictureBox"
__UI_Type(__UI_Type_PictureBox).DefaultWidth = 230
__UI_Type(__UI_Type_PictureBox).DefaultHeight = 150
__UI_Type(__UI_Type_TrackBar).Name = "TrackBar"
__UI_Type(__UI_Type_TrackBar).DefaultWidth = 300
__UI_Type(__UI_Type_TrackBar).DefaultHeight = 40
__UI_Type(__UI_Type_TrackBar).MinimumHeight = 30
__UI_Type(__UI_Type_TrackBar).RestrictResize = __UI_CantResizeV
__UI_Type(__UI_Type_ContextMenu).Name = "ContextMenu"
__UI_Type(__UI_Type_ContextMenu).TurnsInto = __UI_Type_MenuBar
__UI_Type(__UI_Type_ContextMenu).RestrictResize = __UI_CantResize
__UI_Type(__UI_Type_ContextMenu).DefaultWidth = 22
__UI_Type(__UI_Type_ContextMenu).DefaultHeight = 22
__UI_Type(__UI_Type_Font).Name = "Font"
__UI_Type(__UI_Type_ToggleSwitch).Name = "ToggleSwitch"
__UI_Type(__UI_Type_ToggleSwitch).DefaultWidth = 40
__UI_Type(__UI_Type_ToggleSwitch).DefaultHeight = 17
__UI_Type(__UI_Type_ToggleSwitch).TurnsInto = __UI_Type_CheckBox
__UI_Type(__UI_Type_ToggleSwitch).RestrictResize = __UI_CantResize
'--------------------------------------------------------------
__UI_RestoreFKeys
__UI_SubMenuDelay = .4
__UI_SnapDistance = 5
__UI_SnapDistanceFromForm = 10
__UI_MaxBorderSize = 10
__UI_Font8Offset = 5
__UI_Font16Offset = 3
__UI_ClipboardCheck$ = "InForm" + STRING$(2, 10) + "BEGIN CONTROL DATA" + CHR$(10) + STRING$(60, 45) + CHR$(10)
__UI_ThemeSetup
__UI_InternalMenus
__UI_LoadForm
__UI_Init
'Main loop
DO
_LIMIT 1
LOOP
SYSTEM
__UI_ErrorHandler:
RESUME NEXT
CONST __UI_SM_SWAPBUTTON = 23
$ELSE
DECLARE LIBRARY ""
FUNCTION __UI_MB& ALIAS MessageBox (BYVAL ignore&, message$, title$, BYVAL type&)
END DECLARE
$END IF
$SCREENHIDE
_CONTROLCHR OFF
TYPE __UI_ControlTYPE
ID AS LONG
ParentID AS LONG
PreviousParentID AS LONG
ContextMenuID AS LONG
Type AS INTEGER
Name AS STRING * 40
ParentName AS STRING * 40
SubMenu AS _BYTE
MenuPanelID AS LONG
SourceControl AS LONG
Top AS INTEGER
Left AS INTEGER
Width AS INTEGER
Height AS INTEGER
Canvas AS LONG
HelperCanvas AS LONG
TransparentColor AS _UNSIGNED LONG
Stretch AS _BYTE
PreviousStretch AS _BYTE
Font AS INTEGER
PreviousFont AS INTEGER
BackColor AS _UNSIGNED LONG
ForeColor AS _UNSIGNED LONG
SelectedForeColor AS _UNSIGNED LONG
SelectedBackColor AS _UNSIGNED LONG
BackStyle AS _BYTE
HasBorder AS _BYTE
BorderSize AS INTEGER
Padding AS INTEGER
Encoding AS LONG
Align AS _BYTE
PrevAlign AS _BYTE
VAlign AS _BYTE
PrevVAlign AS _BYTE
BorderColor AS _UNSIGNED LONG
Value AS _FLOAT
PreviousValue AS _FLOAT
Min AS _FLOAT
PrevMin AS _FLOAT
Max AS _FLOAT
PrevMax AS _FLOAT
Interval AS _FLOAT
PrevInterval AS _FLOAT
MinInterval AS _FLOAT
PrevMinInterval AS _FLOAT
HotKey AS INTEGER
HotKeyOffset AS INTEGER
HotKeyPosition AS INTEGER
ShowPercentage AS _BYTE
AutoScroll AS _BYTE
AutoSize AS _BYTE
InputViewStart AS LONG
PreviousInputViewStart AS LONG
LastVisibleItem AS INTEGER
ItemHeight AS INTEGER
HasVScrollbar AS _BYTE
VScrollbarButton2Top AS INTEGER
HoveringVScrollbarButton AS _BYTE
ThumbHeight AS INTEGER
ThumbTop AS INTEGER
VScrollbarRatio AS SINGLE
Cursor AS LONG
PasswordField AS _BYTE
PrevCursor AS LONG
FieldArea AS LONG
PreviousFieldArea AS LONG
TextIsSelected AS _BYTE
BypassSelectOnFocus AS _BYTE
Multiline AS _BYTE
NumericOnly AS _BYTE
FirstVisibleLine AS LONG
PrevFirstVisibleLine AS LONG
CurrentLine AS LONG
PrevCurrentLine AS LONG
VisibleCursor AS LONG
PrevVisibleCursor AS LONG
ControlIsSelected AS _BYTE
LeftOffsetFromFirstSelected AS INTEGER
TopOffsetFromFirstSelected AS INTEGER
SelectionLength AS LONG
SelectionStart AS LONG
WordWrap AS _BYTE
CanResize AS _BYTE
CanHaveFocus AS _BYTE
Disabled AS _BYTE
Hidden AS _BYTE
PreviouslyHidden AS _BYTE
CenteredWindow AS _BYTE
ControlState AS _BYTE
ChildrenRedrawn AS _BYTE
FocusState AS LONG
LastChange AS SINGLE
Redraw AS _BYTE
BulletStyle AS _BYTE
MenuItemGroup AS INTEGER
KeyCombo AS LONG
BoundTo AS LONG
BoundProperty AS LONG
END TYPE
TYPE __UI_Types
Name AS STRING * 16
Count AS LONG
TurnsInto AS INTEGER
DefaultHeight AS INTEGER
MinimumHeight AS INTEGER
DefaultWidth AS INTEGER
MinimumWidth AS INTEGER
RestrictResize AS _BYTE
END TYPE
TYPE __UI_ThemeImagesType
FileName AS STRING * 32
Handle AS LONG
END TYPE
TYPE __UI_WordWrapHistoryType
StringSlot AS LONG
Width AS INTEGER
LongestLine AS INTEGER
Font AS LONG
TotalLines AS INTEGER
END TYPE
TYPE __UI_KeyCombos
Combo AS STRING * 14 ' "CTRL+SHIFT+F12"
FriendlyCombo AS STRING * 14 ' "Ctrl+Shift+F12"
ControlID AS LONG
END TYPE
REDIM SHARED Caption(0 TO 100) AS STRING
REDIM SHARED __UI_TempCaptions(0 TO 100) AS STRING
REDIM SHARED Text(0 TO 100) AS STRING
REDIM SHARED __UI_TempTexts(0 TO 100) AS STRING
REDIM SHARED Mask(0 TO 100) AS STRING
REDIM SHARED __UI_TempMask(0 TO 100) AS STRING
REDIM SHARED ToolTip(0 TO 100) AS STRING
REDIM SHARED __UI_TempTips(0 TO 100) AS STRING
REDIM SHARED Control(0 TO 100) AS __UI_ControlTYPE
REDIM SHARED ControlDrawOrder(0) AS LONG
REDIM SHARED __UI_ThemeImages(0 TO 100) AS __UI_ThemeImagesType
REDIM SHARED __UI_WordWrapHistoryTexts(0 TO 100) AS STRING
REDIM SHARED __UI_WordWrapHistoryResults(0 TO 100) AS STRING
REDIM SHARED __UI_WordWrapHistory(0 TO 100) AS __UI_WordWrapHistoryType
REDIM SHARED __UI_ThisLineChars(0) AS LONG, __UI_FocusedTextBoxChars(0) AS LONG
REDIM SHARED __UI_ActiveMenu(0 TO 100) AS LONG, __UI_ParentMenu(0 TO 100) AS LONG
REDIM SHARED __UI_KeyCombo(0 TO 100) AS __UI_KeyCombos
DIM SHARED __UI_TotalKeyCombos AS LONG, __UI_BypassKeyCombos AS _BYTE
DIM SHARED table1252$(0 TO 255), table437$(0 TO 255)
DIM SHARED __UI_MouseLeft AS INTEGER, __UI_MouseTop AS INTEGER
DIM SHARED __UI_MouseWheel AS INTEGER, __UI_MouseButtonsSwap AS _BYTE
DIM SHARED __UI_PrevMouseLeft AS INTEGER, __UI_PrevMouseTop AS INTEGER
DIM SHARED __UI_MouseButton1 AS _BYTE, __UI_MouseButton2 AS _BYTE
DIM SHARED __UI_MouseIsDown AS _BYTE, __UI_MouseDownOnID AS LONG
DIM SHARED __UI_Mouse2IsDown AS _BYTE, __UI_Mouse2DownOnID AS LONG
DIM SHARED __UI_PreviousMouseDownOnID AS LONG
DIM SHARED __UI_KeyIsDown AS _BYTE, __UI_KeyDownOnID AS LONG
DIM SHARED __UI_ShiftIsDown AS _BYTE, __UI_CtrlIsDown AS _BYTE
DIM SHARED __UI_AltIsDown AS _BYTE, __UI_ShowHotKeys AS _BYTE, __UI_AltCombo$
DIM SHARED __UI_LastMouseClick AS SINGLE, __UI_MouseDownOnScrollbar AS SINGLE
DIM SHARED __UI_DragX AS INTEGER, __UI_DragY AS INTEGER
DIM SHARED __UI_DefaultButtonID AS LONG
DIM SHARED __UI_KeyHit AS LONG, __UI_KeepFocus AS _BYTE
DIM SHARED __UI_Focus AS LONG, __UI_PreviousFocus AS LONG, __UI_KeyboardFocus AS _BYTE
DIM SHARED __UI_HoveringID AS LONG, __UI_LastHoveringID AS LONG, __UI_BelowHoveringID AS LONG
DIM SHARED __UI_IsDragging AS _BYTE, __UI_DraggingID AS LONG
DIM SHARED __UI_IsResizing AS _BYTE, __UI_ResizingID AS LONG
DIM SHARED __UI_ResizeHandleHover AS _BYTE
DIM SHARED __UI_IsSelectingText AS _BYTE, __UI_IsSelectingTextOnID AS LONG
DIM SHARED __UI_SelectedText AS STRING, __UI_SelectionLength AS LONG
DIM SHARED __UI_StateHasChanged AS _BYTE
DIM SHARED __UI_DraggingThumb AS _BYTE, __UI_ThumbDragTop AS INTEGER
DIM SHARED __UI_DraggingThumbOnID AS LONG
DIM SHARED __UI_HasInput AS _BYTE, __UI_ProcessInputTimer AS SINGLE
DIM SHARED __UI_UnloadSignal AS _BYTE, __UI_HasResized AS _BYTE
DIM SHARED __UI_ExitTriggered AS _BYTE
DIM SHARED __UI_Loaded AS _BYTE
DIM SHARED __UI_EventsTimer AS INTEGER, __UI_RefreshTimer AS INTEGER
DIM SHARED __UI_ActiveDropdownList AS LONG, __UI_ParentDropdownList AS LONG
DIM SHARED __UI_TotalActiveMenus AS LONG, __UI_ActiveMenuIsContextMenu AS _BYTE
DIM SHARED __UI_SubMenuDelay AS SINGLE, __UI_HoveringSubMenu AS _BYTE
DIM SHARED __UI_TopMenuBarItem AS LONG
DIM SHARED __UI_ActiveTipID AS LONG, __UI_TipTimer AS SINGLE, __UI_PreviousTipID AS LONG
DIM SHARED __UI_ActiveTipTop AS INTEGER, __UI_ActiveTipLeft AS INTEGER
DIM SHARED __UI_FormID AS LONG, __UI_HasMenuBar AS LONG
DIM SHARED __UI_ScrollbarWidth AS INTEGER, __UI_ScrollbarButtonHeight AS INTEGER
DIM SHARED __UI_MenuBarOffset AS INTEGER, __UI_MenuItemOffset AS INTEGER
DIM SHARED __UI_NewMenuBarTextLeft AS INTEGER, __UI_DefaultCaptionIndent AS INTEGER
DIM SHARED __UI_ForceRedraw AS _BYTE, __UI_AutoRefresh AS _BYTE
DIM SHARED __UI_CurrentTitle AS STRING
DIM SHARED __UI_DesignMode AS _BYTE, __UI_FirstSelectedID AS LONG
DIM SHARED __UI_WaitMessage AS STRING, __UI_TotalSelectedControls AS LONG
DIM SHARED __UI_WaitMessageHandle AS LONG, __UI_EditorMode AS _BYTE
DIM SHARED __UI_LastRenderedLineWidth AS LONG, __UI_LastRenderedCharCount AS LONG
DIM SHARED __UI_SelectionRectangleTop AS INTEGER, __UI_SelectionRectangleLeft AS INTEGER
DIM SHARED __UI_SelectionRectangle AS _BYTE
DIM SHARED __UI_CantShowContextMenu AS _BYTE, __UI_ShowPositionAndSize AS _BYTE
DIM SHARED __UI_ShowInvisibleControls AS _BYTE, __UI_Snapped AS _BYTE
DIM SHARED __UI_SnappedByProximityX AS _BYTE, __UI_SnappedByProximityY AS _BYTE
DIM SHARED __UI_SnappedX AS INTEGER, __UI_SnappedY AS INTEGER
DIM SHARED __UI_SnappedXID AS LONG, __UI_SnappedYID AS LONG
DIM SHARED __UI_SnapLines AS _BYTE, __UI_SnapDistance AS INTEGER, __UI_SnapDistanceFromForm AS INTEGER
DIM SHARED __UI_FrameRate AS SINGLE, __UI_Font8Offset AS INTEGER, __UI_Font16Offset AS INTEGER
DIM SHARED __UI_ClipboardCheck$, __UI_MenuBarOffsetV AS INTEGER
DIM SHARED __UI_KeepScreenHidden AS _BYTE, __UI_MaxBorderSize AS INTEGER
DIM SHARED __UI_InternalContextMenus AS LONG, __UI_DidClick AS _BYTE
DIM SHARED __UI_ContextMenuSourceID AS LONG
DIM SHARED __UI_FKey(1 TO 12) AS LONG
'Control types: -----------------------------------------------
DIM SHARED __UI_Type(0 TO 18) AS __UI_Types
__UI_Type(__UI_Type_Form).Name = "Form"
__UI_Type(__UI_Type_Frame).Name = "Frame"
__UI_Type(__UI_Type_Frame).DefaultWidth = 230
__UI_Type(__UI_Type_Frame).DefaultHeight = 150
__UI_Type(__UI_Type_Button).Name = "Button"
__UI_Type(__UI_Type_Button).DefaultWidth = 80
__UI_Type(__UI_Type_Button).DefaultHeight = 23
__UI_Type(__UI_Type_Label).Name = "Label"
__UI_Type(__UI_Type_Label).DefaultWidth = 150
__UI_Type(__UI_Type_Label).DefaultHeight = 23
__UI_Type(__UI_Type_CheckBox).Name = "CheckBox"
__UI_Type(__UI_Type_CheckBox).DefaultWidth = 150
__UI_Type(__UI_Type_CheckBox).DefaultHeight = 23
__UI_Type(__UI_Type_CheckBox).TurnsInto = __UI_Type_ToggleSwitch
__UI_Type(__UI_Type_RadioButton).Name = "RadioButton"
__UI_Type(__UI_Type_RadioButton).DefaultWidth = 150
__UI_Type(__UI_Type_RadioButton).DefaultHeight = 23
__UI_Type(__UI_Type_TextBox).Name = "TextBox"
__UI_Type(__UI_Type_TextBox).DefaultWidth = 120
__UI_Type(__UI_Type_TextBox).DefaultHeight = 23
__UI_Type(__UI_Type_ProgressBar).Name = "ProgressBar"
__UI_Type(__UI_Type_ProgressBar).DefaultWidth = 300
__UI_Type(__UI_Type_ProgressBar).DefaultHeight = 23
__UI_Type(__UI_Type_ListBox).Name = "ListBox"
__UI_Type(__UI_Type_ListBox).DefaultWidth = 200
__UI_Type(__UI_Type_ListBox).DefaultHeight = 200
__UI_Type(__UI_Type_ListBox).TurnsInto = __UI_Type_DropdownList
__UI_Type(__UI_Type_DropdownList).Name = "DropdownList"
__UI_Type(__UI_Type_DropdownList).DefaultWidth = 200
__UI_Type(__UI_Type_DropdownList).DefaultHeight = 23
__UI_Type(__UI_Type_DropdownList).TurnsInto = __UI_Type_ListBox
__UI_Type(__UI_Type_MenuBar).Name = "MenuBar"
__UI_Type(__UI_Type_MenuBar).TurnsInto = __UI_Type_ContextMenu
__UI_Type(__UI_Type_MenuBar).RestrictResize = __UI_CantResizeV
__UI_Type(__UI_Type_MenuItem).Name = "MenuItem"
__UI_Type(__UI_Type_MenuItem).RestrictResize = __UI_CantResizeV
__UI_Type(__UI_Type_MenuPanel).Name = "MenuPanel"
__UI_Type(__UI_Type_PictureBox).Name = "PictureBox"
__UI_Type(__UI_Type_PictureBox).DefaultWidth = 230
__UI_Type(__UI_Type_PictureBox).DefaultHeight = 150
__UI_Type(__UI_Type_TrackBar).Name = "TrackBar"
__UI_Type(__UI_Type_TrackBar).DefaultWidth = 300
__UI_Type(__UI_Type_TrackBar).DefaultHeight = 40
__UI_Type(__UI_Type_TrackBar).MinimumHeight = 30
__UI_Type(__UI_Type_TrackBar).RestrictResize = __UI_CantResizeV
__UI_Type(__UI_Type_ContextMenu).Name = "ContextMenu"
__UI_Type(__UI_Type_ContextMenu).TurnsInto = __UI_Type_MenuBar
__UI_Type(__UI_Type_ContextMenu).RestrictResize = __UI_CantResize
__UI_Type(__UI_Type_ContextMenu).DefaultWidth = 22
__UI_Type(__UI_Type_ContextMenu).DefaultHeight = 22
__UI_Type(__UI_Type_Font).Name = "Font"
__UI_Type(__UI_Type_ToggleSwitch).Name = "ToggleSwitch"
__UI_Type(__UI_Type_ToggleSwitch).DefaultWidth = 40
__UI_Type(__UI_Type_ToggleSwitch).DefaultHeight = 17
__UI_Type(__UI_Type_ToggleSwitch).TurnsInto = __UI_Type_CheckBox
__UI_Type(__UI_Type_ToggleSwitch).RestrictResize = __UI_CantResize
'--------------------------------------------------------------
__UI_RestoreFKeys
CONST True = -1, False = 0
'$INCLUDE:'InFormVersion.bas'
__UI_SubMenuDelay = .4
__UI_SnapDistance = 5
__UI_SnapDistanceFromForm = 10
__UI_MaxBorderSize = 10
__UI_Font8Offset = 5
__UI_Font16Offset = 3
__UI_ClipboardCheck$ = "InForm" + STRING$(2, 10) + "BEGIN CONTROL DATA" + CHR$(10) + STRING$(60, 45) + CHR$(10)
__UI_ThemeSetup
__UI_InternalMenus
__UI_LoadForm
__UI_Init
'Main loop
DO
_LIMIT 1
LOOP
SYSTEM
__UI_ErrorHandler:
RESUME NEXT

File diff suppressed because it is too large Load diff

342
InForm/InFormCommon.bi Normal file
View file

@ -0,0 +1,342 @@
'-----------------------------------------------------------------------------------------------------------------------
' Common InForm header. This is included by the main InForm header file
' Copyright (c) 2024 Samuel Gomes
' Copyright (c) 2022 Fellippe Heitor
'-----------------------------------------------------------------------------------------------------------------------
$IF INFORMCOMMON_BI = UNDEFINED THEN
$LET INFORMCOMMON_BI = TRUE
' Do a complier check to ensure we have the minimum version needed
$IF VERSION < 3.11.0 THEN
$ERROR 'This requires the latest version of QB64-PE from https://github.com/QB64-Phoenix-Edition/QB64pe/releases'
$END IF
'$INCLUDE:'InFormVersion.bi'
'$INCLUDE:'extensions/HashTable.bi'
CONST FALSE%% = 0%%, TRUE%% = NOT FALSE
' InForm theme image IDs
CONST __INFORM_THEME_IMAGE_ARROWS~%% = 1~%%
CONST __INFORM_THEME_IMAGE_BUTTON~%% = 2~%%
CONST __INFORM_THEME_IMAGE_CHECKBOX~%% = 3~%%
CONST __INFORM_THEME_IMAGE_FRAME~%% = 4~%%
CONST __INFORM_THEME_IMAGE_MENUCHECKMARK~%% = 5~%%
CONST __INFORM_THEME_IMAGE_NOTFOUND~%% = 6~%%
CONST __INFORM_THEME_IMAGE_PROGRESSCHUNK~%% = 7~%%
CONST __INFORM_THEME_IMAGE_PROGRESSTRACK~%% = 8~%%
CONST __INFORM_THEME_IMAGE_RADIOBUTTON~%% = 9~%%
CONST __INFORM_THEME_IMAGE_SCROLLBUTTONS~%% = 10~%%
CONST __INFORM_THEME_IMAGE_SCROLLHBUTTONS~%% = 11~%%
CONST __INFORM_THEME_IMAGE_SCROLLHTHUMB~%% = 12~%%
CONST __INFORM_THEME_IMAGE_SCROLLHTRACK~%% = 13~%%
CONST __INFORM_THEME_IMAGE_SCROLLTHUMB~%% = 14~%%
CONST __INFORM_THEME_IMAGE_SCROLLTRACK~%% = 15~%%
CONST __INFORM_THEME_IMAGE_SLIDERDOWN~%% = 16~%%
CONST __INFORM_THEME_IMAGE_SLIDERTRACK~%% = 17~%%
'Control types:
CONST __UI_Type_Form%% = 1%%
CONST __UI_Type_Frame%% = 2%%
CONST __UI_Type_Button%% = 3%%
CONST __UI_Type_Label%% = 4%%
CONST __UI_Type_CheckBox%% = 5%%
CONST __UI_Type_RadioButton%% = 6%%
CONST __UI_Type_TextBox%% = 7%%
CONST __UI_Type_ProgressBar%% = 8%%
CONST __UI_Type_ListBox%% = 9%%
CONST __UI_Type_DropdownList%% = 10%%
CONST __UI_Type_MenuBar%% = 11%%
CONST __UI_Type_MenuItem%% = 12%%
CONST __UI_Type_MenuPanel%% = 13%%
CONST __UI_Type_PictureBox%% = 14%%
CONST __UI_Type_TrackBar%% = 15%%
CONST __UI_Type_ContextMenu%% = 16%%
CONST __UI_Type_Font%% = 17%%
CONST __UI_Type_ToggleSwitch%% = 18%%
'Back styles:
CONST __UI_Opaque%% = 0%%
CONST __UI_Transparent%% = -1%%
'Text alignment
CONST __UI_Left%% = 0%%
CONST __UI_Center%% = 1%%
CONST __UI_Right%% = 2%%
CONST __UI_Top%% = 0%%
CONST __UI_Middle%% = 1%%
CONST __UI_Bottom%% = 2%%
'Textbox controls
CONST __UI_NumericWithoutBounds%% = -1%%
CONST __UI_NumericWithBounds%% = 2%%
'BulletStyle
CONST __UI_CheckMark%% = 0%%
CONST __UI_Bullet%% = 1%%
'General constants
CONST __UI_ToolTipTimeOut! = 0.8!
CONST __UI_CantResizeV%% = 1%%
CONST __UI_CantResizeH%% = 2%%
CONST __UI_CantResize%% = 3%%
'Messagebox constants
CONST MsgBox_OkOnly& = 1&
CONST MsgBox_OkCancel& = 2&
CONST MsgBox_AbortRetryIgnore& = 4&
CONST MsgBox_YesNoCancel& = 8&
CONST MsgBox_YesNo& = 16&
CONST MsgBox_RetryCancel& = 32&
CONST MsgBox_CancelTryAgainContinue& = 64&
CONST MsgBox_Critical& = 128&
CONST MsgBox_Question& = 256&
CONST MsgBox_Exclamation& = 512&
CONST MsgBox_Information& = 1024&
CONST MsgBox_DefaultButton1& = 2048&
CONST MsgBox_DefaultButton2& = 4096&
CONST MsgBox_DefaultButton3& = 8192&
CONST MsgBox_Defaultbutton4& = 16384&
CONST MsgBox_AppModal& = 32768&
CONST MsgBox_SystemModal& = 65536&
CONST MsgBox_SetForeground& = 131072&
CONST MsgBox_Ok& = 1&
CONST MsgBox_Yes& = 2&
CONST MsgBox_No& = 3&
CONST MsgBox_Cancel& = 4&
CONST MsgBox_Abort& = 5&
CONST MsgBox_Retry& = 6&
CONST MsgBox_Ignore& = 7&
CONST MsgBox_TryAgain& = 8&
CONST MsgBox_Continue& = 9&
DECLARE LIBRARY
FUNCTION __UI_GetPID ALIAS getpid
END DECLARE
DECLARE CUSTOMTYPE LIBRARY
SUB __UI_MemCopy ALIAS memcpy (BYVAL dest AS _OFFSET, BYVAL source AS _OFFSET, BYVAL bytes AS LONG)
END DECLARE
$IF WIN THEN
DECLARE LIBRARY
FUNCTION GetSystemMetrics& (BYVAL WhichMetric&)
END DECLARE
CONST __UI_SM_SWAPBUTTON = 23
$END IF
TYPE __UI_ControlTYPE
ID AS LONG
ParentID AS LONG
PreviousParentID AS LONG
ContextMenuID AS LONG
Type AS INTEGER
Name AS STRING * 40
ParentName AS STRING * 40
SubMenu AS _BYTE
MenuPanelID AS LONG
SourceControl AS LONG
Top AS INTEGER
Left AS INTEGER
Width AS INTEGER
Height AS INTEGER
Canvas AS LONG
HelperCanvas AS LONG
TransparentColor AS _UNSIGNED LONG
Stretch AS _BYTE
PreviousStretch AS _BYTE
Font AS INTEGER
PreviousFont AS INTEGER
BackColor AS _UNSIGNED LONG
ForeColor AS _UNSIGNED LONG
SelectedForeColor AS _UNSIGNED LONG
SelectedBackColor AS _UNSIGNED LONG
BackStyle AS _BYTE
HasBorder AS _BYTE
BorderSize AS INTEGER
Padding AS INTEGER
Encoding AS LONG
Align AS _BYTE
PrevAlign AS _BYTE
VAlign AS _BYTE
PrevVAlign AS _BYTE
BorderColor AS _UNSIGNED LONG
Value AS _FLOAT
PreviousValue AS _FLOAT
Min AS _FLOAT
PrevMin AS _FLOAT
Max AS _FLOAT
PrevMax AS _FLOAT
Interval AS _FLOAT
PrevInterval AS _FLOAT
MinInterval AS _FLOAT
PrevMinInterval AS _FLOAT
HotKey AS INTEGER
HotKeyOffset AS INTEGER
HotKeyPosition AS INTEGER
ShowPercentage AS _BYTE
AutoScroll AS _BYTE
AutoSize AS _BYTE
InputViewStart AS LONG
PreviousInputViewStart AS LONG
LastVisibleItem AS INTEGER
ItemHeight AS INTEGER
HasVScrollbar AS _BYTE
VScrollbarButton2Top AS INTEGER
HoveringVScrollbarButton AS _BYTE
ThumbHeight AS INTEGER
ThumbTop AS INTEGER
VScrollbarRatio AS SINGLE
Cursor AS LONG
PasswordField AS _BYTE
PrevCursor AS LONG
FieldArea AS LONG
PreviousFieldArea AS LONG
TextIsSelected AS _BYTE
BypassSelectOnFocus AS _BYTE
Multiline AS _BYTE
NumericOnly AS _BYTE
FirstVisibleLine AS LONG
PrevFirstVisibleLine AS LONG
CurrentLine AS LONG
PrevCurrentLine AS LONG
VisibleCursor AS LONG
PrevVisibleCursor AS LONG
ControlIsSelected AS _BYTE
LeftOffsetFromFirstSelected AS INTEGER
TopOffsetFromFirstSelected AS INTEGER
SelectionLength AS LONG
SelectionStart AS LONG
WordWrap AS _BYTE
CanResize AS _BYTE
CanHaveFocus AS _BYTE
Disabled AS _BYTE
Hidden AS _BYTE
PreviouslyHidden AS _BYTE
CenteredWindow AS _BYTE
ControlState AS _BYTE
ChildrenRedrawn AS _BYTE
FocusState AS LONG
LastChange AS SINGLE
Redraw AS _BYTE
BulletStyle AS _BYTE
MenuItemGroup AS INTEGER
KeyCombo AS LONG
BoundTo AS LONG
BoundProperty AS LONG
END TYPE
TYPE __UI_Types
Name AS STRING * 16
Count AS LONG
TurnsInto AS INTEGER
DefaultHeight AS INTEGER
MinimumHeight AS INTEGER
DefaultWidth AS INTEGER
MinimumWidth AS INTEGER
RestrictResize AS _BYTE
END TYPE
TYPE __UI_WordWrapHistoryType
StringSlot AS LONG
Width AS INTEGER
LongestLine AS INTEGER
Font AS LONG
TotalLines AS INTEGER
END TYPE
TYPE __UI_KeyCombos
Combo AS STRING * 14 ' "CTRL+SHIFT+F12"
FriendlyCombo AS STRING * 14 ' "Ctrl+Shift+F12"
ControlID AS LONG
END TYPE
REDIM SHARED Caption(0 TO 100) AS STRING
REDIM SHARED __UI_TempCaptions(0 TO 100) AS STRING
REDIM SHARED Text(0 TO 100) AS STRING
REDIM SHARED __UI_TempTexts(0 TO 100) AS STRING
REDIM SHARED Mask(0 TO 100) AS STRING
REDIM SHARED __UI_TempMask(0 TO 100) AS STRING
REDIM SHARED ToolTip(0 TO 100) AS STRING
REDIM SHARED __UI_TempTips(0 TO 100) AS STRING
REDIM SHARED Control(0 TO 100) AS __UI_ControlTYPE
REDIM SHARED ControlDrawOrder(0) AS LONG
REDIM __UI_ThemeImages(0 TO 0) AS HashTableType
REDIM SHARED __UI_WordWrapHistoryTexts(0 TO 100) AS STRING
REDIM SHARED __UI_WordWrapHistoryResults(0 TO 100) AS STRING
REDIM SHARED __UI_WordWrapHistory(0 TO 100) AS __UI_WordWrapHistoryType
REDIM SHARED __UI_ThisLineChars(0) AS LONG, __UI_FocusedTextBoxChars(0) AS LONG
REDIM SHARED __UI_ActiveMenu(0 TO 100) AS LONG, __UI_ParentMenu(0 TO 100) AS LONG
REDIM SHARED __UI_KeyCombo(0 TO 100) AS __UI_KeyCombos
DIM SHARED __UI_TotalKeyCombos AS LONG, __UI_BypassKeyCombos AS _BYTE
DIM SHARED table1252$(0 TO 255), table437$(0 TO 255)
DIM SHARED __UI_MouseLeft AS INTEGER, __UI_MouseTop AS INTEGER
DIM SHARED __UI_MouseWheel AS INTEGER, __UI_MouseButtonsSwap AS _BYTE
DIM SHARED __UI_PrevMouseLeft AS INTEGER, __UI_PrevMouseTop AS INTEGER
DIM SHARED __UI_MouseButton1 AS _BYTE, __UI_MouseButton2 AS _BYTE
DIM SHARED __UI_MouseIsDown AS _BYTE, __UI_MouseDownOnID AS LONG
DIM SHARED __UI_Mouse2IsDown AS _BYTE, __UI_Mouse2DownOnID AS LONG
DIM SHARED __UI_PreviousMouseDownOnID AS LONG
DIM SHARED __UI_KeyIsDown AS _BYTE, __UI_KeyDownOnID AS LONG
DIM SHARED __UI_ShiftIsDown AS _BYTE, __UI_CtrlIsDown AS _BYTE
DIM SHARED __UI_AltIsDown AS _BYTE, __UI_ShowHotKeys AS _BYTE, __UI_AltCombo$
DIM SHARED __UI_LastMouseClick AS SINGLE, __UI_MouseDownOnScrollbar AS SINGLE
DIM SHARED __UI_DragX AS INTEGER, __UI_DragY AS INTEGER
DIM SHARED __UI_DefaultButtonID AS LONG
DIM SHARED __UI_KeyHit AS LONG, __UI_KeepFocus AS _BYTE
DIM SHARED __UI_Focus AS LONG, __UI_PreviousFocus AS LONG, __UI_KeyboardFocus AS _BYTE
DIM SHARED __UI_HoveringID AS LONG, __UI_LastHoveringID AS LONG, __UI_BelowHoveringID AS LONG
DIM SHARED __UI_IsDragging AS _BYTE, __UI_DraggingID AS LONG
DIM SHARED __UI_IsResizing AS _BYTE, __UI_ResizingID AS LONG
DIM SHARED __UI_ResizeHandleHover AS _BYTE
DIM SHARED __UI_IsSelectingText AS _BYTE, __UI_IsSelectingTextOnID AS LONG
DIM SHARED __UI_SelectedText AS STRING, __UI_SelectionLength AS LONG
DIM SHARED __UI_StateHasChanged AS _BYTE
DIM SHARED __UI_DraggingThumb AS _BYTE, __UI_ThumbDragTop AS INTEGER
DIM SHARED __UI_DraggingThumbOnID AS LONG
DIM SHARED __UI_HasInput AS _BYTE, __UI_ProcessInputTimer AS SINGLE
DIM SHARED __UI_UnloadSignal AS _BYTE, __UI_HasResized AS _BYTE
DIM SHARED __UI_ExitTriggered AS _BYTE
DIM SHARED __UI_Loaded AS _BYTE
DIM SHARED __UI_EventsTimer AS INTEGER, __UI_RefreshTimer AS INTEGER
DIM SHARED __UI_ActiveDropdownList AS LONG, __UI_ParentDropdownList AS LONG
DIM SHARED __UI_TotalActiveMenus AS LONG, __UI_ActiveMenuIsContextMenu AS _BYTE
DIM SHARED __UI_SubMenuDelay AS SINGLE, __UI_HoveringSubMenu AS _BYTE
DIM SHARED __UI_TopMenuBarItem AS LONG
DIM SHARED __UI_ActiveTipID AS LONG, __UI_TipTimer AS SINGLE, __UI_PreviousTipID AS LONG
DIM SHARED __UI_ActiveTipTop AS INTEGER, __UI_ActiveTipLeft AS INTEGER
DIM SHARED __UI_FormID AS LONG, __UI_HasMenuBar AS LONG
DIM SHARED __UI_ScrollbarWidth AS INTEGER, __UI_ScrollbarButtonHeight AS INTEGER
DIM SHARED __UI_MenuBarOffset AS INTEGER, __UI_MenuItemOffset AS INTEGER
DIM SHARED __UI_NewMenuBarTextLeft AS INTEGER, __UI_DefaultCaptionIndent AS INTEGER
DIM SHARED __UI_ForceRedraw AS _BYTE, __UI_AutoRefresh AS _BYTE
DIM SHARED __UI_CurrentTitle AS STRING
DIM SHARED __UI_DesignMode AS _BYTE, __UI_FirstSelectedID AS LONG
DIM SHARED __UI_WaitMessage AS STRING, __UI_TotalSelectedControls AS LONG
DIM SHARED __UI_WaitMessageHandle AS LONG, __UI_EditorMode AS _BYTE
DIM SHARED __UI_LastRenderedCharCount AS LONG
DIM SHARED __UI_SelectionRectangleTop AS INTEGER, __UI_SelectionRectangleLeft AS INTEGER
DIM SHARED __UI_SelectionRectangle AS _BYTE
DIM SHARED __UI_CantShowContextMenu AS _BYTE, __UI_ShowPositionAndSize AS _BYTE
DIM SHARED __UI_ShowInvisibleControls AS _BYTE, __UI_Snapped AS _BYTE
DIM SHARED __UI_SnappedByProximityX AS _BYTE, __UI_SnappedByProximityY AS _BYTE
DIM SHARED __UI_SnappedX AS INTEGER, __UI_SnappedY AS INTEGER
DIM SHARED __UI_SnappedXID AS LONG, __UI_SnappedYID AS LONG
DIM SHARED __UI_SnapLines AS _BYTE, __UI_SnapDistance AS INTEGER, __UI_SnapDistanceFromForm AS INTEGER
DIM SHARED __UI_FrameRate AS SINGLE, __UI_Font8Offset AS INTEGER, __UI_Font16Offset AS INTEGER
DIM SHARED __UI_ClipboardCheck$, __UI_MenuBarOffsetV AS INTEGER
DIM SHARED __UI_KeepScreenHidden AS _BYTE, __UI_MaxBorderSize AS INTEGER
DIM SHARED __UI_InternalContextMenus AS LONG, __UI_DidClick AS _BYTE
DIM SHARED __UI_ContextMenuSourceID AS LONG
DIM SHARED __UI_FKey(1 TO 12) AS LONG
DIM SHARED __UI_Type(0 TO 18) AS __UI_Types
$END IF

View file

@ -1,5 +0,0 @@
'Starting with v1.0, __UI_VersionNumber is actually the current build.
Const __UI_Version = "v1.4"
Const __UI_VersionNumber = 21
Const __UI_VersionIsBeta = 0
Const __UI_CopyrightSpan = "2016-2021"

29
InForm/InFormVersion.bi Normal file
View file

@ -0,0 +1,29 @@
'-----------------------------------------------------------------------------------------------------------------------
' InForm SemVer (Major.Minor.Patch). This is included by the common header file
' Copyright (c) 2024 Samuel Gomes
' Copyright (c) 2022 Fellippe Heitor
'-----------------------------------------------------------------------------------------------------------------------
$IF INFORMVERSION_BI = UNDEFINED THEN
$LET INFORMVERSION_BI = TRUE
CONST __UI_VersionMajor = "1"
CONST __UI_VersionMinor = "5"
CONST __UI_VersionPatch = "3"
CONST __UI_Version = __UI_VersionMajor + "." + __UI_VersionMinor + "." + __UI_VersionPatch
' This is only added when the file is included from UiEditor.bas
$IF UIEDITOR_BAS = DEFINED THEN
$VERSIONINFO:CompanyName='Samuel Gomes, George McGinn, Fellippe Heitor'
$VERSIONINFO:FileDescription='InForm-PE Form Designer executable'
$VERSIONINFO:InternalName='UiEditor'
$VERSIONINFO:LegalCopyright='Copyright (c) 2024 Samuel Gomes, George McGinn, Fellippe Heitor'
$VERSIONINFO:LegalTrademarks='All trademarks are property of their respective owners'
$VERSIONINFO:OriginalFilename='UiEditor.exe'
$VERSIONINFO:ProductName='InForm-PE Form Designer'
$VERSIONINFO:Web='https://github.com/a740g/InForm-PE'
$VERSIONINFO:Comments='https://github.com/a740g/InForm-PE'
$VERSIONINFO:FILEVERSION#=1,5,3,0
$VERSIONINFO:PRODUCTVERSION#=1,5,3,0
$END IF
$END IF

View file

@ -1,21 +0,0 @@
MIT License
Copyright (c) 2018 Fellippe Heitor
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

File diff suppressed because it is too large Load diff

View file

@ -227,23 +227,6 @@ SUB __UI_LoadForm
SetCaption __UI_NewID, "&Auto-name controls"
Control(__UI_NewID).Value = True
__UI_NewID = __UI_NewControl(__UI_Type_MenuItem, "OptionsMenuAutoUpdate", 155, 18, 0, 4, __UI_GetID("OptionsMenu"))
$IF WIN THEN
SetCaption __UI_NewID, "Auto-&Update"
$ELSE
SetCaption __UI_NewID, "Auto-&Update-"
$END IF
__UI_NewID = __UI_NewControl(__UI_Type_MenuItem, "OptionsMenuCheckUpdates", 155, 18, 0, 4, __UI_GetID("OptionsMenuAutoUpdate"))
SetCaption __UI_NewID, "&Check for updates at start-up"
Control(__UI_NewID).Value = True
__UI_NewID = __UI_NewControl(__UI_Type_MenuItem, "OptionsMenuDevChannel", 155, 18, 0, 4, __UI_GetID("OptionsMenuAutoUpdate"))
SetCaption __UI_NewID, "Receive &development updates-"
__UI_NewID = __UI_NewControl(__UI_Type_MenuItem, "OptionsMenuCheckUpdatesNow", 155, 18, 0, 4, __UI_GetID("OptionsMenuAutoUpdate"))
SetCaption __UI_NewID, "Check for updates &now"
$IF WIN THEN
$ELSE
__UI_NewID = __UI_NewControl(__UI_Type_MenuItem, "OptionsMenuSwapButtons", 0, 0, 0, 0, __UI_GetID("OptionsMenu"))
@ -834,9 +817,11 @@ SUB __UI_LoadForm
__UI_NewID = __UI_NewControl(__UI_Type_Button, "CancelBindBT", 80, 23, 341, 220, __UI_GetID("SetControlBinding"))
SetCaption __UI_NewID, "Cancel"
Control(__UI_NewID).CanHaveFocus = True
END SUB
SUB __UI_AssignIDs
UiEditor = __UI_GetID("UiEditor")
StatusBar = __UI_GetID("StatusBar")
FileMenu = __UI_GetID("FileMenu")
@ -981,9 +966,6 @@ SUB __UI_AssignIDs
ControlToggles = __UI_GetID("ControlToggles")
BulletOptions = __UI_GetID("BulletOptions")
BulletOptionsLB = __UI_GetID("BulletOptionsLB")
OptionsMenuCheckUpdates = __UI_GetID("OptionsMenuCheckUpdates")
OptionsMenuCheckUpdatesNow = __UI_GetID("OptionsMenuCheckUpdatesNow")
OptionsMenuDevChannel = __UI_GetID("OptionsMenuDevChannel")
BooleanOptions = __UI_GetID("BooleanOptions")
BooleanLB = __UI_GetID("BooleanLB")
FontList = __UI_GetID("FontList")
@ -1025,4 +1007,5 @@ SUB __UI_AssignIDs
TargetPropertyList = __UI_GetID("TargetPropertyList")
BindBT = __UI_GetID("BindBT")
CancelBindBT = __UI_GetID("CancelBindBT")
END SUB

File diff suppressed because it is too large Load diff

View file

@ -2,16 +2,17 @@
': InForm - GUI library for QB64 - Beta version 9
': Fellippe Heitor, 2016-2019 - fellippe@qb64.org - @fellippeheitor
'-----------------------------------------------------------
SUB __UI_LoadForm
DIM __UI_NewID AS LONG
$RESIZE:ON
__UI_NewID = __UI_NewControl(__UI_Type_Form, "Form1", 300, 300, 0, 0,0)
__UI_NewID = __UI_NewControl(__UI_Type_Form, "Form1", 300, 300, 0, 0, 0)
END SUB
SUB __UI_AssignIDs
END SUB

View file

@ -0,0 +1,192 @@
'-----------------------------------------------------------------------------------------------------------------------
' Base64 encoder, decoder & resource loading library
' Copyright (c) 2024 Samuel Gomes
'-----------------------------------------------------------------------------------------------------------------------
$IF BASE64_BAS = UNDEFINED THEN
$LET BASE64_BAS = TRUE
'-------------------------------------------------------------------------------------------------------------------
' Test code for debugging the library
'-------------------------------------------------------------------------------------------------------------------
'DEFLNG A-Z
'OPTION _EXPLICIT
'CONST ITERATIONS = 1000000
'CONST LOREM_IPSUM = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut " + _
' "labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip " + _
' "ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat " + _
' "nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum."
'DIM encTxt AS STRING, decTxt AS STRING, i AS LONG, t AS DOUBLE
'PRINT ITERATIONS; "iterations,"; LEN(LOREM_IPSUM); "bytes."
'PRINT "Base64 encode..."
't = TIMER
'FOR i = 1 TO ITERATIONS
' encTxt = Base64_Encode(LOREM_IPSUM)
'NEXT
'PRINT USING "#####.##### seconds"; TIMER - t
'PRINT "Base64 decode..."
't = TIMER
'FOR i = 1 TO ITERATIONS
' decTxt = Base64_Decode(encTxt)
'NEXT
'PRINT USING "#####.##### seconds"; TIMER - t
'IF _STRCMP(decTxt, LOREM_IPSUM) = 0 THEN
' PRINT "Passed"
'ELSE
' PRINT "Failed"
'END IF
'END
'-------------------------------------------------------------------------------------------------------------------
' Converts a normal string or binary data to a base64 string
FUNCTION Base64_Encode$ (s AS STRING)
CONST BASE64_CHARACTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
DIM srcSize AS _UNSIGNED LONG: srcSize = LEN(s)
DIM srcSize3rem AS _UNSIGNED LONG: srcSize3rem = srcSize MOD 3
DIM srcSize3mul AS _UNSIGNED LONG: srcSize3mul = srcSize - srcSize3rem
DIM buffer AS STRING: buffer = SPACE$(((srcSize + 2) \ 3) * 4) ' preallocate complete buffer
DIM j AS _UNSIGNED LONG: j = 1
DIM i AS _UNSIGNED LONG: FOR i = 1 TO srcSize3mul STEP 3
DIM char1 AS _UNSIGNED _BYTE: char1 = ASC(s, i)
DIM char2 AS _UNSIGNED _BYTE: char2 = ASC(s, i + 1)
DIM char3 AS _UNSIGNED _BYTE: char3 = ASC(s, i + 2)
ASC(buffer, j) = ASC(BASE64_CHARACTERS, 1 + (_SHR(char1, 2)))
j = j + 1
ASC(buffer, j) = ASC(BASE64_CHARACTERS, 1 + (_SHL((char1 AND 3), 4) OR _SHR(char2, 4)))
j = j + 1
ASC(buffer, j) = ASC(BASE64_CHARACTERS, 1 + (_SHL((char2 AND 15), 2) OR _SHR(char3, 6)))
j = j + 1
ASC(buffer, j) = ASC(BASE64_CHARACTERS, 1 + (char3 AND 63))
j = j + 1
NEXT i
' Add padding
IF srcSize3rem > 0 THEN
char1 = ASC(s, i)
ASC(buffer, j) = ASC(BASE64_CHARACTERS, 1 + (_SHR(char1, 2)))
j = j + 1
IF srcSize3rem = 1 THEN
ASC(buffer, j) = ASC(BASE64_CHARACTERS, 1 + (_SHL(char1 AND 3, 4)))
j = j + 1
ASC(buffer, j) = 61 ' "="
j = j + 1
ASC(buffer, j) = 61 ' "="
ELSE ' srcSize3rem = 2
char2 = ASC(s, i + 1)
ASC(buffer, j) = ASC(BASE64_CHARACTERS, 1 + (_SHL((char1 AND 3), 4) OR _SHR(char2, 4)))
j = j + 1
ASC(buffer, j) = ASC(BASE64_CHARACTERS, 1 + (_SHL(char2 AND 15, 2)))
j = j + 1
ASC(buffer, j) = 61 ' "="
END IF
END IF
Base64_Encode = buffer
END FUNCTION
' Converts a base64 string to a normal string or binary data
FUNCTION Base64_Decode$ (s AS STRING)
DIM srcSize AS _UNSIGNED LONG: srcSize = LEN(s)
DIM buffer AS STRING: buffer = SPACE$((srcSize \ 4) * 3) ' preallocate complete buffer
DIM j AS _UNSIGNED LONG: j = 1
DIM AS _UNSIGNED _BYTE index, char1, char2, char3, char4
DIM i AS _UNSIGNED LONG: FOR i = 1 TO srcSize STEP 4
index = ASC(s, i): GOSUB find_index: char1 = index
index = ASC(s, i + 1): GOSUB find_index: char2 = index
index = ASC(s, i + 2): GOSUB find_index: char3 = index
index = ASC(s, i + 3): GOSUB find_index: char4 = index
ASC(buffer, j) = _SHL(char1, 2) OR _SHR(char2, 4)
j = j + 1
ASC(buffer, j) = _SHL(char2 AND 15, 4) OR _SHR(char3, 2)
j = j + 1
ASC(buffer, j) = _SHL(char3 AND 3, 6) OR char4
j = j + 1
NEXT i
' Remove padding
IF RIGHT$(s, 2) = "==" THEN
buffer = LEFT$(buffer, LEN(buffer) - 2)
ELSEIF RIGHT$(s, 1) = "=" THEN
buffer = LEFT$(buffer, LEN(buffer) - 1)
END IF
Base64_Decode = buffer
EXIT FUNCTION
find_index:
IF index >= 65 AND index <= 90 THEN
index = index - 65
ELSEIF index >= 97 AND index <= 122 THEN
index = index - 97 + 26
ELSEIF index >= 48 AND index <= 57 THEN
index = index - 48 + 52
ELSEIF index = 43 THEN
index = 62
ELSEIF index = 47 THEN
index = 63
END IF
RETURN
END FUNCTION
' This function loads a resource directly from a string variable or constant (like the ones made by Bin2Data)
FUNCTION Base64_LoadResourceString$ (src AS STRING, ogSize AS _UNSIGNED LONG, isComp AS _BYTE)
' Decode the data
DIM buffer AS STRING: buffer = Base64_Decode(src)
' Expand the data if needed
IF isComp THEN buffer = _INFLATE$(buffer, ogSize)
Base64_LoadResourceString = buffer
END FUNCTION
' Loads a binary file encoded with Bin2Data
' Usage:
' 1. Encode the binary file with Bin2Data
' 2. Include the file or it's contents
' 3. Load the file like so:
' Restore label_generated_by_bin2data
' Dim buffer As String
' buffer = LoadResource ' buffer will now hold the contents of the file
FUNCTION Base64_LoadResourceData$
DIM ogSize AS _UNSIGNED LONG, resize AS _UNSIGNED LONG, isComp AS _BYTE
READ ogSize, resize, isComp ' read the header
DIM buffer AS STRING: buffer = SPACE$(resize) ' preallocate complete buffer
' Read the whole resource data
DIM i AS _UNSIGNED LONG: DO WHILE i < resize
DIM chunk AS STRING: READ chunk
MID$(buffer, i + 1) = chunk
i = i + LEN(chunk)
LOOP
' Decode the data
buffer = Base64_Decode(buffer)
' Expand the data if needed
IF isComp THEN buffer = _INFLATE$(buffer, ogSize)
Base64_LoadResourceData = buffer
END FUNCTION
$END IF

View file

@ -0,0 +1,949 @@
'-----------------------------------------------------------------------------------------------------------------------
' Animated GIF Player library
' Copyright (c) 2024 Samuel Gomes
'-----------------------------------------------------------------------------------------------------------------------
$IF GIFPLAY_BAS = UNDEFINED THEN
$LET GIFPLAY_BAS = TRUE
'$INCLUDE:'GIFPlay.bi'
'-------------------------------------------------------------------------------------------------------------------
' Test code for debugging the library
'-------------------------------------------------------------------------------------------------------------------
'$RESIZE:SMOOTH
'$CONSOLE
'DEFLNG A-Z
'OPTION _EXPLICIT
'CONST GIF_ID = 1
'DO
' DIM gifFileName AS STRING: gifFileName = _OPENFILEDIALOG$("Open GIF", , "*.gif|*.GIF|*.Gif", "GIF Files")
' IF LEN(gifFileName) = 0 THEN EXIT DO
' IF GIF_LoadFromFile(GIF_ID, gifFileName) THEN
' DIM surface AS LONG: surface = _NEWIMAGE(GIF_GetWidth(GIF_ID), GIF_GetHeight(GIF_ID), 32)
' SCREEN surface
' _ALLOWFULLSCREEN _SQUAREPIXELS , _SMOOTH
' GIF_Play GIF_ID
' DO
' DIM k AS LONG: k = _KEYHIT
' IF k = 32 THEN
' IF GIF_IsPlaying(GIF_ID) THEN GIF_Pause (GIF_ID) ELSE GIF_Play (GIF_ID)
' END IF
' CLS
' GIF_Draw GIF_ID
' _DISPLAY
' _LIMIT 30
' LOOP UNTIL k = 27
' SCREEN 0
' _FREEIMAGE surface
' END IF
'LOOP
'END
'-------------------------------------------------------------------------------------------------------------------
' Opens a GIF file from a buffer in memory
FUNCTION GIF_LoadFromMemory%% (Id AS LONG, buffer AS STRING)
$IF INFORM_BI = DEFINED THEN
IF Control(ID).Type <> __UI_Type_PictureBox THEN
ERROR 5
EXIT FUNCTION
END IF
$END IF
DIM sf AS StringFileType
StringFile_Create sf, buffer
GIF_LoadFromMemory = __GIF_Load(Id, sf)
END FUNCTION
' Opens a GIF file from a file on disk
FUNCTION GIF_LoadFromFile%% (Id AS LONG, fileName AS STRING)
$IF INFORM_BI = DEFINED THEN
IF Control(ID).Type <> __UI_Type_PictureBox THEN
ERROR 5
EXIT FUNCTION
END IF
$END IF
DIM sf AS StringFileType
IF StringFile_Load(sf, fileName) THEN
GIF_LoadFromFile = __GIF_Load(Id, sf)
END IF
END FUNCTION
' Free a GIF and all associated resources
SUB GIF_Free (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
SHARED __GIFPlayFrame() AS __GIFPlayFrameType
SHARED __GIF_FirstFreeFrame AS LONG
' Nothing to do if Id is invalid
IF NOT HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN EXIT SUB
' Get the slot we need to free
DIM idx AS LONG: idx = HashTable_LookupLong(__GIFPlayHashTable(), Id)
' Walk the whole animation chain to free all the frames and associated data
__GIFPlay(idx).frame = __GIFPlay(idx).firstFrame
DO
' Free the image being held by the frame
IF __GIFPlayFrame(__GIFPlay(idx).frame).image < -1 THEN
_FREEIMAGE __GIFPlayFrame(__GIFPlay(idx).frame).image
__GIFPlayFrame(__GIFPlay(idx).frame).image = 0
END IF
' Mark the frame slot as unused so that it can be reused
__GIFPlayFrame(__GIFPlay(idx).frame).isUsed = __GIF_FALSE
' Note the lowest free frame
IF __GIF_FirstFreeFrame > __GIFPlay(idx).frame THEN __GIF_FirstFreeFrame = __GIFPlay(idx).frame
' Move to the next frame
__GIFPlay(idx).frame = __GIFPlayFrame(__GIFPlay(idx).frame).nextFrame
LOOP UNTIL __GIFPlay(idx).frame = __GIFPlay(idx).firstFrame ' loop until we come back to the first frame
' Free the rendered image
IF __GIFPlay(idx).image < -1 THEN
_FREEIMAGE __GIFPlay(idx).image
__GIFPlay(idx).image = 0
END IF
' Free the saved rendered image
IF __GIFPlay(idx).savedImage < -1 THEN
_FREEIMAGE __GIFPlay(idx).savedImage
__GIFPlay(idx).savedImage = 0
END IF
' Finally mark the GIF slot as unused so that it can be reused
__GIFPlay(idx).isUsed = __GIF_FALSE
' Remove Id from the hash table
HashTable_Remove __GIFPlayHashTable(), Id
END SUB
' Returns the width of the animation in pixels
FUNCTION GIF_GetWidth~& (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
GIF_GetWidth = _WIDTH(__GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).image)
END IF
END FUNCTION
' Returns the height of the animation in pixels
FUNCTION GIF_GetHeight~& (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
GIF_GetHeight = _HEIGHT(__GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).image)
END IF
END FUNCTION
' Returns the number of currently playing frame
FUNCTION GIF_GetFrameNumber~& (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
GIF_GetFrameNumber = __GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).frameNumber
END IF
END FUNCTION
' Returns the total frames in the GIF. If this is 1 then it is a static image
FUNCTION GIF_GetTotalFrames~& (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
GIF_GetTotalFrames = __GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).frameCount
END IF
END FUNCTION
' Resume or starts playback
SUB GIF_Play (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
DIM idx AS LONG: idx = HashTable_LookupLong(__GIFPlayHashTable(), Id)
__GIFPlay(idx).isPlaying = __GIF_TRUE
__GIFPlay(idx).lastTick = __GIF_GetTicks
END IF
END SUB
' Pauses playback. That same frame is served as long as playback is paused
SUB GIF_Pause (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
__GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).isPlaying = __GIF_FALSE
END IF
END SUB
' Stops playing the GIF and resets the cursor to the first frame
SUB GIF_Stop (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
DIM idx AS LONG: idx = HashTable_LookupLong(__GIFPlayHashTable(), Id)
__GIFPlay(idx).isPlaying = __GIF_FALSE
__GIFPlay(idx).frame = __GIFPlay(idx).firstFrame
__GIFPlay(idx).frameNumber = 0
__GIFPlay(idx).loopCounter = 0
__GIFPlay(idx).elapsedTime = 0
__GIFPlay(idx).lastFrameRendered = -1
__GIFPlay(idx).hasSavedImage = __GIF_FALSE
END IF
END SUB
' Return True if GIF is currently playing
FUNCTION GIF_IsPlaying%% (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
GIF_IsPlaying = __GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).isPlaying
END IF
END FUNCTION
' This draws the current frame on the destination surface @ (0, 0) (stretching the frame if needed)
' This will also draw the overlay if the playback is stopped / paused
SUB GIF_Draw (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
$IF INFORM_BI = DEFINED THEN
BeginDraw ID
$END IF
' Get the rendered image handle
DIM renderedFrame AS LONG: renderedFrame = GIF_GetFrame(Id)
' Cache the GIF index because we'll be using this a lot
DIM idx AS LONG: idx = HashTable_LookupLong(__GIFPlayHashTable(), Id)
' Clear the surface using the background color (this will be black if the GIF has no global color table)
CLS , __GIFPlay(idx).bgColor
' Blit the rendered frame
_PUTIMAGE , renderedFrame, , , _SMOOTH
' Render the overlay if needed
IF NOT __GIFPlay(idx).isPlaying AND __GIFPlay(idx).overlayEnabled AND __GIFPlay(idx).frameCount > 1 THEN
DIM overlayImage AS LONG: overlayImage = __GIF_GetOverlayImage
_PUTIMAGE (_SHR(_WIDTH, 1) - _SHR(_WIDTH(overlayImage), 1), _SHR(_HEIGHT, 1) - _SHR(_HEIGHT(overlayImage), 1)), overlayImage
END IF
$IF INFORM_BI = DEFINED THEN
EndDraw ID
$END IF
END IF
END SUB
' This returns the current rendered frame (QB64 image) to be played
' Playback is time sensitive so frames may be skipped or the last frame may be returned
' Use this if you want to do your own rendering
' Also do not free the image. The library will do that when it is no longer needed
FUNCTION GIF_GetFrame& (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
SHARED __GIFPlayFrame() AS __GIFPlayFrameType
' Exit if Id is not valid
IF NOT HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN EXIT FUNCTION
' Cache the GIF index because we'll be using this a lot
DIM idx AS LONG: idx = HashTable_LookupLong(__GIFPlayHashTable(), Id)
' Always return the rendered image handle (since this does not change during the GIFs lifetime)
GIF_GetFrame = __GIFPlay(idx).image
' Exit if we are paused or not ready
IF NOT __GIFPlay(idx).isPlaying OR NOT __GIFPlay(idx).isReady THEN EXIT FUNCTION
' Exit if we finished a single or the specified number of loops
IF __GIFPlay(idx).loops <> 0 AND (__GIFPlay(idx).loopCounter < 0 OR __GIFPlay(idx).loopCounter >= __GIFPlay(idx).loops) THEN EXIT FUNCTION
' Fetch and store the current tick
DIM currentTick AS _UNSIGNED _INTEGER64: currentTick = __GIF_GetTicks
' Remember the last frame index
DIM lastFrameRendered AS LONG: lastFrameRendered = __GIFPlay(idx).frame
' Walk through the animation chain and find the frame we have to render based on the tick we recorded the last time
DO UNTIL currentTick < __GIFPlay(idx).lastTick + __GIFPlayFrame(__GIFPlay(idx).frame).duration
' Add the current frame duration to lastTick so that we can do frame skips if needed
__GIFPlay(idx).lastTick = __GIFPlay(idx).lastTick + __GIFPlayFrame(__GIFPlay(idx).frame).duration
' Increment elapsed time
__GIFPlay(idx).elapsedTime = __GIFPlay(idx).elapsedTime + __GIFPlayFrame(__GIFPlay(idx).frame).duration
' We crossed the duration of the current frame, so move to the next one
__GIFPlay(idx).frame = __GIFPlayFrame(__GIFPlay(idx).frame).nextFrame ' this should correctly loop back to the first frame
' Increment the frame counter and loop back to 0 if needed
__GIFPlay(idx).frameNumber = __GIFPlay(idx).frameNumber + 1
IF __GIFPlay(idx).frameNumber >= __GIFPlay(idx).frameCount THEN
__GIFPlay(idx).frameNumber = 0
__GIFPlay(idx).loopCounter = __GIFPlay(idx).loopCounter + 1
IF __GIFPlay(idx).loops < 0 THEN
__GIFPlay(idx).loopCounter = -1 ' single-shot animation
ELSE
__GIFPlay(idx).elapsedTime = 0 ' only reset the elapsed time for looping playback
END IF
END IF
LOOP
' If the last frame rendered is the same as the current frame then just return the previously rendered frame image
IF __GIFPlay(idx).frame = __GIFPlay(idx).lastFrameRendered THEN EXIT FUNCTION
' We now have the frame to display, so save the currentTick and update lastFrameRendered
__GIFPlay(idx).lastTick = currentTick
__GIFPlay(idx).lastFrameRendered = lastFrameRendered
' Take appropriate action based on the disposal method of the previous frame
IF __GIFPlay(idx).frame = __GIFPlay(idx).firstFrame THEN
' If this is the first frame, then we do not have any previous disposal method
CLS , __GIFPlay(idx).bgColor, __GIFPlay(idx).image ' clear the render image using the BG color
ELSE
SELECT CASE __GIFPlayFrame(__GIFPlayFrame(__GIFPlay(idx).frame).prevFrame).disposalMethod
CASE 2 ' Restore to background color
CLS , __GIFPlay(idx).bgColor, __GIFPlay(idx).image
_CLEARCOLOR __GIFPlay(idx).bgColor, __GIFPlay(idx).image
CASE 3 ' Restore to previous
IF __GIFPlay(idx).hasSavedImage THEN
' Copy back the saved image and unset the flag
_PUTIMAGE , __GIFPlay(idx).savedImage, __GIFPlay(idx).image
__GIFPlay(idx).hasSavedImage = __GIF_FALSE
END IF
' All other disposal methods do not require any action
END SELECT
END IF
' If the current frame's disposal method is 3 (restore to previous) then save the current rendered frame and set the flag
IF __GIFPlayFrame(__GIFPlay(idx).frame).disposalMethod = 3 THEN
_PUTIMAGE , __GIFPlay(idx).image, __GIFPlay(idx).savedImage
__GIFPlay(idx).hasSavedImage = __GIF_TRUE
END IF
' Render the frame at the correct (x, y) offset on the final image
_PUTIMAGE (__GIFPlayFrame(__GIFPlay(idx).frame).L, __GIFPlayFrame(__GIFPlay(idx).frame).T), __GIFPlayFrame(__GIFPlay(idx).frame).image, __GIFPlay(idx).image
END FUNCTION
' Returns the background color that should be used to clear the surface before drawing the final rendered frame
FUNCTION GIF_GetBackgroundColor~& (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
GIF_GetBackgroundColor = __GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).bgColor
END IF
END FUNCTION
' Returns the total runtime of the animation in ms
FUNCTION GIF_GetTotalDuration~&& (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
GIF_GetTotalDuration = __GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).duration
END IF
END FUNCTION
' Returns the total runtime of the current frame in ms
FUNCTION GIF_GetFrameDuration~&& (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
SHARED __GIFPlayFrame() AS __GIFPlayFrameType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
GIF_GetFrameDuration = __GIFPlayFrame(__GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).frame).duration
END IF
END FUNCTION
' Returns the current runtime of the animation in ms
FUNCTION GIF_GetElapsedTime~&& (Id AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
GIF_GetElapsedTime = __GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).elapsedTime
END IF
END FUNCTION
' Set the looping behavior
SUB GIF_SetLoop (Id AS LONG, loops AS LONG)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
__GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).loops = loops
END IF
END SUB
' Sets the GIF overlay to enable / disable
SUB GIF_EnableOverlay (Id AS LONG, isEnabled AS _BYTE)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
__GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).overlayEnabled = isEnabled
END IF
END SUB
' Returns TRUE if a GIF with Id is loaded
FUNCTION GIF_IsLoaded%% (Id AS LONG)
$CHECKING:OFF
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
IF HashTable_IsKeyPresent(__GIFPlayHashTable(), Id) THEN
GIF_IsLoaded = __GIFPlay(HashTable_LookupLong(__GIFPlayHashTable(), Id)).isReady
END IF
$CHECKING:ON
END FUNCTION
' Deinterlaces a raw GIF frame
SUB __GIF_DeinterlaceFrameImage (bmp AS LONG)
DIM W AS LONG: W = _WIDTH(bmp)
DIM H AS LONG: H = _HEIGHT(bmp)
DIM MX AS LONG: MX = W - 1
DIM n AS LONG: n = _NEWIMAGE(W, H, 256)
DIM AS LONG y, i
WHILE y < H
_PUTIMAGE (0, y), bmp, n, (0, i)-(MX, i)
i = i + 1
y = y + 8
WEND
y = 4
WHILE y < H
_PUTIMAGE (0, y), bmp, n, (0, i)-(MX, i)
i = i + 1
y = y + 8
WEND
y = 2
WHILE y < H
_PUTIMAGE (0, y), bmp, n, (0, i)-(MX, i)
i = i + 1
y = y + 4
WEND
y = 1
WHILE y < H
_PUTIMAGE (0, y), bmp, n, (0, i)-(MX, i)
i = i + 1
y = y + 2
WEND
_PUTIMAGE , n, bmp
_FREEIMAGE n
END SUB
' https://commandlinefanatic.com/cgi-bin/showarticle.cgi?article=art011
FUNCTION __GIF_ReadLZWCode& (sf AS StringFileType, buffer AS STRING, bitPos AS LONG, bitSize AS LONG)
DIM AS LONG code, p: p = 1
DIM i AS LONG: FOR i = 1 TO bitSize
DIM bytePos AS LONG: bytePos = _SHR(bitPos, 3) AND 255
IF bytePos = 0 THEN
DIM dataLen AS LONG: dataLen = StringFile_ReadByte(sf)
IF dataLen = 0 THEN
__GIF_ReadLZWCode = -1
EXIT FUNCTION
END IF
MID$(buffer, 257 - dataLen, dataLen) = StringFile_ReadString(sf, dataLen)
bytePos = 256 - dataLen
bitPos = _SHL(bytePos, 3)
END IF
IF ASC(buffer, 1 + bytePos) AND _SHL(1, bitPos AND 7) THEN code = code + p
p = p + p
bitPos = bitPos + 1
NEXT i
__GIF_ReadLZWCode = code
END FUNCTION
' https://stackoverflow.com/questions/26894809/gif-lzw-decompression
FUNCTION __GIF_DecodeLZW%% (sf AS StringFileType, bmpMem AS _MEM)
TYPE __LZWCodeType
c AS LONG
prefix AS LONG
length AS LONG
END TYPE
DIM codes(0 TO 4095) AS __LZWCodeType ' maximum bit size is 12
DIM origBitSize AS LONG: origBitSize = StringFile_ReadByte(sf)
DIM n AS LONG: n = 2 + _SHL(1, origBitSize)
DIM i AS LONG: WHILE i < n
codes(i).c = i
codes(i).length = 0
i = i + 1
WEND
DIM clearMarker AS LONG: clearMarker = n - 2
DIM endMarker AS LONG: endMarker = n - 1
DIM buffer AS STRING: buffer = SPACE$(256)
DIM bitSize AS LONG: bitSize = origBitSize + 1
DIM bitPos AS LONG
' Expect to read clear code as first code here
DIM prev AS LONG: prev = __GIF_ReadLZWCode(sf, buffer, bitPos, bitSize)
IF prev = -1 THEN EXIT FUNCTION
DO
DIM code AS LONG: code = __GIF_ReadLZWCode(sf, buffer, bitPos, bitSize)
IF code = -1 THEN EXIT FUNCTION
IF code = clearMarker THEN
bitSize = origBitSize
n = _SHL(1, bitSize) + 2
bitSize = bitSize + 1
prev = code
_CONTINUE
END IF
IF code = endMarker THEN EXIT DO
' Known code: ok. Else: must be doubled char
DIM c AS LONG: IF code < n THEN c = code ELSE c = prev
' Output the code
DIM outPos AS LONG: outPos = outPos + codes(c).length
i = 0
DO
_MEMPUT bmpMem, bmpMem.OFFSET + outPos - i, codes(c).c AS _UNSIGNED _BYTE
IF codes(c).length <> 0 THEN
c = codes(c).prefix
ELSE
EXIT DO
END IF
i = i + 1
LOOP
outPos = outPos + 1
' Unknown code -> must be double char
IF code >= n THEN
_MEMPUT bmpMem, bmpMem.OFFSET + outPos, codes(c).c AS _UNSIGNED _BYTE
outPos = outPos + 1
END IF
' Except after clear marker, build new code
IF prev <> clearMarker AND n < 4096 THEN
codes(n).prefix = prev
codes(n).length = codes(prev).length + 1
codes(n).c = codes(c).c
n = n + 1
END IF
' Out of bits? Increase
IF _SHL(1, bitSize) = n THEN
IF bitSize < 12 THEN bitSize = bitSize + 1
END IF
prev = code
LOOP
__GIF_DecodeLZW = __GIF_TRUE
END FUNCTION
' This applies the palette and transparency to a raw GIF frame image
' info - the GIF global and local frame data needed to prepare the frame image
' bmp - the raw frame image
SUB __GIF_PrepareFrameImage (info AS __GIFFrameType, bmp AS LONG)
' Set the 8-bit image palette
DIM AS LONG x, y
IF info.localColors = 0 THEN
' No local palette, so use the global one
WHILE y < info.globalColors
x = y * 3
_PALETTECOLOR y, _RGB32(ASC(info.globalPalette, x + 1), ASC(info.globalPalette, x + 2), ASC(info.globalPalette, x + 3)), bmp
y = y + 1
WEND
ELSE
' Use the local palette
WHILE y < info.localColors
x = y * 3
_PALETTECOLOR y, _RGB32(ASC(info.localPalette, x + 1), ASC(info.localPalette, x + 2), ASC(info.localPalette, x + 3)), bmp
y = y + 1
WEND
END IF
' Set the transparent color
IF info.transparentColor >= 0 THEN _CLEARCOLOR info.transparentColor, bmp
END SUB
' This is an internal loading function common for both memory and file loaders
FUNCTION __GIF_Load%% (Id AS LONG, sf AS StringFileType)
SHARED __GIFPlayHashTable() AS HashTableType
SHARED __GIFPlay() AS __GIFPlayType
SHARED __GIFPlayFrame() AS __GIFPlayFrameType
SHARED __GIF_FirstFreeFrame AS LONG
' Check if Id already exists and if so free it
IF GIF_IsLoaded(Id) THEN GIF_Free Id
' Check if we can read the signature at a minimum
IF StringFile_GetSize(sf) < 6 THEN EXIT FUNCTION
' Check the file signature before proceeding further
DIM buffer AS STRING: buffer = StringFile_ReadString(sf, 6)
IF buffer <> "GIF87a" AND buffer <> "GIF89a" THEN EXIT FUNCTION
' Ok, so it is a GIF. Allocate resources to load the rest of the file
DIM idx AS LONG: FOR idx = 0 TO UBOUND(__GIFPlay)
IF NOT __GIFPlay(idx).isUsed THEN EXIT FOR
NEXT idx
' No free GIF slots?
IF idx > UBOUND(__GIFPlay) THEN REDIM _PRESERVE __GIFPlay(0 TO idx) AS __GIFPlayType
__GIFPlay(idx).isUsed = __GIF_TRUE ' occupy the slot
HashTable_InsertLong __GIFPlayHashTable(), Id, idx ' add it to the hash table
' Reset some stuff
__GIFPlay(idx).isReady = __GIF_FALSE
__GIFPlay(idx).firstFrame = -1
__GIFPlay(idx).lastFrame = -1
__GIFPlay(idx).frame = -1
__GIFPlay(idx).frameCount = 0
__GIFPlay(idx).frameNumber = 0
__GIFPlay(idx).isPlaying = __GIF_FALSE
__GIFPlay(idx).loops = 0
__GIFPlay(idx).loopCounter = 0
__GIFPlay(idx).duration = 0
__GIFPlay(idx).lastTick = 0
__GIFPlay(idx).elapsedTime = 0
__GIFPlay(idx).lastFrameRendered = -1
__GIFPlay(idx).hasSavedImage = __GIF_FALSE
__GIFPlay(idx).overlayEnabled = __GIF_TRUE
' Get width and height
DIM W AS _UNSIGNED INTEGER: W = StringFile_ReadInteger(sf)
DIM H AS _UNSIGNED INTEGER: H = StringFile_ReadInteger(sf)
' Create the 32bpp rendered image using the width and height we got above
__GIFPlay(idx).image = _NEWIMAGE(W, H, 32)
__GIFPlay(idx).savedImage = _NEWIMAGE(W, H, 32)
IF __GIFPlay(idx).image >= -1 OR __GIFPlay(idx).savedImage >= -1 THEN GOTO gif_load_error
DIM i AS _UNSIGNED _BYTE: i = StringFile_ReadByte(sf)
DIM rawFrame AS __GIFFrameType
rawFrame.globalPalette = STRING$(768, 0)
rawFrame.localPalette = STRING$(768, 0)
rawFrame.transparentColor = -1 ' no transparent color
' Global color table?
IF _READBIT(i, 7) THEN rawFrame.globalColors = _SHL(1, ((i AND 7) + 1))
' Background color is only valid with a global palette
i = StringFile_ReadByte(sf)
' Skip aspect ratio
StringFile_Seek sf, StringFile_GetPosition(sf) + 1
' Read the global palette data
IF rawFrame.globalColors > 0 THEN MID$(rawFrame.globalPalette, 1, 3 * rawFrame.globalColors) = StringFile_ReadString(sf, 3 * rawFrame.globalColors)
' Get RGBA value from the global palette for the backgrond color
__GIFPlay(idx).bgColor = _RGB32(ASC(rawFrame.globalPalette, i + 1), ASC(rawFrame.globalPalette, i + 2), ASC(rawFrame.globalPalette, i + 3))
DIM frameIdx AS LONG: frameIdx = -1
DO
i = StringFile_ReadByte(sf)
SELECT CASE i
CASE &H2C ' image descriptor
' Look for a free slot from the last lowest freed index
FOR frameIdx = __GIF_FirstFreeFrame TO UBOUND(__GIFPlayFrame)
IF NOT __GIFPlayFrame(frameIdx).isUsed THEN
__GIF_FirstFreeFrame = frameIdx + 1
EXIT FOR
END IF
NEXT
IF frameIdx > UBOUND(__GIFPlayFrame) THEN
' Search from the beginning
FOR frameIdx = 0 TO UBOUND(__GIFPlayFrame)
IF NOT __GIFPlayFrame(frameIdx).isUsed THEN EXIT FOR
NEXT
END IF
' If still no free frame slot then allocate one
IF frameIdx > UBOUND(__GIFPlayFrame) THEN REDIM _PRESERVE __GIFPlayFrame(0 TO frameIdx) AS __GIFPlayFrameType
' Occupy the slot
__GIFPlayFrame(frameIdx).isUsed = __GIF_TRUE
' Read frame size and offset
__GIFPlayFrame(frameIdx).L = StringFile_ReadInteger(sf)
__GIFPlayFrame(frameIdx).T = StringFile_ReadInteger(sf)
W = StringFile_ReadInteger(sf)
H = StringFile_ReadInteger(sf)
' Create a raw frame image from the width and height we got above
__GIFPlayFrame(frameIdx).image = _NEWIMAGE(W, H, 256)
IF __GIFPlayFrame(frameIdx).image >= -1 THEN GOTO gif_load_error
i = StringFile_ReadByte(sf)
' Local palette?
IF _READBIT(i, 7) THEN
rawFrame.localColors = _SHL(1, ((i AND 7) + 1))
MID$(rawFrame.localPalette, 1, 3 * rawFrame.localColors) = StringFile_ReadString(sf, 3 * rawFrame.localColors)
END IF
' Decode the frame bitmap data
DIM mI AS _MEM: mI = _MEMIMAGE(__GIFPlayFrame(frameIdx).image)
IF mI.SIZE = 0 THEN GOTO gif_load_error
IF NOT __GIF_DecodeLZW(sf, mI) THEN
_MEMFREE mI
GOTO gif_load_error
END IF
_MEMFREE mI
' De-interlace the bitmap if it is interlaced
IF _READBIT(i, 6) THEN __GIF_DeinterlaceFrameImage __GIFPlayFrame(frameIdx).image
' Apply palette and transparency
__GIF_PrepareFrameImage rawFrame, __GIFPlayFrame(frameIdx).image
' Update GIF properties
IF __GIFPlay(idx).firstFrame = -1 THEN
' This is the first frame of the animation
__GIFPlay(idx).firstFrame = frameIdx
__GIFPlay(idx).frame = frameIdx ' the starting frame
__GIFPlayFrame(frameIdx).prevFrame = frameIdx ' make previous frame to point to this
__GIFPlayFrame(frameIdx).nextFrame = frameIdx ' make next frame to point to this
ELSE
' This is not the first frame
__GIFPlayFrame(__GIFPlay(idx).firstFrame).prevFrame = frameIdx ' update first frame's previous frame
__GIFPlayFrame(__GIFPlay(idx).lastFrame).nextFrame = frameIdx ' udpate last frames's next frame
__GIFPlayFrame(frameIdx).prevFrame = __GIFPlay(idx).lastFrame ' previous frame is the last frame
__GIFPlayFrame(frameIdx).nextFrame = __GIFPlay(idx).firstFrame ' next frame is the the first frame
END IF
__GIFPlay(idx).lastFrame = frameIdx ' make the last frame to point to this
__GIFPlayFrame(frameIdx).disposalMethod = rawFrame.disposalMethod
IF rawFrame.duration = 0 THEN rawFrame.duration = 10~% ' 0.1 seconds if no duration is specified (this behavior is from the erstwhile GIFPlay library)
__GIFPlayFrame(frameIdx).duration = 10~&& * rawFrame.duration ' convert to ticks (ms)
__GIFPlay(idx).duration = __GIFPlay(idx).duration + __GIFPlayFrame(frameIdx).duration ' add the frame duration to the global duration
__GIFPlay(idx).frameCount = __GIFPlay(idx).frameCount + 1
' Prepare for next frame
rawFrame.localColors = 0
rawFrame.localPalette = STRING$(768, 0)
rawFrame.disposalMethod = 0
rawFrame.transparentColor = -1 ' no transparent color
rawFrame.duration = 0
CASE &H21 ' extension introducer
DIM j AS _UNSIGNED _BYTE: j = StringFile_ReadByte(sf) ' extension type
i = StringFile_ReadByte(sf) ' size
IF j = &HF9 THEN ' graphic control extension
' Size must be 4
IF i <> 4 THEN GOTO gif_load_error
i = StringFile_ReadByte(sf)
rawFrame.disposalMethod = _SHR(i, 2) AND 7
rawFrame.duration = StringFile_ReadInteger(sf)
IF _READBIT(i, 0) THEN ' transparency?
rawFrame.transparentColor = StringFile_ReadByte(sf)
ELSE
StringFile_Seek sf, StringFile_GetPosition(sf) + 1
END IF
i = StringFile_ReadByte(sf) ' size
ELSEIF j = &HFF THEN ' application extension
IF i = 11 THEN
buffer = StringFile_ReadString(sf, 11)
i = StringFile_ReadByte(sf) ' size
IF _STRCMP(buffer, "NETSCAPE2.0") = 0 THEN
IF i = 3 THEN
j = StringFile_ReadByte(sf)
__GIFPlay(idx).loops = StringFile_ReadInteger(sf)
IF j <> 1 THEN __GIFPlay(idx).loops = 0
i = StringFile_ReadByte(sf) ' size
END IF
END IF
END IF
END IF
' Possibly more blocks until terminator block (0)
WHILE i > 0
StringFile_Seek sf, StringFile_GetPosition(sf) + i
i = StringFile_ReadByte(sf)
WEND
CASE &H3B ' GIF trailer
EXIT DO
END SELECT
LOOP WHILE NOT StringFile_IsEOF(sf)
' Bad / corrupt GIF?
IF __GIFPlay(idx).frameCount = 0 THEN GOTO gif_load_error
'__GIF_PrintDebugInfo idx
__GIFPlay(idx).isReady = __GIF_TRUE ' set the ready flag
' Render the first frame and then stop
GIF_Play Id
DIM dummy AS LONG: dummy = GIF_GetFrame(Id)
GIF_Stop Id
__GIF_Load = __GIF_TRUE
EXIT FUNCTION
gif_load_error:
GIF_Free Id ' use GIF_Free() to cleanup if we encountered any error
END FUNCTION
'SUB __GIF_PrintDebugInfo (index AS LONG)
' SHARED __GIFPlay() AS __GIFPlayType
' SHARED __GIFPlayFrame() AS __GIFPlayFrameType
' _ECHO "Dump for GIF:" + STR$(index) + CHR$(10)
' _ECHO "isUsed =" + STR$(__GIFPlay(index).isUsed)
' _ECHO "image =" + STR$(__GIFPlay(index).image)
' _ECHO "bgColor =" + STR$(__GIFPlay(index).bgColor)
' _ECHO "firstFrame =" + STR$(__GIFPlay(index).firstFrame)
' _ECHO "lastFrame =" + STR$(__GIFPlay(index).lastFrame)
' _ECHO "frame =" + STR$(__GIFPlay(index).frame)
' _ECHO "frameCount =" + STR$(__GIFPlay(index).frameCount)
' _ECHO "frameNumber =" + STR$(__GIFPlay(index).frameNumber)
' _ECHO "isPlaying =" + STR$(__GIFPlay(index).isPlaying)
' _ECHO "loops =" + STR$(__GIFPlay(index).loops)
' _ECHO "loopCounter =" + STR$(__GIFPlay(index).loopCounter)
' _ECHO "duration =" + STR$(__GIFPlay(index).duration)
' _ECHO "lastTick =" + STR$(__GIFPlay(index).lastTick)
' _ECHO "lastFrameRendered =" + STR$(__GIFPlay(index).lastFrameRendered)
' _ECHO "savedImage =" + STR$(__GIFPlay(index).savedImage)
' _ECHO "hasSavedImage =" + STR$(__GIFPlay(index).hasSavedImage)
' _ECHO "overlayEnabled =" + STR$(__GIFPlay(index).overlayEnabled)
' _ECHO CHR$(10) + "Walking animation chain..." + CHR$(10)
' DO
' _ECHO "Dump for frame:" + STR$(__GIFPlay(index).frame) + CHR$(10)
' _ECHO "isUsed =" + STR$(__GIFPlayFrame(__GIFPlay(index).frame).isUsed)
' _ECHO "prevFrame =" + STR$(__GIFPlayFrame(__GIFPlay(index).frame).prevFrame)
' _ECHO "nextFrame =" + STR$(__GIFPlayFrame(__GIFPlay(index).frame).nextFrame)
' _ECHO "image =" + STR$(__GIFPlayFrame(__GIFPlay(index).frame).image)
' _ECHO "L =" + STR$(__GIFPlayFrame(__GIFPlay(index).frame).L)
' _ECHO "T =" + STR$(__GIFPlayFrame(__GIFPlay(index).frame).T)
' _ECHO "disposalMethod =" + STR$(__GIFPlayFrame(__GIFPlay(index).frame).disposalMethod)
' _ECHO "duration =" + STR$(__GIFPlayFrame(__GIFPlay(index).frame).duration)
' _ECHO CHR$(10) + "Changing to next frame..."
' __GIFPlay(index).frame = __GIFPlayFrame(__GIFPlay(index).frame).nextFrame
' LOOP UNTIL __GIFPlay(index).frame = __GIFPlay(index).firstFrame
'END SUB
' This gets the GIF overlay image (real loading only happens once)
FUNCTION __GIF_GetOverlayImage&
CONST SIZE_GIFOVERLAYIMAGE_BMP_16506~& = 16506~&
CONST COMP_GIFOVERLAYIMAGE_BMP_16506%% = -1%%
CONST DATA_GIFOVERLAYIMAGE_BMP_16506 = _
"eNpy8q1yYACDKiDOAWIHKGZkUGBgZsAF/kMQjDM4gRSgfbsGjt+I4jgexj+2YU57nd27H0Nl6htD6wkzJ31hqFyFWkMVZmZm5rzjMyjfzcwLvEKj" + _
"tXTnFbyZjxn0O60WBBjDdVjDU/gAP0LwK77CW3gKa7gOY+B3c1k13Ic3ICm9gftQQ8h1BIt4GdInL2MRRxBKHcd1+BIyIF/iehzHYdWpmMXnkEPy" + _
"OWZxKgZZV2AbEohtXI5B1Di+hQTmW4z3ub3fBQncXX04Hs7CKiQnVnFWhtkfh+TM4zgrgza/AsmplZTHwh2QnLszRT8vheA/LlyObyAF8Q0u9zjm" + _
"tyEFs52wL5iFFNRsgrXMZ5CC+gwnY/JfBym462LW719BCu4rHIGtRUhJLNo+H29ASuINMxYMQ1JooIUOekYHLTQgFpromJ8V1NFGV7+HOiQjw9C6" + _
"L0VumzlOB02TvWehhTZ6VoavwX3QehXixWz7ysrK7rPPPrsXmXJfc98zGdqoa8bNzc2/f++tt97a19dJ9/tPP/20H1EPPfSQ/o0mJAOvwdVFabK7" + _
"bFHCeuSRR/ZMWxh4fuMiTBygzff+u9267XY/X3vttT33Nc3gyn08NTW1474fQP4J3ATx0LH7/eabbzbt24D7mUajEWmWQPLfhHXffT8yMrJjs6Nr" + _
"+3k00LZZAsq/jqcgCbX+u+8/++yzfc2OOgR1bSNWgPmfwoe+bd/ljig93tGCOLrd/ctvwM4dPLyL7yAJ9Rxt+/Pz8ztmnzTRc1+PYirT/Ibna/AF" + _
"5KD56Qc0f72v+ROU+V1J6JeM89v2Hy+A/Inav8mm45ht/7b/i9FBPZD2n0X/107ye0YnhP4vzfjnti3BuqShc0FdC7iPQxn/fOc/msX2ZTr/Qd2u" + _
"be2cIaD5/3oW81/tByzl5vsRZecM2R//3ucJbsLYQdc/bnv/u8616wCX2635Isrse6eRYX6r67H+uRDiqYWeo/mSjE8cN6aPzm78i5mTxbkIrl5J" + _
"8xroOlfHBbvmN+2iAwkg/6vQuhfixfRvCWj/KN7nv/x1Pc9/DfX5/GcD9ZTnP5Fp/zdkzn+/Xsrz39X1D63z8SWk4L7Eker6Z2mvfx9HXM2U+P4H" + _
"HQu2IAVDJrIlq8uKd/8TmfxqrMT3v2ndBsm526v7X6v7n6v736vnH6rnX6rnnzI+HmYCeP5tBqeW8PnH63A8wOdfX4L0yUvm+ddQq4a78QokpVdw" + _
"N2rIY+nz70tYxZN431x3/g7v40msYmlQz7//BcxY2A4="
STATIC overlayImage AS LONG
' Only do this once
IF overlayImage = 0 THEN
overlayImage = _LOADIMAGE(Base64_LoadResourceString(DATA_GIFOVERLAYIMAGE_BMP_16506, SIZE_GIFOVERLAYIMAGE_BMP_16506, COMP_GIFOVERLAYIMAGE_BMP_16506), 32, "memory")
END IF
__GIF_GetOverlayImage = overlayImage
END FUNCTION
'$INCLUDE:'HashTable.bas'
'$INCLUDE:'StringFile.bas'
'$INCLUDE:'Base64.bas'
$END IF

View file

@ -0,0 +1,70 @@
'-----------------------------------------------------------------------------------------------------------------------
' Animated GIF Player library
' Copyright (c) 2024 Samuel Gomes
'-----------------------------------------------------------------------------------------------------------------------
$IF GIFPLAY_BI = UNDEFINED THEN
$LET GIFPLAY_BI = TRUE
'$INCLUDE:'HashTable.bi'
'$INCLUDE:'StringFile.bi'
CONST __GIF_FALSE%% = 0%%, __GIF_TRUE%% = NOT __GIF_FALSE
' This is the master animation type that holds info about a complete animation
TYPE __GIFPlayType
isUsed AS _BYTE ' is this slot being used (this is only here to assist slot allocation)
isReady AS _BYTE ' this is set if the GIF is fully loaded (helps fix issues with InForm-PE TIMERs)
image AS LONG ' the rendered 32bpp frame image
bgColor AS _UNSIGNED LONG ' background color (32-bit RGBA!)
firstFrame AS LONG ' index of the first frame in the frame data array
lastFrame AS LONG ' index of the last frame in the frame data array
frame AS LONG ' index of the current frame being played
frameCount AS _UNSIGNED LONG ' total number of frames counted while loading
frameNumber AS _UNSIGNED LONG ' this is simply the number of current frame since playback (re)started
isPlaying AS _BYTE ' set to true if the animation is currently playing
loops AS LONG ' -1 = no, 0 = forever, n = that many times
loopCounter AS _UNSIGNED LONG ' this counts the number of loops
duration AS _UNSIGNED _INTEGER64 ' total duration in ticks (ms)
lastTick AS _UNSIGNED _INTEGER64 ' the tick recorded when the last frame was played
elapsedTime AS _UNSIGNED _INTEGER64 ' the time (ms) that has passed since the animation was started
lastFrameRendered AS LONG ' index of the last frame that was rendered
savedImage AS LONG ' copy of the current frame when disposal method 3 (restore to previous) is encountered
hasSavedImage AS _BYTE ' set to true if we have a valid saved frame
overlayEnabled AS _BYTE ' should the "GIF" overlay be shown / hidden when it is not playing
END TYPE
' This type holds information for a single animation frame
TYPE __GIFPlayFrameType
isUsed AS _BYTE ' is this frame slot being used?
prevFrame AS LONG ' previous frame (this will link back to the last frame if this is the first one)
nextFrame AS LONG ' next frame (this will link back to the first frame if this is the last one)
image AS LONG ' QB64 image handle
L AS _UNSIGNED INTEGER ' frame left (x offset)
T AS _UNSIGNED INTEGER ' frame top (y offset)
disposalMethod AS _UNSIGNED _BYTE ' 0 = don't care, 1 = keep, 2 = background, 3 = previous
duration AS _UNSIGNED _INTEGER64 ' frame duration in ticks (ms)
END TYPE
' This is an internal type that defines whatever is needed (except the pixel info) from a raw GIF frame data to construct a QB64 image
TYPE __GIFFrameType
globalColors AS _UNSIGNED INTEGER ' total colors in the global palette
globalPalette AS STRING * 768 ' global palette - 256 colors * 3 components
localColors AS _UNSIGNED INTEGER ' total colors in the local frame palette
localPalette AS STRING * 768 ' local frame palette - 256 colors * 3 components
disposalMethod AS _UNSIGNED _BYTE ' 0 = don't care, 1 = keep, 2 = background, 3 = previous
transparentColor AS INTEGER ' transparent color for this frame (< 0 means none)
duration AS _UNSIGNED INTEGER ' raw duration data in 1/100th seconds
END TYPE
' GetTicks returns the number of "ticks" (ms) since the program started execution where 1000 "ticks" (ms) = 1 second
DECLARE LIBRARY
FUNCTION __GIF_GetTicks~&& ALIAS "GetTicks"
END DECLARE
REDIM __GIFPlayHashTable(0 TO 0) AS HashTableType ' shared hash table to keep user supplied IDs (the values here points to indexes in __GIFPlay)
REDIM __GIFPlay(0 TO 0) AS __GIFPlayType ' main GIFPlay array - each array element is for a single GIF
REDIM __GIFPlayFrame(0 TO 0) AS __GIFPlayFrameType ' shared GIF frame array - this holds GIF frame and frame information for all loaded GIFs
DIM __GIF_FirstFreeFrame AS LONG ' index of the lowest free frame in __GIFPlayFrame
$END IF

View file

@ -0,0 +1,217 @@
'-----------------------------------------------------------------------------------------------------------------------
' A simple hash table for integers and QB64-PE handles
' Copyright (c) 2024 Samuel Gomes
'-----------------------------------------------------------------------------------------------------------------------
$IF HASHTABLE_BAS = UNDEFINED THEN
$LET HASHTABLE_BAS = TRUE
'$INCLUDE:'HashTable.bi'
'-------------------------------------------------------------------------------------------------------------------
' Test code for debugging the library
'-------------------------------------------------------------------------------------------------------------------
'DEFLNG A-Z
'OPTION _EXPLICIT
'REDIM MyHashTable(0 TO 0) AS HashTableType
'CONST TEST_LB = 1
'CONST TEST_UB = 9999999
'RANDOMIZE TIMER
'DIM myarray(TEST_LB TO TEST_UB) AS LONG, t AS DOUBLE
'DIM AS _UNSIGNED LONG k, i, x
'FOR k = 1 TO 4
' PRINT "Add element to array..."
' t = TIMER
' FOR i = TEST_UB TO TEST_LB STEP -1
' myarray(i) = x
' x = x + 1
' NEXT
' PRINT USING "#####.##### seconds"; TIMER - t
' PRINT "Add element to hash table..."
' t = TIMER
' FOR i = TEST_UB TO TEST_LB STEP -1
' HashTable_InsertLong MyHashTable(), i, myarray(i)
' NEXT
' PRINT USING "#####.##### seconds"; TIMER - t
' PRINT "Read element from array..."
' t = TIMER
' FOR i = TEST_UB TO TEST_LB STEP -1
' x = myarray(i)
' NEXT
' PRINT USING "#####.##### seconds"; TIMER - t
' PRINT "Read element from hash table..."
' t = TIMER
' FOR i = TEST_UB TO TEST_LB STEP -1
' x = HashTable_LookupLong(MyHashTable(), i)
' NEXT
' PRINT USING "#####.##### seconds"; TIMER - t
' PRINT "Remove element from hash table..."
' t = TIMER
' FOR i = TEST_UB TO TEST_LB STEP -1
' HashTable_Remove MyHashTable(), i
' NEXT
' PRINT USING "#####.##### seconds"; TIMER - t
'NEXT
'FOR i = TEST_UB TO TEST_LB STEP -1
' LOCATE , 1: PRINT "Adding key"; i; "Size:"; UBOUND(MyHashTable) + 1;
' HashTable_InsertLong MyHashTable(), i, myarray(i)
'NEXT
'PRINT
'FOR i = TEST_UB TO TEST_LB STEP -1
' LOCATE , 1: PRINT "Verifying key: "; i;
' IF HashTable_LookupLong(MyHashTable(), i) <> myarray(i) THEN
' PRINT "[fail] ";
' SLEEP 1
' ELSE
' PRINT "[pass] ";
' END IF
'NEXT
'PRINT
'FOR i = TEST_UB TO TEST_LB STEP -1
' LOCATE , 1: PRINT "Removing key"; i; "Size:"; UBOUND(MyHashTable) + 1;
' HashTable_Remove MyHashTable(), i
'NEXT
'PRINT
'HashTable_InsertLong MyHashTable(), 42, 666
'HashTable_InsertLong MyHashTable(), 7, 123454321
'HashTable_InsertLong MyHashTable(), 21, 69
'PRINT "Value for key 42:"; HashTable_LookupLong(MyHashTable(), 42)
'PRINT "Value for key 7:"; HashTable_LookupLong(MyHashTable(), 7)
'PRINT "Value for key 21:"; HashTable_LookupLong(MyHashTable(), 21)
'PRINT HashTable_IsKeyPresent(MyHashTable(), 100)
'END
'-------------------------------------------------------------------------------------------------------------------
' Simple hash function: k is the 32-bit key and l is the upper bound of the array
FUNCTION __HashTable_GetHash~& (k AS _UNSIGNED LONG, l AS _UNSIGNED LONG)
$CHECKING:OFF
' Actually this should be k MOD (l + 1)
' However, we can get away using AND because our arrays size always doubles in multiples of 2
' So, if l = 255, then (k MOD (l + 1)) = (k AND l)
' Another nice thing here is that we do not need to do the addition :)
__HashTable_GetHash = k AND l
$CHECKING:ON
END FUNCTION
' Subroutine to resize and rehash the elements in a hash table
SUB __HashTable_ResizeAndRehash (hashTable() AS HashTableType)
DIM uB AS _UNSIGNED LONG: uB = UBOUND(hashTable)
' Resize the array to double its size while preserving contents
DIM newUB AS _UNSIGNED LONG: newUB = _SHL(uB + 1, 1) - 1
REDIM _PRESERVE hashTable(0 TO newUB) AS HashTableType
' Rehash and swap all the elements
DIM i AS _UNSIGNED LONG: FOR i = 0 TO uB
IF hashTable(i).U THEN SWAP hashTable(i), hashTable(__HashTable_GetHash(hashTable(i).K, newUB))
NEXT i
END SUB
' This returns an array index in hashTable where k can be inserted
' If there is a collision it will grow the array, re-hash and copy all elements
FUNCTION __HashTable_GetInsertIndex& (hashTable() AS HashTableType, k AS _UNSIGNED LONG)
DIM uB AS _UNSIGNED LONG: uB = UBOUND(hashTable)
DIM idx AS _UNSIGNED LONG: idx = __HashTable_GetHash(k, uB)
IF hashTable(idx).U THEN
' Used slot
IF hashTable(idx).K = k THEN
' Duplicate key
__HashTable_GetInsertIndex = __HASHTABLE_KEY_EXISTS
ELSE
' Collision
__HashTable_ResizeAndRehash hashTable()
__HashTable_GetInsertIndex = __HashTable_GetInsertIndex(hashTable(), k)
END IF
ELSE
' Empty slot
__HashTable_GetInsertIndex = idx
END IF
END FUNCTION
' This function returns the index from hashTable for the key k if k is in use
FUNCTION __HashTable_GetLookupIndex& (hashTable() AS HashTableType, k AS _UNSIGNED LONG)
DIM uB AS _UNSIGNED LONG: uB = UBOUND(hashTable)
DIM idx AS _UNSIGNED LONG: idx = __HashTable_GetHash(k, uB)
IF hashTable(idx).U THEN
' Used slot
IF hashTable(idx).K = k THEN
' Key found
__HashTable_GetLookupIndex = idx
ELSE
' Unknown key
__HashTable_GetLookupIndex = __HASHTABLE_KEY_UNAVAILABLE
END IF
ELSE
' Unknown key
__HashTable_GetLookupIndex = __HASHTABLE_KEY_UNAVAILABLE
END IF
END FUNCTION
' Return TRUE if k is available in the hash table
FUNCTION HashTable_IsKeyPresent%% (hashTable() AS HashTableType, k AS _UNSIGNED LONG)
$CHECKING:OFF
HashTable_IsKeyPresent = (__HashTable_GetLookupIndex(hashTable(), k) >= 0)
$CHECKING:ON
END FUNCTION
' Remove an element from the hash table
SUB HashTable_Remove (hashTable() AS HashTableType, k AS _UNSIGNED LONG)
DIM idx AS LONG: idx = __HashTable_GetLookupIndex(hashTable(), k)
IF idx >= 0 THEN
hashTable(idx).U = __HASHTABLE_FALSE
ELSE
ERROR 9
END IF
END SUB
' Inserts a long value in the table using a key
SUB HashTable_InsertLong (hashTable() AS HashTableType, k AS _UNSIGNED LONG, v AS LONG)
DIM idx AS LONG: idx = __HashTable_GetInsertIndex(hashTable(), k)
IF idx >= 0 THEN
hashTable(idx).U = __HASHTABLE_TRUE
hashTable(idx).K = k
hashTable(idx).V = v
ELSE
ERROR 9
END IF
END SUB
' Returns the long value from the table using a key
FUNCTION HashTable_LookupLong& (hashTable() AS HashTableType, k AS _UNSIGNED LONG)
DIM idx AS LONG: idx = __HashTable_GetLookupIndex(hashTable(), k)
IF idx >= 0 THEN
HashTable_LookupLong = hashTable(idx).V
ELSE
ERROR 9
END IF
END FUNCTION
$END IF

View file

@ -0,0 +1,22 @@
'-----------------------------------------------------------------------------------------------------------------------
' A simple hash table for integers and QB64-PE handles
' Copyright (c) 2024 Samuel Gomes
'-----------------------------------------------------------------------------------------------------------------------
$IF HASHTABLE_BI = UNDEFINED THEN
$LET HASHTABLE_BI = TRUE
CONST __HASHTABLE_FALSE%% = 0%%, __HASHTABLE_TRUE%% = NOT __HASHTABLE_FALSE
CONST __HASHTABLE_KEY_EXISTS& = -1&
CONST __HASHTABLE_KEY_UNAVAILABLE& = -2&
' Hash table entry type
' To extended supported data types, add other value types after V and then write
' wrappers around __HashTable_GetInsertIndex() & __HashTable_GetLookupIndex()
TYPE HashTableType
U AS _BYTE ' used?
K AS _UNSIGNED LONG ' key
V AS LONG ' value
END TYPE
$END IF

801
InForm/extensions/Ini.bas Normal file
View file

@ -0,0 +1,801 @@
'-----------------------------------------------------------------------------------------------------------------------
' INI Manager
' Copyright (c) 2024 Samuel Gomes
' Copyright (c) 2022 Fellippe Heitor
'-----------------------------------------------------------------------------------------------------------------------
$IF INI_BAS = UNDEFINED THEN
$LET INI_BAS = TRUE
'$INCLUDE:'Ini.bi'
SUB IniSortSection (file$, __section$)
SHARED IniCODE AS LONG, IniLastKey$, IniWholeFile$
SHARED IniDisableAutoCommit AS _BYTE
REDIM Keys(1 TO 100) AS STRING
DIM TotalKeys, tempValue$, i AS LONG, Backup$, CommitBackup
IF IniFormatSection$(__section$) = "[]" THEN IniCODE = 15: EXIT SUB
DO
tempValue$ = ReadSetting(file$, __section$, "")
IF LEFT$(IniINFO$, 7) = "ERROR: " THEN EXIT SUB
IF IniCODE = 10 THEN EXIT DO
TotalKeys = TotalKeys + 1
IF TotalKeys > UBOUND(Keys) THEN
REDIM _PRESERVE Keys(1 TO UBOUND(Keys) + 100) AS STRING
END IF
Keys(TotalKeys) = IniLastKey$ + "=" + tempValue$
LOOP
REDIM _PRESERVE Keys(1 TO TotalKeys) AS STRING
IF IniArraySort(Keys()) = 0 THEN IniCODE = 23: EXIT SUB
CommitBackup = IniDisableAutoCommit
IniDisableAutoCommit = -1 'Prevent every minor change from being written to disk
Backup$ = IniWholeFile$
FOR i = 1 TO TotalKeys
IniDeleteKey file$, __section$, LEFT$(Keys(i), INSTR(Keys(i), "=") - 1)
IF LEFT$(IniINFO$, 7) = "ERROR: " THEN
IniDisableAutoCommit = CommitBackup
IniWholeFile$ = Backup$
EXIT SUB
END IF
NEXT
FOR i = 1 TO TotalKeys
WriteSetting file$, __section$, LEFT$(Keys(i), INSTR(Keys(i), "=") - 1), MID$(Keys(i), INSTR(Keys(i), "=") + 1)
IF LEFT$(IniINFO$, 7) = "ERROR: " THEN
IniDisableAutoCommit = CommitBackup
IniWholeFile$ = Backup$
EXIT SUB
END IF
NEXT
IniDisableAutoCommit = CommitBackup 'Restore writing to disk (or previously set state) and
IniCommit ' commit changes.
IniCODE = 22
END SUB
SUB IniDeleteSection (file$, __section$)
SHARED IniNewFile$, IniCODE AS LONG, currentIniFileName$
SHARED IniLF$, IniWholeFile$, currentIniFileLOF AS _UNSIGNED LONG
IniLoad file$
IF IniCODE THEN EXIT SUB
DIM a$
IniCODE = 0
a$ = IniGetSection(__section$)
IF IniCODE THEN EXIT SUB
IniNewFile$ = LEFT$(IniWholeFile$, INSTR(IniWholeFile$, a$) - 1)
IniNewFile$ = IniNewFile$ + MID$(IniWholeFile$, INSTR(IniWholeFile$, a$) + LEN(a$ + IniLF$))
IniCommit
IniCODE = 13
END SUB
SUB IniDeleteKey (file$, __section$, __key$)
SHARED IniPosition AS _UNSIGNED LONG, IniCODE AS LONG
SHARED IniLF$, IniWholeFile$, IniSectionData$
SHARED IniLastSection$, IniLastKey$, IniNewFile$
DIM tempValue$
DIM section$, key$
DIM FoundLF AS _UNSIGNED LONG
IniCODE = 0
'prepare variables for the write operation
section$ = IniFormatSection$(__section$)
IF IniCODE THEN EXIT SUB
key$ = LTRIM$(RTRIM$(__key$))
IF key$ = "" THEN IniCODE = 12: EXIT SUB
IniLastKey$ = key$
'Read the existing key to fill IniPosition
tempValue$ = ReadSetting$(file$, section$, key$)
IF IniCODE > 0 AND IniCODE <> 2 THEN EXIT SUB 'key not found
'map IniPosition (set in the section block) to the global file position
IniPosition = INSTR(IniWholeFile$, IniSectionData$) + IniPosition - 1
FoundLF = INSTR(IniPosition, IniWholeFile$, IniLF$)
IF FoundLF = 0 THEN FoundLF = LEN(IniWholeFile$)
IniNewFile$ = LEFT$(IniWholeFile$, IniPosition - 1) + MID$(IniWholeFile$, FoundLF + LEN(IniLF$))
IniCommit
IniCODE = 19
END SUB
SUB IniMoveKey (file$, __section$, __key$, __newsection$)
'A move operation is a copy operation + a delete operation
SHARED IniCODE AS LONG
DIM tempValue$
tempValue$ = ReadSetting(file$, __section$, __key$)
IF IniCODE > 0 AND IniCODE <> 2 THEN EXIT SUB
WriteSetting file$, __newsection$, __key$, tempValue$
IF IniCODE > 0 AND IniCODE <> 2 AND IniCODE <> 7 AND IniCODE <> 9 THEN EXIT SUB
IniDeleteKey file$, __section$, __key$
IF IniCODE = 19 THEN IniCODE = 20
END SUB
SUB IniCommit
SHARED currentIniFileName$, IniWholeFile$, currentIniFileLOF AS _UNSIGNED LONG
SHARED IniNewFile$, IniDisableAutoCommit AS _BYTE, IniCODE AS LONG
SHARED LoadedFiles$
IF currentIniFileName$ = "" THEN IniCODE = 18: EXIT SUB
IniWholeFile$ = IniNewFile$
currentIniFileLOF = LEN(IniNewFile$)
IF NOT IniDisableAutoCommit THEN
DIM fileNum AS INTEGER, findFile AS INTEGER
'search LoadedFiles$, so we use the same file handle every time
findFile = INSTR(LoadedFiles$, "@" + currentIniFileName$ + "@")
IF findFile = 0 THEN
fileNum = FREEFILE
LoadedFiles$ = LoadedFiles$ + "@" + MKI$(fileNum) + "@" + currentIniFileName$ + "@"
ELSE
fileNum = CVI(MID$(LoadedFiles$, findFile - 2, 2))
CLOSE fileNum
END IF
OPEN currentIniFileName$ FOR BINARY AS #fileNum
IF LEN(IniWholeFile$) < LOF(fileNum) THEN
CLOSE fileNum
OPEN currentIniFileName$ FOR OUTPUT AS #fileNum: CLOSE #fileNum
OPEN currentIniFileName$ FOR BINARY AS #fileNum
END IF
PUT #fileNum, 1, IniNewFile$
CLOSE #fileNum 'flush
OPEN currentIniFileName$ FOR BINARY AS #fileNum 'keep open
END IF
END SUB
FUNCTION IniGetSection$ (__section$)
SHARED IniPosition AS _UNSIGNED LONG, IniCODE AS LONG, currentIniFileName$
SHARED IniLF$, IniWholeFile$, currentIniFileLOF AS _UNSIGNED LONG
IF currentIniFileName$ = "" THEN IniCODE = 18: EXIT FUNCTION
IF currentIniFileLOF = 0 OR LEN(LTRIM$(RTRIM$(IniWholeFile$))) = 0 THEN IniCODE = 17: EXIT FUNCTION
IniCODE = 0
DIM section$, foundSection AS _UNSIGNED LONG, endSection AS _UNSIGNED LONG
DIM i AS _UNSIGNED LONG, Bracket1 AS _UNSIGNED LONG, sectionStart AS _UNSIGNED LONG
DIM inQuote AS _BYTE
section$ = IniFormatSection$(__section$)
IF IniCODE THEN EXIT FUNCTION
IF section$ = "[]" THEN
'fetch the "global" section, if present
sectionStart = INSTR(IniWholeFile$, "[")
IF sectionStart = 0 THEN IniGetSection$ = IniWholeFile$: EXIT FUNCTION
FOR i = sectionStart - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN foundSection = i + 1: EXIT FOR
IF ASC(IniWholeFile$, i) <> 32 THEN EXIT FOR
NEXT
IF i = 0 THEN foundSection = 1
IniGetSection$ = LEFT$(IniWholeFile$, foundSection - 1)
ELSE
DO
sectionStart = INSTR(sectionStart + 1, LCASE$(IniWholeFile$), LCASE$(section$))
IF sectionStart = 0 THEN IniCODE = 14: EXIT DO
'make sure it's a valid section header
foundSection = 0
FOR i = sectionStart - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN foundSection = i + 1: EXIT FOR
IF ASC(IniWholeFile$, i) <> 32 THEN EXIT FOR
NEXT
IF i = 0 THEN foundSection = 1
IF foundSection > 0 THEN
'we found it; time to identify where this section ends
'(either another [section] or the end of the file
Bracket1 = sectionStart
checkAgain:
Bracket1 = INSTR(Bracket1 + 1, IniWholeFile$, "[")
IF Bracket1 > 0 THEN
'found a bracket; check if it's inside quotes
inQuote = 0
FOR i = 1 TO Bracket1 - 1
IF ASC(IniWholeFile$, i) = 34 THEN inQuote = NOT inQuote
NEXT
IF inQuote THEN GOTO checkAgain
FOR i = Bracket1 - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN endSection = i + 1 - LEN(IniLF$): EXIT FOR
IF ASC(IniWholeFile$, i) = 61 THEN GOTO checkAgain 'bracket is inside a key's value
IF i <= foundSection THEN EXIT FOR
NEXT
IniGetSection$ = MID$(IniWholeFile$, foundSection, endSection - foundSection)
ELSE
IniGetSection$ = MID$(IniWholeFile$, foundSection)
END IF
EXIT FUNCTION
END IF
LOOP
END IF
END FUNCTION
FUNCTION IniFormatSection$ (__section$)
SHARED IniCODE AS LONG
DIM section$
section$ = LTRIM$(RTRIM$(__section$))
'sections are in the format [section name] - add brackets if not passed
IF LEFT$(section$, 1) <> "[" THEN section$ = "[" + section$
IF RIGHT$(section$, 1) <> "]" THEN section$ = section$ + "]"
IF INSTR(MID$(section$, 2, LEN(section$) - 3), "[") OR INSTR(MID$(section$, 2, LEN(section$) - 3), "]") THEN
IniCODE = 15
EXIT FUNCTION
END IF
IniFormatSection$ = section$
END FUNCTION
FUNCTION ReadSetting$ (file$, __section$, __key$)
SHARED IniLastSection$, IniLastKey$, IniWholeFile$, IniLF$
SHARED IniPosition AS _UNSIGNED LONG, IniSectionData$
SHARED IniCODE AS LONG, IniAllowBasicComments AS _BYTE
SHARED currentIniFileLOF AS _UNSIGNED LONG
IniLoad file$
IF IniCODE THEN EXIT FUNCTION
IF currentIniFileLOF = 0 OR LEN(LTRIM$(RTRIM$(IniWholeFile$))) = 0 THEN IniCODE = 17: EXIT FUNCTION
DIM Equal AS _UNSIGNED LONG, tempValue$, key$, section$
DIM Quote AS _UNSIGNED LONG, Comment AS _UNSIGNED LONG
DIM i AS LONG, FoundLF AS _UNSIGNED LONG
section$ = IniFormatSection(__section$)
IF IniCODE THEN EXIT FUNCTION
'fetch the desired section$
IniSectionData$ = IniGetSection(section$)
IF IniCODE > 0 AND IniCODE <> 17 THEN EXIT FUNCTION
IF LEN(IniSectionData$) = 0 AND section$ <> "[]" THEN IniCODE = 14: EXIT FUNCTION
IniLastSection$ = section$
IniPosition = 0
key$ = LTRIM$(RTRIM$(__key$))
IniLastKey$ = ""
IF key$ = "" THEN
IF section$ = "[]" THEN IniSectionData$ = IniWholeFile$
key$ = IniNextKey
IF IniCODE THEN EXIT FUNCTION
IF key$ = "" THEN
IniCODE = 10
EXIT FUNCTION
END IF
END IF
IF LEFT$(key$, 1) = ";" OR LEFT$(key$, 1) = "'" OR INSTR(key$, "[") > 0 OR INSTR(key$, "]") > 0 OR INSTR(key$, "=") > 0 THEN
IniCODE = 12
EXIT FUNCTION
END IF
IniLastKey$ = key$
IF IniPosition > 0 THEN Equal = IniPosition: GOTO KeyFound
CheckKey:
IniPosition = INSTR(IniPosition + 1, LCASE$(IniSectionData$), LCASE$(key$))
IF IniPosition > 0 THEN
'identify if this occurrence is actually a key and not part of a key name/value
FOR i = IniPosition - 1 TO 1 STEP -1
IF ASC(IniSectionData$, i) = 10 THEN EXIT FOR
IF ASC(IniSectionData$, i) <> 10 AND ASC(IniSectionData$, i) <> 32 THEN
'not a key
GOTO CheckKey
END IF
NEXT
'check if there's nothing but an equal sign ahead
FOR i = IniPosition + LEN(key$) TO LEN(IniSectionData$)
IF ASC(IniSectionData$, i) = ASC("=") THEN EXIT FOR
IF ASC(IniSectionData$, i) <> ASC("=") AND ASC(IniSectionData$, i) <> 32 THEN
'not the key
GOTO CheckKey
END IF
NEXT
'so far so good; check if there is an assignment
Equal = INSTR(IniPosition, IniSectionData$, "=")
KeyFound:
FoundLF = INSTR(IniPosition, IniSectionData$, IniLF$)
IF FoundLF > 0 THEN
IF Equal > FoundLF THEN GOTO CheckKey
ELSE
FoundLF = LEN(IniSectionData$) + 1
IF Equal = 0 THEN GOTO CheckKey
END IF
tempValue$ = LTRIM$(RTRIM$(MID$(IniSectionData$, Equal + 1, FoundLF - Equal - 1)))
IF LEN(tempValue$) > 0 THEN
IF LEFT$(tempValue$, 1) = CHR$(34) THEN
tempValue$ = MID$(tempValue$, 2)
Quote = INSTR(tempValue$, CHR$(34))
IF Quote > 0 THEN
tempValue$ = LEFT$(tempValue$, Quote - 1)
END IF
ELSE
IF IniAllowBasicComments THEN Comment = INSTR(tempValue$, "'") 'BASIC style comments accepted
IF Comment = 0 THEN Comment = INSTR(tempValue$, ";")
IF Comment > 0 THEN
tempValue$ = LTRIM$(RTRIM$(LEFT$(tempValue$, Comment - 1)))
END IF
END IF
ELSE
IniCODE = 2
END IF
ELSE
IniCODE = 3
EXIT FUNCTION
END IF
ReadSetting$ = tempValue$
IniLastSection$ = IniCurrentSection$
END FUNCTION
FUNCTION IniCurrentSection$
SHARED IniPosition AS _UNSIGNED LONG, IniSectionData$, IniWholeFile$
DIM GlobalPosition AS _UNSIGNED LONG, i AS _UNSIGNED LONG
DIM ClosingBracket AS _UNSIGNED LONG
GlobalPosition = INSTR(IniWholeFile$, IniSectionData$) + IniPosition - 1
CheckSection:
FOR i = GlobalPosition - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = ASC("[") THEN
GlobalPosition = i: EXIT FOR
END IF
NEXT
IF i = 0 THEN IniCurrentSection$ = "[]": EXIT FUNCTION
'identify if this occurrence is actually a section header and not something else
FOR i = GlobalPosition - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN EXIT FOR
IF ASC(IniWholeFile$, i) <> 10 AND ASC(IniWholeFile$, i) <> 32 THEN
'not a section header
GOTO CheckSection
END IF
NEXT
ClosingBracket = INSTR(GlobalPosition, IniWholeFile$, "]")
IF ClosingBracket > 0 THEN
IniCurrentSection$ = MID$(IniWholeFile$, GlobalPosition, ClosingBracket - GlobalPosition + 1)
END IF
END FUNCTION
SUB WriteSetting (file$, __section$, __key$, __value$)
SHARED IniPosition AS _UNSIGNED LONG, IniCODE AS LONG, currentIniFileName$
SHARED IniLF$, IniWholeFile$, IniSectionData$
SHARED IniLastSection$, IniLastKey$, IniNewFile$
DIM tempValue$, section$, key$, value$
IniCODE = 0
'prepare variables for the write operation
section$ = IniFormatSection$(__section$)
IF IniCODE THEN EXIT SUB
key$ = LTRIM$(RTRIM$(__key$))
IF key$ = "" THEN IniCODE = 12: EXIT SUB
IniLastKey$ = key$
value$ = LTRIM$(RTRIM$(__value$))
IF LTRIM$(STR$(VAL(value$))) <> value$ THEN
'if not a numeric value and value contains spaces, add quotation marks
IF INSTR(value$, CHR$(32)) THEN value$ = CHR$(34) + value$ + CHR$(34)
END IF
'Read the existing key to fill IniPosition
tempValue$ = ReadSetting$(file$, section$, key$)
'map IniPosition (set in the section block) to the global file position
IniPosition = INSTR(IniWholeFile$, IniSectionData$) + IniPosition - 1
IF IniCODE = 1 OR IniCODE = 17 THEN
'file not found or empty; create a new one
IF file$ = "" THEN file$ = currentIniFileName$
IF file$ = "" THEN IniCODE = 21: EXIT SUB
currentIniFileName$ = file$
IF section$ <> "[]" THEN
IniNewFile$ = section$ + IniLF$
END IF
IniNewFile$ = IniNewFile$ + key$ + "=" + value$
IniCODE = 0
IniCommit
IniLoad file$
IF IniCODE = 0 THEN IniCODE = 11
IniLastSection$ = section$
EXIT SUB
END IF
IF IniCODE = 0 OR IniCODE = 2 THEN 'key found and read back; write new value$
IF LCASE$(IniLastSection$) = LCASE$(section$) THEN
IF LTRIM$(RTRIM$(__value$)) = tempValue$ AND LEN(LTRIM$(RTRIM$(__value$))) > 0 THEN
'identical values skip the writing routine
IniCODE = 8
EXIT SUB
END IF
DIM nextLine AS _UNSIGNED LONG
nextLine = INSTR(IniPosition + 1, IniWholeFile$, IniLF$)
'create new file contents
IniNewFile$ = LEFT$(IniWholeFile$, IniPosition - 1)
IniNewFile$ = IniNewFile$ + key$ + "=" + value$
IF nextLine > 0 THEN
IniNewFile$ = IniNewFile$ + MID$(IniWholeFile$, nextLine)
END IF
IniCommit
IniCODE = 4
END IF
ELSEIF IniCODE = 3 OR IniCODE = 14 THEN 'Key not found, Section not found
IniCODE = 0
IF LCASE$(IniLastSection$) = LCASE$(section$) THEN
'find this section$ in the current ini file;
DIM Bracket1 AS _UNSIGNED LONG
DIM beginSection AS _UNSIGNED LONG, endSection AS _UNSIGNED LONG
DIM i AS _UNSIGNED LONG
beginSection = 0
endSection = 0
CheckSection:
beginSection = INSTR(beginSection + 1, LCASE$(IniWholeFile$), LCASE$(section$))
IF beginSection = 0 THEN GOTO CreateSection
'identify if this occurrence is actually the section header and not something else
FOR i = beginSection - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN EXIT FOR
IF ASC(IniWholeFile$, i) <> 10 AND ASC(IniWholeFile$, i) <> 32 THEN
'not the section header
GOTO CheckSection
END IF
NEXT
'we found it; time to identify where this section ends
'(either another [section], a blank line or the end of the file
Bracket1 = INSTR(beginSection + 1, IniWholeFile$, "[")
IF Bracket1 > 0 THEN
FOR i = Bracket1 - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN endSection = i + 1 - LEN(IniLF$): EXIT FOR
IF i <= beginSection THEN EXIT FOR
NEXT
END IF
IF endSection > 0 THEN
'add values to the end of the specified section$
IniNewFile$ = LEFT$(IniWholeFile$, endSection - 1)
IniNewFile$ = IniNewFile$ + key$ + "=" + value$ + IniLF$
IF MID$(IniWholeFile$, endSection, LEN(IniLF$)) <> IniLF$ THEN IniNewFile$ = IniNewFile$ + IniLF$
IniNewFile$ = IniNewFile$ + MID$(IniWholeFile$, endSection)
ELSE
'add values to the end of the file
IniNewFile$ = IniWholeFile$
IF RIGHT$(IniNewFile$, LEN(IniLF$)) = IniLF$ THEN
IniNewFile$ = IniNewFile$ + key$ + "=" + value$
ELSE
IniNewFile$ = IniNewFile$ + IniLF$ + key$ + "=" + value$
END IF
END IF
IniCommit
IF IniCODE = 0 THEN IniCODE = 7
EXIT SUB
ELSE
CreateSection:
IniNewFile$ = IniWholeFile$
IF section$ = "[]" THEN GOTO WriteAtTop
IF RIGHT$(IniNewFile$, LEN(IniLF$) * 2) = IniLF$ + IniLF$ THEN
IniNewFile$ = IniNewFile$ + section$ + IniLF$ + key$ + "=" + value$ + IniLF$
ELSEIF RIGHT$(IniNewFile$, LEN(IniLF$)) = IniLF$ THEN
IniNewFile$ = IniNewFile$ + IniLF$ + section$ + IniLF$ + key$ + "=" + value$ + IniLF$
ELSE
IniNewFile$ = IniNewFile$ + IniLF$ + IniLF$ + section$ + IniLF$ + key$ + "=" + value$ + IniLF$
END IF
IniCommit
IF IniCODE = 0 THEN IniCODE = 9 ELSE IniCODE = 16
EXIT SUB
END IF
'if not found, key$=value$ is written to the beginning of the file
WriteAtTop:
IniNewFile$ = key$ + "=" + value$ + IniLF$
IF LEFT$(LTRIM$(IniWholeFile$), 1) = "[" THEN IniNewFile$ = IniNewFile$ + IniLF$
IniNewFile$ = IniNewFile$ + IniWholeFile$
IniCommit
IniCODE = 5
END IF
END SUB
SUB IniSetForceReload (state AS _BYTE)
SHARED IniForceReload AS _BYTE
IF state THEN
IniForceReload = -1
ELSE
IniForceReload = 0
END IF
END SUB
SUB IniClose
SHARED IniDisableAutoCommit AS _BYTE, currentIniFileName$
SHARED LoadedFiles$
DIM findFile AS INTEGER, fileNum AS INTEGER
IF currentIniFileName$ = "" THEN EXIT SUB
'search LoadedFiles$, so we use the same file handle every time
findFile = INSTR(LoadedFiles$, "@" + currentIniFileName$ + "@")
IF findFile = 0 THEN
'not open; nothing to close
EXIT SUB
ELSE
fileNum = CVI(MID$(LoadedFiles$, findFile - 2, 2))
CLOSE fileNum
END IF
IniDisableAutoCommit = 0
IniCommit
currentIniFileName$ = ""
END SUB
SUB IniLoad (file$)
SHARED IniCODE AS LONG, currentIniFileName$, IniLF$, IniWholeFile$
SHARED currentIniFileLOF AS _UNSIGNED LONG
SHARED IniForceReload AS _BYTE
SHARED LoadedFiles$
DIM fileNum AS INTEGER, findFile AS INTEGER
'Error messages are returned with IniCODE
'Error descriptions can be fetched with function IniINFO$
IniCODE = 0
IF file$ <> "" AND currentIniFileName$ <> file$ THEN currentIniFileName$ = ""
IF IniForceReload AND LEN(currentIniFileName$) > 0 THEN
file$ = currentIniFileName$
currentIniFileName$ = ""
END IF
'Passing an empty file$ is allowed if user already
'passed a valid file in this session.
IF currentIniFileName$ = "" THEN
'initialization
IF _FILEEXISTS(file$) THEN
currentIniFileName$ = file$
'add to LoadedFiles$, so we use the same file handle every time
findFile = INSTR(LoadedFiles$, "@" + file$ + "@")
IF findFile = 0 THEN
fileNum = FREEFILE
LoadedFiles$ = LoadedFiles$ + "@" + MKI$(fileNum) + "@" + file$ + "@"
ELSE
fileNum = CVI(MID$(LoadedFiles$, findFile - 2, 2))
END IF
'Load file into memory
CLOSE fileNum
OPEN currentIniFileName$ FOR BINARY AS #fileNum
currentIniFileLOF = LOF(fileNum)
IniWholeFile$ = SPACE$(currentIniFileLOF)
GET #fileNum, 1, IniWholeFile$
'Check if this ini file uses CRLF or LF
IF INSTR(IniWholeFile$, CHR$(13)) THEN IniLF$ = CHR$(13) + CHR$(10) ELSE IniLF$ = CHR$(10)
ELSE
IniFileNotFound:
IniCODE = 1
$IF WIN THEN
IniLF$ = CHR$(13) + CHR$(10)
$ELSE
IniLF$ = CHR$(10)
$END IF
EXIT SUB
END IF
ELSEIF NOT _FILEEXISTS(currentIniFileName$) THEN
currentIniFileName$ = ""
GOTO IniFileNotFound
END IF
END SUB
FUNCTION IniNextKey$
SHARED IniCODE AS LONG, IniLF$, currentIniFileName$, IniSectionData$
SHARED IniPosition AS _UNSIGNED LONG
STATIC lastDataBlock$, position AS _UNSIGNED LONG, tempLF$
IF currentIniFileName$ = "" THEN IniCODE = 18: EXIT FUNCTION
IF IniSectionData$ <> lastDataBlock$ THEN
position = 0
lastDataBlock$ = IniSectionData$
'data blocks must end with a line feed for parsing purposes
IF RIGHT$(IniSectionData$, LEN(IniLF$)) <> IniLF$ THEN tempLF$ = IniLF$ ELSE tempLF$ = ""
END IF
DIM Equal AS _UNSIGNED LONG, tempKey$
FindKey:
Equal = INSTR(position, IniSectionData$ + tempLF$, "=")
IF Equal = 0 THEN position = 0: EXIT FUNCTION
tempKey$ = LTRIM$(RTRIM$(MID$(IniSectionData$ + tempLF$, position + 1, Equal - position - 1)))
IF INSTR(tempKey$, CHR$(10)) > 0 THEN
position = position + INSTR(tempKey$, CHR$(10)) + 1
tempKey$ = MID$(tempKey$, INSTR(tempKey$, CHR$(10)) + 1)
END IF
DO WHILE LEFT$(tempKey$, LEN(IniLF$)) = IniLF$
tempKey$ = MID$(tempKey$, LEN(IniLF$) + 1)
position = position + LEN(IniLF$)
LOOP
position = INSTR(position + 1, IniSectionData$ + tempLF$, IniLF$)
IF LEFT$(tempKey$, 1) = ";" OR LEFT$(tempKey$, 1) = "'" OR INSTR(tempKey$, "[") > 0 OR INSTR(tempKey$, "]") > 0 OR INSTR(tempKey$, "=") > 0 THEN
GOTO FindKey
END IF
IniNextKey$ = tempKey$
IniPosition = Equal
END FUNCTION
FUNCTION IniNextSection$ (file$)
SHARED IniCODE AS LONG, IniLF$, IniWholeFile$
STATIC sectionStart AS _UNSIGNED LONG
IniLoad file$
IF LEFT$(IniINFO$, 6) = "ERROR:" THEN EXIT FUNCTION
IniCODE = 0
DIM foundSection AS _UNSIGNED LONG, endSection AS _UNSIGNED LONG
DIM i AS _UNSIGNED LONG, Bracket1 AS _UNSIGNED LONG, Bracket2 AS _UNSIGNED LONG
FindNext:
sectionStart = INSTR(sectionStart + 1, IniWholeFile$, "[")
IF sectionStart = 0 THEN IniCODE = 24: EXIT FUNCTION
'make sure it's a valid section header
foundSection = 0
FOR i = sectionStart - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN foundSection = i + 1: EXIT FOR
IF ASC(IniWholeFile$, i) <> 32 THEN GOTO FindNext
NEXT
IF i = 0 THEN foundSection = 1
IF foundSection > 0 THEN
'we found it; time to identify where this section ends
'(either another [section] or the end of the file
Bracket2 = INSTR(sectionStart + 1, IniWholeFile$, "]")
IF Bracket2 = 0 THEN IniCODE = 24: EXIT FUNCTION
Bracket1 = INSTR(sectionStart + 1, IniWholeFile$, "[")
IF Bracket1 > 0 THEN
FOR i = Bracket1 - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN endSection = i + 1 - LEN(IniLF$): EXIT FOR
IF i <= foundSection THEN EXIT FOR
NEXT
IniNextSection$ = MID$(IniWholeFile$, foundSection, Bracket2 - foundSection + 1)
ELSE
IniNextSection$ = MID$(IniWholeFile$, foundSection, Bracket2 - foundSection + 1)
IniCODE = 24
sectionStart = 0
END IF
ELSE
IniCODE = 24
END IF
END FUNCTION
FUNCTION IniINFO$
SHARED IniCODE AS LONG
SELECT CASE IniCODE
CASE 0: IniINFO$ = "Operation successful"
CASE 1: IniINFO$ = "ERROR: File not found"
CASE 2: IniINFO$ = "Empty value"
CASE 3: IniINFO$ = "ERROR: Key not found"
CASE 4: IniINFO$ = "Key updated"
CASE 5: IniINFO$ = "Global key created"
CASE 7: IniINFO$ = "Key created in existing section"
CASE 8: IniINFO$ = "No changes applied (same value)"
CASE 9: IniINFO$ = "New section created; key created"
CASE 10: IniINFO$ = "No more keys"
CASE 11: IniINFO$ = "File created; new key added"
CASE 12: IniINFO$ = "ERROR: Invalid key"
CASE 13: IniINFO$ = "Section deleted"
CASE 14: IniINFO$ = "ERROR: Section not found"
CASE 15: IniINFO$ = "ERROR: Invalid section"
CASE 16: IniINFO$ = "New section created; existing key moved"
CASE 17: IniINFO$ = "ERROR: Empty file"
CASE 18: IniINFO$ = "ERROR: No file open"
CASE 19: IniINFO$ = "Key deleted"
CASE 20: IniINFO$ = "Key moved"
CASE 21: IniINFO$ = "ERROR: Invalid file name/path"
CASE 22: IniINFO$ = "Section sorted"
CASE 23: IniINFO$ = "No changes applied; section already sorted"
CASE 24: IniINFO$ = "No more sections"
CASE ELSE: IniINFO$ = "ERROR: <invalid error code>"
END SELECT
END FUNCTION
'Written in BASIC by Luke Ceddia for ide_methods.bas (QB64)
'After Cormen, Leiserson, Rivest & Stein "Introduction To Algoritms" via Wikipedia
'Adapted for use in .INI Manager
FUNCTION IniArraySort%% (arr() AS STRING)
DIM i&, x$, j&, moves&
FOR i& = LBOUND(arr) + 1 TO UBOUND(arr)
x$ = arr(i&)
j& = i& - 1
WHILE j& >= LBOUND(arr)
IF arr(j&) <= x$ THEN EXIT WHILE
moves& = moves& + 1
arr$(j& + 1) = arr$(j&)
j& = j& - 1
WEND
arr$(j& + 1) = x$
NEXT i&
'Returns -1 (true) if any changes were made
IniArraySort%% = moves& > 0
END FUNCTION
$END IF

31
InForm/extensions/Ini.bi Normal file
View file

@ -0,0 +1,31 @@
'-----------------------------------------------------------------------------------------------------------------------
' INI Manager
' Copyright (c) 2024 Samuel Gomes
' Copyright (c) 2022 Fellippe Heitor
'-----------------------------------------------------------------------------------------------------------------------
$IF INI_BI = UNDEFINED THEN
$LET INI_BI = TRUE
' TODO:
' We should put all of this stuff into a single state type and then have just a single global to avoid possible name collisions.
' That should also let us make the library load multiple INI files at the same time like the GIFPlayer library.
' INI routines without namespace like prefix should also be prefixed with the "Ini_" prefix.
'Global variables declaration
DIM currentIniFileName AS STRING
DIM LoadedFiles AS STRING
DIM currentIniFileLOF AS _UNSIGNED LONG
DIM IniWholeFile AS STRING
DIM IniSectionData AS STRING
DIM IniPosition AS _UNSIGNED LONG
DIM IniNewFile AS STRING
DIM IniLastSection AS STRING
DIM IniLastKey AS STRING
DIM IniLF AS STRING
DIM IniDisableAutoCommit AS _BYTE
DIM IniCODE AS LONG
DIM IniAllowBasicComments AS _BYTE
DIM IniForceReload AS _BYTE
$END IF

View file

@ -1,51 +0,0 @@
Animated GIF decoder v1.0
By Zom-B
http://www.qb64.org/wiki/GIF_Images
Adapted for use with InForm's PictureBox controls by @FellippeHeitor
* Usage instructions:
Your form must contain a PictureBox control that'll serve as a container for
the GIF file you'll load with this library.
In the "External modules" section of the .bas file generated by InForm,
$INCLUDE both gifplay.bi and gifplay.bm. The first must come before the
line that includes InForm.ui and the second must come after that, as in
the sample below:
': External modules: --------------------------------
'$INCLUDE:'InForm\extensions\gifplay.bi'
'$INCLUDE:'InForm\InForm.ui'
'$INCLUDE:'InForm\xp.uitheme'
'$INCLUDE:'gifplaySample.frm'
'$INCLUDE:'InForm\extensions\gifplay.bm'
* Methods:
- FUNCTION OpenGif(ID, file$)
OpenGif is a function that takes a PictureBox control ID and a GIF
file name and returns True if loading the animation is successful.
- FUNCTION TotalFrames(ID AS LONG)
TotalFrames returns the total number of frames in a loaded gif.
If not an animated GIF, returns 1.
- SUB UpdateGif(ID)
UpdateGif must be called from within the __UI_BeforeUpdateDisplay event.
That's where the frames will be updated in your PictureBox control.
- FUNCTION IsPlaying(ID)
Returns True is the PictureBox control contains a GIF that's currently
being played.
- SUB PlayGif(ID), SUB PauseGif(ID), SUB StopGif(ID)
Starts, pauses or stops playback of a GIF file loaded into the specified
PictureBox control.
- SUB CloseGif(ID)
Closes the GIF file loaded in the specified PictureBox control and frees
the memory used by the frame data buffer attached to it.

View file

@ -0,0 +1,332 @@
'-----------------------------------------------------------------------------------------------------------------------
' File I/O like routines for memory loaded files
' Copyright (c) 2024 Samuel Gomes
'-----------------------------------------------------------------------------------------------------------------------
$IF STRINGFILE_BAS = UNDEFINED THEN
$LET STRINGFILE_BAS = TRUE
'$INCLUDE:'StringFile.bi'
'-------------------------------------------------------------------------------------------------------------------
' Test code for debugging the library
'-------------------------------------------------------------------------------------------------------------------
'DEFLNG A-Z
'OPTION _EXPLICIT
'WIDTH , 80
'DIM sf AS StringFileType
'StringFile_Create sf, "This_is_a_test_buffer."
'PRINT LEN(sf.buffer), sf.cursor
'PRINT StringFile_GetPosition(sf)
'PRINT StringFile_ReadString(sf, 22)
'PRINT StringFile_GetPosition(sf)
'PRINT StringFile_IsEOF(sf)
'PRINT LEN(sf.buffer), sf.cursor
'StringFile_Seek sf, StringFile_GetPosition(sf) - 1
'StringFile_WriteString sf, "! Now adding some more text."
'PRINT StringFile_GetPosition(sf)
'PRINT StringFile_IsEOF(sf)
'PRINT LEN(sf.buffer), sf.cursor
'StringFile_Seek sf, 0
'PRINT StringFile_GetPosition(sf)
'PRINT StringFile_IsEOF(sf)
'PRINT LEN(sf.buffer), sf.cursor
'PRINT StringFile_ReadString(sf, 49)
'PRINT StringFile_GetPosition(sf)
'PRINT StringFile_IsEOF(sf)
'PRINT LEN(sf.buffer), sf.cursor
'StringFile_Seek sf, 0
'PRINT CHR$(StringFile_ReadByte(sf))
'PRINT LEN(sf.buffer), sf.cursor
'StringFile_WriteString sf, "XX"
'PRINT LEN(sf.buffer), sf.cursor
'PRINT CHR$(StringFile_ReadByte(sf))
'StringFile_Seek sf, 0
'PRINT StringFile_ReadString(sf, 49)
'PRINT StringFile_GetPosition(sf)
'PRINT StringFile_IsEOF(sf)
'PRINT LEN(sf.buffer), sf.cursor
'StringFile_Seek sf, 0
'StringFile_WriteInteger sf, 420
'StringFile_Seek sf, 0
'PRINT StringFile_ReadInteger(sf)
'PRINT LEN(sf.buffer), sf.cursor
'StringFile_Seek sf, 0
'StringFile_WriteByte sf, 255
'StringFile_Seek sf, 0
'PRINT StringFile_ReadByte(sf)
'PRINT LEN(sf.buffer), sf.cursor
'StringFile_Seek sf, 0
'StringFile_WriteLong sf, 192000
'StringFile_Seek sf, 0
'PRINT StringFile_ReadLong(sf)
'PRINT LEN(sf.buffer), sf.cursor
'StringFile_Seek sf, 0
'StringFile_WriteSingle sf, 752.334
'StringFile_Seek sf, 0
'PRINT StringFile_ReadSingle(sf)
'PRINT LEN(sf.buffer), sf.cursor
'StringFile_Seek sf, 0
'StringFile_WriteDouble sf, 23232323.242423424#
'StringFile_Seek sf, 0
'PRINT StringFile_ReadDouble(sf)
'PRINT LEN(sf.buffer), sf.cursor
'StringFile_Seek sf, 0
'StringFile_WriteInteger64 sf, 9999999999999999&&
'StringFile_Seek sf, 0
'PRINT StringFile_ReadInteger64(sf)
'PRINT LEN(sf.buffer), sf.cursor
'END
'-------------------------------------------------------------------------------------------------------------------
' Creates a new StringFile object
' StringFile APIs are a simple way of dealing with file that are completely loaded in memory
' Since it uses a QB string as a backing buffer, no explicit memory management (i.e. freeing) is required
SUB StringFile_Create (stringFile AS StringFileType, buffer AS STRING)
stringFile.buffer = buffer
stringFile.cursor = 0
END SUB
' Loads a whole file from disk into a StringFile object
' This will reset the StringFile object if it was previously being used
FUNCTION StringFile_Load%% (stringFile AS StringFileType, fileName AS STRING)
IF _FILEEXISTS(fileName) THEN
DIM AS LONG fh: fh = FREEFILE
OPEN fileName FOR BINARY ACCESS READ AS fh
stringFile.buffer = INPUT$(LOF(fh), fh)
stringFile.cursor = 0
CLOSE fh
StringFile_Load = __STRINGFILE_TRUE
END IF
END FUNCTION
' Saves a StringFile object to a file
' This does not disturb the read / write cursor
FUNCTION StringFile_Save%% (stringFile AS StringFileType, fileName AS STRING, overwrite AS _BYTE)
IF _FILEEXISTS(fileName) AND NOT overwrite THEN EXIT FUNCTION
DIM fh AS LONG: fh = FREEFILE
OPEN fileName FOR OUTPUT AS fh ' open file in text mode to wipe out the file if it exists
PRINT #fh, stringFile.buffer; ' write the buffer to the file (works regardless of the file being opened in text mode)
CLOSE fh
StringFile_Save = __STRINGFILE_TRUE
END FUNCTION
' Returns true if EOF is reached
FUNCTION StringFile_IsEOF%% (stringFile AS StringFileType)
StringFile_IsEOF = (stringFile.cursor >= LEN(stringFile.buffer))
END FUNCTION
' Get the size of the file
FUNCTION StringFile_GetSize~& (stringFile AS StringFileType)
StringFile_GetSize = LEN(stringFile.buffer)
END FUNCTION
' Gets the current r/w cursor position
FUNCTION StringFile_GetPosition~& (stringFile AS StringFileType)
StringFile_GetPosition = stringFile.cursor
END FUNCTION
' Seeks to a position in the file
SUB StringFile_Seek (stringFile AS StringFileType, position AS _UNSIGNED LONG)
IF position <= LEN(stringFile.buffer) THEN ' allow seeking to EOF position
stringFile.cursor = position
ELSE
ERROR 5
END IF
END SUB
' Resizes the file
SUB StringFile_Resize (stringFile AS StringFileType, newSize AS _UNSIGNED LONG)
DIM AS _UNSIGNED LONG curSize: curSize = LEN(stringFile.buffer)
IF newSize > curSize THEN
stringFile.buffer = stringFile.buffer + STRING$(newSize - curSize, 0)
ELSEIF newSize < curSize THEN
stringFile.buffer = LEFT$(stringFile.buffer, newSize)
IF stringFile.cursor > newSize THEN stringFile.cursor = newSize ' reposition cursor to EOF position
END IF
END SUB
' Reads size bytes from the file
FUNCTION StringFile_ReadString$ (stringFile AS StringFileType, size AS _UNSIGNED LONG)
IF size > 0 THEN ' reading 0 bytes will simply do nothing
IF stringFile.cursor < LEN(stringFile.buffer) THEN ' we'll allow partial string reads but check if we have anything to read at all
DIM dst AS STRING: dst = MID$(stringFile.buffer, stringFile.cursor + 1, size)
stringFile.cursor = stringFile.cursor + LEN(dst) ' increment cursor by size bytes
StringFile_ReadString = dst
ELSE ' not enough bytes to read
ERROR 5
END IF
END IF
END FUNCTION
' Writes a string to the file and grows the file if needed
SUB StringFile_WriteString (stringFile AS StringFileType, src AS STRING)
DIM srcSize AS _UNSIGNED LONG: srcSize = LEN(src)
IF srcSize > 0 THEN ' writing 0 bytes will simply do nothing
DIM curSize AS _UNSIGNED LONG: curSize = LEN(stringFile.buffer)
' Grow the buffer if needed
IF stringFile.cursor + srcSize >= curSize THEN stringFile.buffer = stringFile.buffer + STRING$(stringFile.cursor + srcSize - curSize, 0)
MID$(stringFile.buffer, stringFile.cursor + 1, srcSize) = src
stringFile.cursor = stringFile.cursor + srcSize ' this puts the cursor right after the last positon written
END IF
END SUB
' Reads a byte from the file
FUNCTION StringFile_ReadByte~%% (stringFile AS StringFileType)
IF stringFile.cursor + 1 <= LEN(stringFile.buffer) THEN ' check if we really have the amount of bytes to read
StringFile_ReadByte = ASC(stringFile.buffer, stringFile.cursor + 1) ' read the data
stringFile.cursor = stringFile.cursor + 1 ' this puts the cursor right after the last positon read
ELSE ' not enough bytes to read
ERROR 5
END IF
END FUNCTION
' Write a byte to the file
SUB StringFile_WriteByte (stringFile AS StringFileType, src AS _UNSIGNED _BYTE)
DIM curSize AS _UNSIGNED LONG: curSize = LEN(stringFile.buffer)
' Grow the buffer if needed
IF stringFile.cursor + 1 >= curSize THEN stringFile.buffer = stringFile.buffer + STRING$(stringFile.cursor + 1 - curSize, 0)
ASC(stringFile.buffer, stringFile.cursor + 1) = src ' write the data
stringFile.cursor = stringFile.cursor + 1 ' this puts the cursor right after the last positon written
END SUB
' Reads an integer from the file
FUNCTION StringFile_ReadInteger~% (stringFile AS StringFileType)
IF stringFile.cursor + 2 <= LEN(stringFile.buffer) THEN ' check if we really have the amount of bytes to read
StringFile_ReadInteger = CVI(MID$(stringFile.buffer, stringFile.cursor + 1, 2)) ' read the data
stringFile.cursor = stringFile.cursor + 2 ' this puts the cursor right after the last positon read
ELSE ' not enough bytes to read
ERROR 5
END IF
END FUNCTION
' Writes an integer to the file
SUB StringFile_WriteInteger (stringFile AS StringFileType, src AS _UNSIGNED INTEGER)
DIM curSize AS _UNSIGNED LONG: curSize = LEN(stringFile.buffer)
' Grow the buffer if needed
IF stringFile.cursor + 2 >= curSize THEN stringFile.buffer = stringFile.buffer + STRING$(stringFile.cursor + 2 - curSize, 0)
MID$(stringFile.buffer, stringFile.cursor + 1, 2) = MKI$(src) ' write the data
stringFile.cursor = stringFile.cursor + 2 ' this puts the cursor right after the last positon written
END SUB
' Reads a long from the file
FUNCTION StringFile_ReadLong~& (stringFile AS StringFileType)
IF stringFile.cursor + 4 <= LEN(stringFile.buffer) THEN ' check if we really have the amount of bytes to read
StringFile_ReadLong = CVL(MID$(stringFile.buffer, stringFile.cursor + 1, 4)) ' read the data
stringFile.cursor = stringFile.cursor + 4 ' this puts the cursor right after the last positon read
ELSE ' not enough bytes to read
ERROR 5
END IF
END FUNCTION
' Writes a long to the file
SUB StringFile_WriteLong (stringFile AS StringFileType, src AS _UNSIGNED LONG)
DIM curSize AS _UNSIGNED LONG: curSize = LEN(stringFile.buffer)
' Grow the buffer if needed
IF stringFile.cursor + 4 >= curSize THEN stringFile.buffer = stringFile.buffer + STRING$(stringFile.cursor + 4 - curSize, 0)
MID$(stringFile.buffer, stringFile.cursor + 1, 4) = MKL$(src) ' write the data
stringFile.cursor = stringFile.cursor + 4 ' this puts the cursor right after the last positon written
END SUB
' Reads a single from the file
FUNCTION StringFile_ReadSingle! (stringFile AS StringFileType)
IF stringFile.cursor + 4 <= LEN(stringFile.buffer) THEN ' check if we really have the amount of bytes to read
StringFile_ReadSingle = CVS(MID$(stringFile.buffer, stringFile.cursor + 1, 4)) ' read the data
stringFile.cursor = stringFile.cursor + 4 ' this puts the cursor right after the last positon read
ELSE ' not enough bytes to read
ERROR 5
END IF
END FUNCTION
' Writes a single to the file
SUB StringFile_WriteSingle (stringFile AS StringFileType, src AS SINGLE)
DIM curSize AS _UNSIGNED LONG: curSize = LEN(stringFile.buffer)
' Grow the buffer if needed
IF stringFile.cursor + 4 >= curSize THEN stringFile.buffer = stringFile.buffer + STRING$(stringFile.cursor + 4 - curSize, 0)
MID$(stringFile.buffer, stringFile.cursor + 1, 4) = MKS$(src) ' write the data
stringFile.cursor = stringFile.cursor + 4 ' this puts the cursor right after the last positon written
END SUB
' Reads an integer64 from the file
FUNCTION StringFile_ReadInteger64~&& (stringFile AS StringFileType)
IF stringFile.cursor + 8 <= LEN(stringFile.buffer) THEN ' check if we really have the amount of bytes to read
StringFile_ReadInteger64 = _CV(_UNSIGNED _INTEGER64, MID$(stringFile.buffer, stringFile.cursor + 1, 8)) ' read the data
stringFile.cursor = stringFile.cursor + 8 ' this puts the cursor right after the last positon read
ELSE ' not enough bytes to read
ERROR 5
END IF
END FUNCTION
' Writes an integer64 to the file
SUB StringFile_WriteInteger64 (stringFile AS StringFileType, src AS _UNSIGNED _INTEGER64)
DIM curSize AS _UNSIGNED LONG: curSize = LEN(stringFile.buffer)
' Grow the buffer if needed
IF stringFile.cursor + 8 >= curSize THEN stringFile.buffer = stringFile.buffer + STRING$(stringFile.cursor + 8 - curSize, 0)
MID$(stringFile.buffer, stringFile.cursor + 1, 8) = _MK$(_UNSIGNED _INTEGER64, src) ' write the data
stringFile.cursor = stringFile.cursor + 8 ' this puts the cursor right after the last positon written
END SUB
' Reads a double from the file
FUNCTION StringFile_ReadDouble# (stringFile AS StringFileType)
IF stringFile.cursor + 8 <= LEN(stringFile.buffer) THEN ' check if we really have the amount of bytes to read
StringFile_ReadDouble = CVD(MID$(stringFile.buffer, stringFile.cursor + 1, 8)) ' read the data
stringFile.cursor = stringFile.cursor + 8 ' this puts the cursor right after the last positon read
ELSE ' not enough bytes to read
ERROR 5
END IF
END FUNCTION
' Writes a double to the file
SUB StringFile_WriteDouble (stringFile AS StringFileType, src AS DOUBLE)
DIM curSize AS _UNSIGNED LONG: curSize = LEN(stringFile.buffer)
' Grow the buffer if needed
IF stringFile.cursor + 8 >= curSize THEN stringFile.buffer = stringFile.buffer + STRING$(stringFile.cursor + 8 - curSize, 0)
MID$(stringFile.buffer, stringFile.cursor + 1, 8) = MKD$(src) ' write the data
stringFile.cursor = stringFile.cursor + 8 ' this puts the cursor right after the last positon written
END SUB
$END IF

View file

@ -0,0 +1,17 @@
'-----------------------------------------------------------------------------------------------------------------------
' File I/O like routines for memory loaded files
' Copyright (c) 2024 Samuel Gomes
'-----------------------------------------------------------------------------------------------------------------------
$IF STRINGFILE_BI = UNDEFINED THEN
$LET STRINGFILE_BI = TRUE
CONST __STRINGFILE_FALSE%% = 0%%, __STRINGFILE_TRUE%% = NOT __STRINGFILE_FALSE
' Simplified QB64-only memory-file
TYPE StringFileType
buffer AS STRING
cursor AS _UNSIGNED LONG
END TYPE
$END IF

View file

@ -1,63 +0,0 @@
FUNCTION Download$ (url$, file$, timelimit) STATIC
'as seen on http://www.qb64.org/wiki/Downloading_Files
'adapted for use with InForm
DIM theClient AS LONG, l AS LONG
DIM prevUrl$, prevUrl2$, url2$, x AS LONG
DIM e$, url3$, x$, t!, a2$, a$, i AS LONG
DIM i2 AS LONG, i3 AS LONG, d$, fh AS LONG
IF url$ <> prevUrl$ OR url$ = "" THEN
prevUrl$ = url$
IF url$ = "" THEN
IF theClient THEN CLOSE theClient: theClient = 0
EXIT SUB
END IF
url2$ = url$
x = INSTR(url2$, "/")
IF x THEN url2$ = LEFT$(url$, x - 1)
IF url2$ <> prevUrl2$ THEN
prevUrl2$ = url2$
IF theClient THEN CLOSE theClient: theClient = 0
theClient = _OPENCLIENT("TCP/IP:80:" + url2$)
IF theClient = 0 THEN Download = MKI$(2): prevUrl$ = "": EXIT FUNCTION
END IF
e$ = CHR$(13) + CHR$(10) ' end of line characters
url3$ = RIGHT$(url$, LEN(url$) - x + 1)
x$ = "GET " + url3$ + " HTTP/1.1" + e$
x$ = x$ + "Host: " + url2$ + e$ + e$
PUT #theClient, , x$
t! = TIMER ' start time
END IF
GET #theClient, , a2$
a$ = a$ + a2$
i = INSTR(a$, "Content-Length:")
IF i THEN
i2 = INSTR(i, a$, e$)
IF i2 THEN
l = VAL(MID$(a$, i + 15, i2 - i - 14))
i3 = INSTR(i2, a$, e$ + e$)
IF i3 THEN
i3 = i3 + 4 'move i3 to start of data
IF (LEN(a$) - i3 + 1) = l THEN
d$ = MID$(a$, i3, l)
fh = FREEFILE
OPEN file$ FOR OUTPUT AS #fh: CLOSE #fh 'Warning! Clears data from existing file
OPEN file$ FOR BINARY AS #fh
PUT #fh, , d$
CLOSE #fh
Download = MKI$(1) + MKL$(l) 'indicates download was successful
prevUrl$ = ""
prevUrl2$ = ""
a$ = ""
CLOSE theClient
theClient = 0
EXIT FUNCTION
END IF ' availabledata = l
END IF ' i3
END IF ' i2
END IF ' i
IF TIMER > t! + timelimit THEN CLOSE theClient: theClient = 0: Download = MKI$(3): prevUrl$ = "": EXIT FUNCTION
Download = MKI$(0) 'still working
END FUNCTION

View file

@ -1,57 +0,0 @@
'#######################################################################################
'# Animated GIF decoder v1.0 #
'# By Zom-B #
'# #
'# http://www.qb64.org/wiki/GIF_Images #
'#######################################################################################
'Adapted for use with InForm's PictureBox controls by @FellippeHeitor
TYPE GIFDATA
ID AS LONG
file AS INTEGER
sigver AS STRING * 6
width AS _UNSIGNED INTEGER
height AS _UNSIGNED INTEGER
bpp AS _UNSIGNED _BYTE
sortFlag AS _BYTE ' Unused
colorRes AS _UNSIGNED _BYTE
colorTableFlag AS _BYTE
bgColor AS _UNSIGNED _BYTE
aspect AS SINGLE ' Unused
numColors AS _UNSIGNED INTEGER
palette AS STRING * 768
firstFrame AS LONG
totalFrames AS LONG
IsPlaying AS _BYTE
Frame AS LONG
LoadedFrames AS LONG
GifLoadComplete AS _BYTE
LastFrameServed AS LONG
LastFrameUpdate AS SINGLE
LastFrameDelay AS SINGLE
HideOverlay AS _BYTE
END TYPE
TYPE FRAMEDATA
ID AS LONG
thisFrame AS LONG
addr AS LONG
left AS _UNSIGNED INTEGER
top AS _UNSIGNED INTEGER
width AS _UNSIGNED INTEGER
height AS _UNSIGNED INTEGER
localColorTableFlag AS _BYTE
interlacedFlag AS _BYTE
sortFlag AS _BYTE ' Unused
palBPP AS _UNSIGNED _BYTE
minimumCodeSize AS _UNSIGNED _BYTE
transparentFlag AS _BYTE 'GIF89a-specific (animation) values
userInput AS _BYTE ' Unused
disposalMethod AS _UNSIGNED _BYTE
delay AS SINGLE
transColor AS _UNSIGNED _BYTE
END TYPE
REDIM SHARED GifData(0) AS GIFDATA
REDIM SHARED GifFrameData(0) AS FRAMEDATA
DIM SHARED TotalGIFLoaded AS LONG, TotalGIFFrames AS LONG

View file

@ -1,881 +0,0 @@
'#######################################################################################
'# Animated GIF decoder v1.0 #
'# By Zom-B #
'# #
'# http://www.qb64.org/wiki/GIF_Images #
'#######################################################################################
'Adapted for use with InForm's PictureBox controls by @FellippeHeitor
SUB UpdateGif (ID AS LONG)
DIM i AS LONG, newFrame AS LONG
STATIC GifOverlay AS LONG
i = GetGifIndex(ID)
IF i = 0 THEN EXIT SUB
IF GifOverlay = 0 THEN
GifOverlay = LoadOverlayImage&
END IF
IF GifData(i).IsPlaying OR GifData(i).LastFrameServed = 0 THEN
IF GifData(i).LastFrameUpdate > 0 AND TIMER - GifData(i).LastFrameUpdate < GifData(i).LastFrameDelay THEN
'Wait for the GIF's frame delay
ELSE
GifData(i).Frame = GifData(i).Frame + 1
GifData(i).LastFrameServed = GifData(i).Frame
GifData(i).LastFrameUpdate = TIMER
END IF
END IF
BeginDraw ID
newFrame = GetGifFrame&(i)
IF newFrame THEN _PUTIMAGE , newFrame
IF GifData(i).IsPlaying = False AND GifData(i).HideOverlay = False AND GifData(i).totalFrames > 1 THEN
_PUTIMAGE (_WIDTH / 2 - _WIDTH(GifOverlay) / 2, _HEIGHT / 2 - _HEIGHT(GifOverlay) / 2), GifOverlay
END IF
EndDraw ID
END SUB
FUNCTION GifIsPlaying%% (ID AS LONG)
DIM i AS LONG
i = GetGifIndex(ID)
GifIsPlaying%% = GifData(i).IsPlaying
END FUNCTION
FUNCTION GifWidth%(ID AS LONG)
DIM i AS LONG
i = GetGifIndex(ID)
GifWidth% = GifData(i).width
END FUNCTION
FUNCTION GifHeight%(ID AS LONG)
DIM i AS LONG
i = GetGifIndex(ID)
GifHeight% = GifData(i).height
END FUNCTION
FUNCTION TotalFrames&(ID AS LONG)
DIM i AS LONG
i = GetGifIndex(ID)
TotalFrames& = GifData(i).totalFrames
END FUNCTION
SUB HideGifOverlay (ID AS LONG)
DIM i AS LONG
i = GetGifIndex(ID)
GifData(i).HideOverlay = True
END SUB
SUB PlayGif (ID AS LONG)
DIM i AS LONG
i = GetGifIndex(ID)
GifData(i).IsPlaying = True
END SUB
SUB PauseGif (ID AS LONG)
DIM i AS LONG
i = GetGifIndex(ID)
GifData(i).IsPlaying = False
END SUB
SUB StopGif (ID AS LONG)
DIM i AS LONG
i = GetGifIndex(ID)
GifData(i).IsPlaying = False
GifData(i).Frame = 1
END SUB
FUNCTION OpenGif%%(ID AS LONG, filename$)
DIM i AS LONG, Index AS LONG
DIM byte~%%, palette$, delay~%
IF Control(ID).Type <> __UI_Type_PictureBox THEN ERROR 5: EXIT FUNCTION
Index = GetGifIndex&(ID)
IF Index = 0 THEN
TotalGIFLoaded = TotalGIFLoaded + 1
Index = TotalGIFLoaded
REDIM _PRESERVE GifData(1 TO TotalGIFLoaded) AS GIFDATA
ELSE
CloseGif ID
END IF
GifData(Index).ID = ID
GifData(Index).file = FREEFILE
IF _FILEEXISTS(filename$) = 0 THEN EXIT FUNCTION
OPEN filename$ FOR BINARY AS GifData(Index).file
GET GifData(Index).file, , GifData(Index).sigver
GET GifData(Index).file, , GifData(Index).width
GET GifData(Index).file, , GifData(Index).height
GET GifData(Index).file, , byte~%%
GifData(Index).bpp = (byte~%% AND 7) + 1
GifData(Index).sortFlag = (byte~%% AND 8) > 0
GifData(Index).colorRes = (byte~%% \ 16 AND 7) + 1
GifData(Index).colorTableFlag = (byte~%% AND 128) > 0
GifData(Index).numColors = 2 ^ GifData(Index).bpp
GET GifData(Index).file, , GifData(Index).bgColor
GET GifData(Index).file, , byte~%%
IF byte~%% = 0 THEN GifData(Index).aspect = 0 ELSE GifData(Index).aspect = (byte~%% + 15) / 64
IF GifData(Index).sigver <> "GIF87a" AND GifData(Index).sigver <> "GIF89a" THEN
'Invalid version
GOTO LoadError
END IF
IF NOT GifData(Index).colorTableFlag THEN
'No Color Table
GOTO LoadError
END IF
palette$ = SPACE$(3 * GifData(Index).numColors)
GET GifData(Index).file, , palette$
GifData(Index).palette = palette$
DO
GET GifData(Index).file, , byte~%%
SELECT CASE byte~%%
CASE &H2C ' Image Descriptor
TotalGIFFrames = TotalGIFFrames + 1
GifData(Index).totalFrames = GifData(Index).totalFrames + 1
IF GifData(Index).firstFrame = 0 THEN
GifData(Index).firstFrame = TotalGIFFrames
END IF
IF TotalGIFFrames > UBOUND(GifFrameData) THEN
REDIM _PRESERVE GifFrameData(0 TO TotalGIFFrames * 2) AS FRAMEDATA
END IF
GifFrameData(TotalGIFFrames).ID = ID
GifFrameData(TotalGIFFrames).thisFrame = GifData(Index).totalFrames
GET GifData(Index).file, , GifFrameData(TotalGIFFrames).left
GET GifData(Index).file, , GifFrameData(TotalGIFFrames).top
GET GifData(Index).file, , GifFrameData(TotalGIFFrames).width
GET GifData(Index).file, , GifFrameData(TotalGIFFrames).height
GET GifData(Index).file, , byte~%%
GifFrameData(TotalGIFFrames).localColorTableFlag = (byte~%% AND 128) > 0
GifFrameData(TotalGIFFrames).interlacedFlag = (byte~%% AND 64) > 0
GifFrameData(TotalGIFFrames).sortFlag = (byte~%% AND 32) > 0
GifFrameData(TotalGIFFrames).palBPP = (byte~%% AND 7) + 1
GifFrameData(TotalGIFFrames).addr = LOC(GifData(Index).file) + 1
IF GifFrameData(TotalGIFFrames).localColorTableFlag THEN
SEEK GifData(Index).file, LOC(GifData(Index).file) + 3 * 2 ^ GifFrameData(TotalGIFFrames).palBPP + 1
END IF
GET GifData(Index).file, , GifFrameData(TotalGIFFrames).minimumCodeSize
IF GifFrameData(TotalGIFFrames).disposalMethod > 2 THEN
'Unsupported disposalMethod
GOTO LoadError
END IF
SkipGIFBlocks GifData(Index).file
CASE &H3B ' Trailer
EXIT DO
CASE &H21 ' Extension Introducer
GET GifData(Index).file, , byte~%% ' Extension Label
SELECT CASE byte~%%
CASE &HFF, &HFE ' Application Extension, Comment Extension
SkipGIFBlocks GifData(Index).file
CASE &HF9
IF TotalGIFFrames > UBOUND(GifFrameData) THEN
REDIM _PRESERVE GifFrameData(0 TO TotalGIFFrames * 2) AS FRAMEDATA
END IF
GifFrameData(TotalGIFFrames).ID = ID
GET GifData(Index).file, , byte~%% ' Block Size (always 4)
GET GifData(Index).file, , byte~%%
GifFrameData(TotalGIFFrames).transparentFlag = (byte~%% AND 1) > 0
GifFrameData(TotalGIFFrames).userInput = (byte~%% AND 2) > 0
GifFrameData(TotalGIFFrames).disposalMethod = byte~%% \ 4 AND 7
GET GifData(Index).file, , delay~%
IF delay~% = 0 THEN GifFrameData(TotalGIFFrames).delay = 0.1 ELSE GifFrameData(TotalGIFFrames).delay = delay~% / 100
GET GifData(Index).file, , GifFrameData(TotalGIFFrames).transColor
SkipGIFBlocks GifData(Index).file
CASE ELSE
'Unsupported extension Label
GOTO LoadError
END SELECT
CASE ELSE
'Unsupported chunk
GOTO LoadError
END SELECT
LOOP
REDIM _PRESERVE GifFrameData(0 TO TotalGIFFrames) AS FRAMEDATA
GifData(Index).IsPlaying = False
OpenGif%% = True
EXIT FUNCTION
LoadError:
GifData(Index).ID = 0
CLOSE GifData(Index).file
FOR i = 1 TO TotalGIFFrames
IF GifFrameData(i).ID = ID THEN
GifFrameData(i).ID = 0
END IF
NEXT
END FUNCTION
FUNCTION GetGifIndex&(ID AS LONG)
DIM i AS LONG
FOR i = 1 TO TotalGIFLoaded
IF GifData(i).ID = ID THEN
GetGifIndex& = i
EXIT FOR
END IF
NEXT
END FUNCTION
SUB CloseGif(ID AS LONG)
DIM i AS LONG, Index AS LONG
Index = GetGifIndex(ID)
IF Index = 0 THEN EXIT SUB
FOR i = 0 TO UBOUND(GifFrameData)
IF GifFrameData(i).ID = ID THEN
GifFrameData(i).ID = 0
IF GifFrameData(i).addr < -1 THEN
_FREEIMAGE GifFrameData(i).addr
END IF
END IF
NEXT
CLOSE GifData(Index).file
GifData(Index).ID = 0
GifData(Index).firstFrame = 0
END SUB
SUB SkipGIFBlocks (file AS INTEGER)
DIM byte~%%
DO
GET file, , byte~%% ' Block Size
SEEK file, LOC(file) + byte~%% + 1
LOOP WHILE byte~%%
END SUB
FUNCTION GetGifFrame& (Index AS LONG)
DIM i AS LONG
DIM frame AS LONG, previousFrame AS LONG
DIM w AS INTEGER, h AS INTEGER
DIM img&, actualFrame&
DIM prevDest AS LONG
IF GifData(Index).Frame > GifData(Index).totalFrames THEN
GifData(Index).Frame = 1
END IF
FOR i = 1 TO UBOUND(GifFrameData)
IF GifFrameData(i).ID = GifData(Index).ID AND GifFrameData(i).thisFrame = GifData(Index).Frame THEN
frame = i
EXIT FOR
ELSEIF GifFrameData(i).ID = GifData(Index).ID AND GifFrameData(i).thisFrame < GifData(Index).Frame THEN
previousFrame = i
END IF
NEXT
GifData(Index).LastFrameDelay = GifFrameData(frame).delay - (GifFrameData(frame).delay / 10)
IF GifFrameData(frame).addr > 0 THEN
prevDest = _DEST
w = GifFrameData(frame).width
h = GifFrameData(frame).height
img& = _NEWIMAGE(w, h, 256)
actualFrame& = _NEWIMAGE(GifData(Index).width, GifData(Index).height, 256)
_DEST img&
DecodeFrame GifData(Index), GifFrameData(frame)
_DEST actualFrame&
IF GifFrameData(frame).localColorTableFlag THEN
_COPYPALETTE img&
ELSE
FOR i = 0 TO GifData(Index).numColors - 1
_PALETTECOLOR i, _RGB32(ASC(GifData(Index).palette, i * 3 + 1), ASC(GifData(Index).palette, i * 3 + 2), ASC(GifData(Index).palette, i * 3 + 3))
NEXT
END IF
IF GifData(Index).Frame > 1 THEN
SELECT CASE GifFrameData(previousFrame).disposalMethod
CASE 0, 1
_PUTIMAGE , GifFrameData(previousFrame).addr
CASE 2
CLS , GifData(Index).bgColor
_CLEARCOLOR GifData(Index).bgColor
END SELECT
ELSE
CLS , GifData(Index).bgColor
END IF
IF GifFrameData(frame).transparentFlag THEN
_CLEARCOLOR GifFrameData(frame).transColor, img&
END IF
_PUTIMAGE (GifFrameData(frame).left, GifFrameData(frame).top), img&
_FREEIMAGE img&
GifFrameData(frame).addr = actualFrame&
GifData(Index).LoadedFrames = GifData(Index).LoadedFrames + 1
GifData(Index).GifLoadComplete = (GifData(Index).LoadedFrames = GifData(Index).TotalFrames)
_DEST prevDest
END IF
GetGifFrame& = GifFrameData(frame).addr
END FUNCTION
SUB DecodeFrame (gifdata AS GIFDATA, GifFrameData AS FRAMEDATA)
DIM byte AS _UNSIGNED _BYTE
DIM prefix(4095), suffix(4095), colorStack(4095)
DIM startCodeSize AS INTEGER, clearCode AS INTEGER
DIM endCode AS INTEGER, minCode AS INTEGER, startMaxCode AS INTEGER
DIM nvc AS INTEGER, codeSize AS INTEGER
DIM maxCode AS INTEGER, bitPointer AS INTEGER, blockSize AS INTEGER
DIM blockPointer AS INTEGER, x AS INTEGER, y AS INTEGER
DIM palette$, i AS LONG, c&, stackPointer AS INTEGER
DIM currentCode AS INTEGER, code AS INTEGER, lastColor AS INTEGER
DIM oldCode AS INTEGER, WorkCode&, LastChar AS INTEGER
DIM interlacedPass AS INTEGER, interlacedStep AS INTEGER
DIM file AS INTEGER, a$, loopStart!
startCodeSize = gifdata.bpp + 1
clearCode = 2 ^ gifdata.bpp
endCode = clearCode + 1
minCode = endCode + 1
startMaxCode = clearCode * 2 - 1
nvc = minCode
codeSize = startCodeSize
maxCode = startMaxCode
IF GifFrameData.interlacedFlag THEN interlacedPass = 0: interlacedStep = 8
bitPointer = 0
blockSize = 0
blockPointer = 0
x = 0
y = 0
file = gifdata.file
SEEK file, GifFrameData.addr
IF GifFrameData.localColorTableFlag THEN
palette$ = SPACE$(3 * 2 ^ GifFrameData.palBPP)
GET file, , palette$
FOR i = 0 TO gifdata.numColors - 1
c& = _RGB32(ASC(palette$, i * 3 + 1), ASC(palette$, i * 3 + 2), ASC(palette$, i * 3 + 3))
_PALETTECOLOR i, c&
NEXT
END IF
GET file, , byte ' minimumCodeSize
loopStart! = TIMER
DO
IF TIMER - loopStart! > 2 THEN EXIT DO
GOSUB GetCode
stackPointer = 0
IF code = clearCode THEN 'Reset & Draw next color direct
nvc = minCode ' \
codeSize = startCodeSize ' Preset default codes
maxCode = startMaxCode ' /
GOSUB GetCode
currentCode = code
lastColor = code
colorStack(stackPointer) = lastColor
stackPointer = 1
ELSEIF code <> endCode THEN 'Draw direct color or colors from suffix
currentCode = code
IF currentCode = nvc THEN 'Take last color too
currentCode = oldCode
colorStack(stackPointer) = lastColor
stackPointer = stackPointer + 1
END IF
WHILE currentCode >= minCode 'Extract colors from suffix
colorStack(stackPointer) = suffix(currentCode)
stackPointer = stackPointer + 1
currentCode = prefix(currentCode) 'Next color from suffix is described in
WEND ' the prefix, else prefix is the last col.
lastColor = currentCode ' Last color is equal to the
colorStack(stackPointer) = lastColor ' last known code (direct, or from
stackPointer = stackPointer + 1 ' Prefix)
suffix(nvc) = lastColor 'Automatically, update suffix
prefix(nvc) = oldCode 'Code from the session before (for extracting from suffix)
nvc = nvc + 1
IF nvc > maxCode AND codeSize < 12 THEN
codeSize = codeSize + 1
maxCode = maxCode * 2 + 1
END IF
END IF
FOR i = stackPointer - 1 TO 0 STEP -1
PSET (x, y), colorStack(i)
x = x + 1
IF x = GifFrameData.width THEN
x = 0
IF GifFrameData.interlacedFlag THEN
y = y + interlacedStep
IF y >= GifFrameData.height THEN
SELECT CASE interlacedPass
CASE 0: interlacedPass = 1: y = 4
CASE 1: interlacedPass = 2: y = 2
CASE 2: interlacedPass = 3: y = 1
END SELECT
interlacedStep = 2 * y
END IF
ELSE
y = y + 1
END IF
END IF
NEXT
oldCode = code
LOOP UNTIL code = endCode
GET file, , byte
EXIT SUB
GetCode:
IF bitPointer = 0 THEN GOSUB ReadByteFromBlock: bitPointer = 8
WorkCode& = LastChar \ (2 ^ (8 - bitPointer))
WHILE codeSize > bitPointer
GOSUB ReadByteFromBlock
WorkCode& = WorkCode& OR LastChar * (2 ^ bitPointer)
bitPointer = bitPointer + 8
WEND
bitPointer = bitPointer - codeSize
code = WorkCode& AND maxCode
RETURN
ReadByteFromBlock:
IF blockPointer = blockSize THEN
GET file, , byte: blockSize = byte
a$ = SPACE$(blockSize): GET file, , a$
blockPointer = 0
END IF
blockPointer = blockPointer + 1
LastChar = ASC(MID$(a$, blockPointer, 1))
RETURN
END SUB
FUNCTION gifOverlayImage$
DIM A$
A$ = MKI$(64) + MKI$(64)
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000J000005000`M0000M20004<000`e0000V30008?000Pl0000"
A$ = A$ + "V3000L=000@`0000M2000L70000D0000J000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000003000PQ0000<30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?0000c0000620000300000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "00030000^1000X<000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000:3000h60000300000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000l0000@N0000Q30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000Q3000T7000`30000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000010000\5000`g0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "O3000\5000@0000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "0000000000000000000000000000000000000000R0000X;000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000j2000420"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "0000000000000000A1000D>000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000@i0000A100000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "0000000000000000000000000000000000000000000000@00000520008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000@Q0000100000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "0000000000000000000000P10000M20008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b3000d9000P1000000000000000000000000000000000000"
A$ = A$ + "0000000000000000000000000000000000000000000000000000000000P1"
A$ = A$ + "0000^20008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000^2000H00000000000000000000000000000000000000000000000000"
A$ = A$ + "0000000000000000000000000000000000@00000L20008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0000W00001000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "0000000000000000120008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b300088000000000000000000000"
A$ = A$ + "0000000000000000000000000000000000000000000000000000@10008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000A10000000000000000000000000000000000"
A$ = A$ + "0000000000000000000000000000P0000@>000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b3000@>00008000000000000000000000000000000000000000000000000"
A$ = A$ + "000010000T;000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000i2000400"
A$ = A$ + "000000000000000000000000000000000000000000000\5000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?0000G00000000000000000000"
A$ = A$ + "000000000000000000000l0000Pg0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000N3000l0000000000000000000000000000000000"
A$ = A$ + "00@N0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000@N000000000000000000000000000000`20000Q30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000Q3000`000000"
A$ = A$ + "00000000000000000000^10008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000PK000000000000000000001000"
A$ = A$ + "0l<000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000@30004000000000000000L3000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "000m0000f3000P?000Pn0000j3000X?000Pn0000h3000@?000`l0000b300"
A$ = A$ + "08?000Pl0000b30008?000@m0000h3000X?0000n0000f30008?000`l0000"
A$ = A$ + "g3000T?000Pn0000j3000X?000Pn0000j3000X?000Pn0000j3000X?000Pn"
A$ = A$ + "0000j3000P?000`l0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00`=000000000000000R0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b3000D?0000n0000j3000X?000Pn0000"
A$ = A$ + "j3000X?000Pn0000j3000X?000Pn0000i3000H?000Pl0000b30008?000@m"
A$ = A$ + "0000j3000X?000Pn0000j3000X?000Pm0000g3000X?000Pn0000j3000X?0"
A$ = A$ + "00Pn0000j3000X?000Pn0000j3000X?000Pn0000j3000X?000Pn0000i300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl00009200000000000000"
A$ = A$ + "<30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b3000H?000Pn0000jOb9WX?WLb9oNk]gnooooooooooooooooooooooZ"
A$ = A$ + "[^JoniWOl3000X?000Pn0000h30008?000Pl0000g3000X?^hRKoooooo;]d"
A$ = A$ + "Bk?000Pn0000h3000T?000PnZ[^jnooooooooooooooooooooooooooooooo"
A$ = A$ + "oooooooooooooooooooooooooooo\a6Kk3000X?000@m0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b3000d<000000000K00008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b3000H?000Pn0000j_jZ"
A$ = A$ + "[foooooooooooooooooooooooooooooooooooooooooooooooo_dB;]oWLb9"
A$ = A$ + "j3000X?000Pm0000b3000L?000PnhR;^mooooo_dB;]o0000j3000P?000@n"
A$ = A$ + "0000j[^jZkoooooooooooooooooooooooooooooooooooooooooooooooooo"
A$ = A$ + "oooooooooc6K\]?000Pn0000e30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000L000005000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b3000@?000Pn0000j;]dBkoooooooooooGLa5g_Oni7o"
A$ = A$ + "0000j3000X?000PnIUEFk_jZ[foooooooooook]gNk?000Pn0000j3000@?0"
A$ = A$ + "00`m0000jS;^hfooooooB;]dn3000X?0000n0000i3000X_jZ[^oooooogHS"
A$ = A$ + "=b?000Pn0000j3000X?000Pn0000j3000X?000Pn0000j3000X?000Pn0000"
A$ = A$ + "i30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300085000@O"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "000n0000jc9WLboooooooooooc6K\]?000Pn0000j3000X?000Pn0000j300"
A$ = A$ + "0X?000PnIUEFkoooooooooooLb9Wl3000X?000Pm0000g3000X?^hRKooooo"
A$ = A$ + "o;]dBk?000Pn0000h3000T?000PnZ[^jnoooooOS=f8o0000j3000X?000Pn"
A$ = A$ + "0000j3000X?000Pn0000j3000X?000Pn0000h3000<?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000@O0000T20008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?0000m0000jOb9WXoooooooooo"
A$ = A$ + "ogHS=b?000Pn0000i3000H?000`l0000b30008?000@m0000h3000X?WLb9o"
A$ = A$ + "oooook]gNk?000Pn0000h3000L?000PnhR;^mooooo_dB;]o0000j3000P?0"
A$ = A$ + "00@n0000j[^jZkoooooo=fHSl3000X?000@m0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000T20008<000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000f3000X?WLb9oooooo[^jZk?000Pn0000j3000<?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b3000@?000PnWLb9jGLa5g?WLb9oWLb9j300"
A$ = A$ + "0X?000`m0000jS;^hfooooooB;]dn3000X?0000n0000i3000X_jZ[^ooooo"
A$ = A$ + "ogHS=b?000Pn0000e30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008<0"
A$ = A$ + "00@f0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "0P?000PnNk]gnooooo?WLb9o0000j3000L?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000h3000X?000Pn0000j3000X?0000n0000g3000X?^hRKo"
A$ = A$ + "ooooo;]dBk?000Pn0000h3000T?000PnZ[^jnoooooOS=f8o0000j3000X?0"
A$ = A$ + "00Pn0000j3000X?000Pn0000j3000P?000Pm0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000@e0000V30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000@n0000jC?mdooooooo"
A$ = A$ + "\a6Kk3000X?000@m0000b30008?000`l0000h3000X?000Pn0000j3000X?0"
A$ = A$ + "00Pn0000j3000X?0000n0000c3000L?000PnhR;^mooooo_dB;]o0000j300"
A$ = A$ + "0P?000@n0000j[^jZkoooooo=fHSl3000X?000Pn0000j3000X?000Pn0000"
A$ = A$ + "j3000X?000Pn0000j3000H?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000P30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000j3000Xooooooooooo?d@3]?000Pn0000c300"
A$ = A$ + "08?000Pl0000i3000X?000Pn0000j3000X?000Pn0000j3000X?000Pn0000"
A$ = A$ + "j3000X?000`m0000jS;^hfooooooB;]dn3000X?0000n0000i3000X_jZ[^o"
A$ = A$ + "ooooooooooooooooooooooooooooooooooooooooooooooooB;]dn3000X?0"
A$ = A$ + "000n0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "0`>000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b3000X?000Pnooooooooooo@3=dn0000j3000<?000Pl0000e3000X?K\afn"
A$ = A$ + "ooooooooooooooooooooooooooooooooooooogHS=b?000Pn0000g3000X?^"
A$ = A$ + "hRKoooooo;]dBk?000Pn0000h3000T?000PnZ[^jnooooooooooooooooooo"
A$ = A$ + "ooooooooooooooooooooooooooooo;]dBk?000Pn0000h30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?0000k0000V30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pn0000jooooooo"
A$ = A$ + "oooo\a6Kk3000X?000@m0000b3000D?000Pn\a6Kkooooooooooooooooooo"
A$ = A$ + "ooooooooooooooooooOS=f8o0000j3000L?000PnhR;^mooooo_dB;]o0000"
A$ = A$ + "j3000P?000@n0000j[^jZkoooooo=fHSl3000X?000Pn0000j3000X?000Pn"
A$ = A$ + "0000j3000X?000Pn0000j3000H?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000P3000T=000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000h3000X_gNk]ooooooc9WLb?000Pn0000"
A$ = A$ + "f30008?000Pl0000i3000X?000Pn0000j3000X?000Pn0000j[^jZkoooooo"
A$ = A$ + "=fHSl3000X?000`m0000jS;^hfooooooB;]dn3000X?0000n0000i3000X_j"
A$ = A$ + "Z[^oooooogHS=b?000Pn0000j3000X?000Pn0000j3000X?000Pn0000h300"
A$ = A$ + "0H?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b3000D=000P`0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b3000H?000PnLb9Wlooooo_gNk]o0000j3000T?000`l0000b3000<?0"
A$ = A$ + "000n0000j3000X?000Pn0000j3000X_jZ[^oooooogHS=b?000Pn0000g300"
A$ = A$ + "0X?^hRKoooooo;]dBk?000Pn0000h3000T?000PnZ[^jnoooooOS=f8o0000"
A$ = A$ + "j3000D?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000P`0000T20008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0000m0000j?d@"
A$ = A$ + "3]oooooooooookWOna?000Pn0000i3000H?0000m0000b30008?0000m0000"
A$ = A$ + "g3000T?000PnZ[^jnoooooOS=f8o0000j3000L?000PnhR;^mooooo_dB;]o"
A$ = A$ + "0000j3000P?000@n0000j[^jZkoooooo=fHSl3000X?000@m0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000T2000d7000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b3000P?000PnLb9Wlooooooooooo"
A$ = A$ + "niWOl3000X?000Pn0000j3000X?000Pn0000j3000X?000PnniWOlC?mdooo"
A$ = A$ + "oooo=fHSl3000X?000`m0000jS;^hfooooooB;]dn3000X?0000n0000i300"
A$ = A$ + "0X_jZ[^oooooogHS=b?000Pn0000e30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b3000d7000PD0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?0000m0000j3000X?^hRKooooooooooo_dB;]oLb9Wl300"
A$ = A$ + "0X?000Pn0000jOb9WX?WLb9oZ[^jnoooooooooooZ[^jnWEFI]?000Pn0000"
A$ = A$ + "g3000X?^hRKoooooo;]dBk?000Pn0000h3000T?000PnZ[^jnoooooOS=f8o"
A$ = A$ + "0000j3000D?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000PD0000L000"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b3000D?000Pn0000jc9WLboooooooooooooooooooooooooooooooooooooo"
A$ = A$ + "oooooooooooooooo[^jZm3000X?000Pn0000h3000L?000PnhR;^mooooo_d"
A$ = A$ + "B;]o0000j3000P?000@n0000j[^jZkoooooo=fHSl3000X?000@m0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000L000000000@c0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000e3000X?0"
A$ = A$ + "00Pn0000jc9WLbOa5GLooooooooooooooooooooooGLa5g?WLb9o0000j300"
A$ = A$ + "0X?000Pn0000g3000<?000`m0000jS;^hfooooooB;]dn3000X?0000n0000"
A$ = A$ + "i3000X_jZ[^oooooogHS=b?000Pn0000e30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000>300000000000000920008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?0000m0000h3000X?000Pn0000"
A$ = A$ + "j3000X?000Pn0000j3000X?000Pn0000j3000X?0000n0000e30008?000Pl"
A$ = A$ + "0000e3000X?000Pn0000j3000X?000Pn0000f3000L?000Pn0000j3000X?0"
A$ = A$ + "00Pn0000j3000<?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b3000T8000000000"
A$ = A$ + "00000P3000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?0000m0000f3000P?000Pn0000j3000X?0"
A$ = A$ + "00Pn0000h3000H?0000m0000b30008?000Pl0000b30008?000@m0000h300"
A$ = A$ + "0X?0000n0000f30008?000`l0000g3000T?000Pn0000h3000<?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?0000>00000000000000@00000@30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?0000d0000100000000000000000000h6000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000^10000000000"
A$ = A$ + "00000000000000030000R30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000R3000`000000000000000000000000000000"
A$ = A$ + "0T7000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b3000T700000000000000000000000000000000000`30000N30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b3000h=000@4000000000000"
A$ = A$ + "00000000000000000000000000000`5000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?0000G000000000000000000000000000000000000"
A$ = A$ + "0000000000@00000j20008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000P^"
A$ = A$ + "000010000000000000000000000000000000000000000000000000000420"
A$ = A$ + "000i0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?0000i0000Q0000000000000000000"
A$ = A$ + "00000000000000000000000000000000000000000000A10008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000A1000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000`P0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl000042000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "00000000000010000`9000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000L2000400000000000000000000000000"
A$ = A$ + "0000000000000000000000000000000000000000000000000000000000P1"
A$ = A$ + "0000^20008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000^2000H00000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000H0000@W0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000M2000H00000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "0000000000000000000000000000000010000D8000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl000052000400000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000A1000D>000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000@i0000A1000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "0000000000P80000j20008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000P^0000Q0000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000400"
A$ = A$ + "000G0000O30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b3000l=0000G"
A$ = A$ + "000010000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "0000000000000000000000000000000000000000000000000l0000@N0000"
A$ = A$ + "Q30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000Q3000X7000`3000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "00000000000000000000000000000000000000000`0000PK0000;30008?0"
A$ = A$ + "00Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b300"
A$ = A$ + "08?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000`b0000"
A$ = A$ + "^1000`000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000<0000920000=000Pl0000"
A$ = A$ + "b30008?000Pl0000b30008?000Pl0000b30008?000Pl0000b30008?000Pl"
A$ = A$ + "0000b30008?000Pl0000@3000T80000<0000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000J000005000@N0000N20008<0"
A$ = A$ + "000f0000Y30008?000@k0000R30008=000P`0000N2000T70000D0000J000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "000000000000000000000000000000000000000000000000000000000000"
A$ = A$ + "0000%%00"
gifOverlayImage$ = A$
END FUNCTION
FUNCTION LoadOverlayImage&
DIM MemoryBlock AS _MEM, TempImage AS LONG
DIM NewWidth AS INTEGER, NewHeight AS INTEGER, A$, BASFILE$
A$ = gifOverlayImage$
IF LEN(A$) = 0 THEN EXIT FUNCTION
NewWidth = CVI(LEFT$(A$, 2))
NewHeight = CVI(MID$(A$, 3, 2))
A$ = MID$(A$, 5)
BASFILE$ = gifUnpack$(A$)
TempImage = _NEWIMAGE(NewWidth, NewHeight, 32)
MemoryBlock = _MEMIMAGE(TempImage)
__UI_MemCopy MemoryBlock.OFFSET, _OFFSET(BASFILE$), LEN(BASFILE$)
_MEMFREE MemoryBlock
LoadOverlayImage& = TempImage
END FUNCTION
FUNCTION gifUnpack$ (PackedData$)
'Adapted from Dav's BIN2BAS
'http://www.qbasicnews.com/dav/qb64.php
DIM A$, i&, B$, C%, F$, C$, t%, B&, X$, btemp$
A$ = PackedData$
FOR i& = 1 TO LEN(A$) STEP 4: B$ = MID$(A$, i&, 4)
IF INSTR(1, B$, "%") THEN
FOR C% = 1 TO LEN(B$): F$ = MID$(B$, C%, 1)
IF F$ <> "%" THEN C$ = C$ + F$
NEXT: B$ = C$
END IF: FOR t% = LEN(B$) TO 1 STEP -1
B& = B& * 64 + ASC(MID$(B$, t%)) - 48
NEXT: X$ = "": FOR t% = 1 TO LEN(B$) - 1
X$ = X$ + CHR$(B& AND 255): B& = B& \ 256
NEXT: btemp$ = btemp$ + X$: NEXT
gifUnpack$ = btemp$
END FUNCTION
'############################################################################################

View file

@ -1,97 +0,0 @@
': This program uses
': InForm - GUI library for QB64 - Beta version 9
': Fellippe Heitor, 2016-2019 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
': Controls' IDs: ------------------------------------------------------------------
DIM SHARED gifplaySample AS LONG
DIM SHARED PictureBox1 AS LONG
DIM SHARED LoadBT AS LONG
DIM SHARED PlayBT AS LONG
': External modules: ---------------------------------------------------------------
'$INCLUDE:'gifplay.bi'
'$INCLUDE:'..\InForm.bi'
'$INCLUDE:'..\xp.uitheme'
'$INCLUDE:'gifplaySample.frm'
'$INCLUDE:'gifplay.bm'
': Event procedures: ---------------------------------------------------------------
SUB __UI_BeforeInit
END SUB
SUB __UI_OnLoad
Control(PlayBT).Disabled = True
END SUB
SUB __UI_BeforeUpdateDisplay
UpdateGif PictureBox1
END SUB
SUB __UI_BeforeUnload
END SUB
SUB __UI_Click (id AS LONG)
SELECT CASE id
CASE LoadBT
'file 'globe.gif' comes from:
'https://en.wikipedia.org/wiki/GIF#/media/File:Rotating_earth_(large).gif
IF OpenGif(PictureBox1, "globe.gif") THEN
Control(PlayBT).Disabled = False
IF TotalFrames(PictureBox1) > 1 THEN
Caption(PlayBT) = "Play"
ELSE
Caption(PlayBT) = "Static gif"
Control(PlayBT).Disabled = True
END IF
Caption(LoadBT) = "globe.gif loaded"
Control(LoadBT).Disabled = True
ELSE
Answer = MessageBox("File 'globe.gif' could not be found.", "", MsgBox_Exclamation + MsgBox_OkOnly)
END IF
CASE PlayBT
IF GifIsPlaying(PictureBox1) THEN
PauseGif PictureBox1
Caption(PlayBT) = "Play"
ELSE
PlayGif PictureBox1
Caption(PlayBT) = "Pause"
END IF
CASE PictureBox1
HideGifOverlay PictureBox1
END SELECT
END SUB
SUB __UI_MouseEnter (id AS LONG)
END SUB
SUB __UI_MouseLeave (id AS LONG)
END SUB
SUB __UI_FocusIn (id AS LONG)
END SUB
SUB __UI_FocusOut (id AS LONG)
END SUB
SUB __UI_MouseDown (id AS LONG)
END SUB
SUB __UI_MouseUp (id AS LONG)
END SUB
SUB __UI_KeyPress (id AS LONG)
END SUB
SUB __UI_TextChanged (id AS LONG)
END SUB
SUB __UI_ValueChanged (id AS LONG)
END SUB
SUB __UI_FormResized
END SUB
'$INCLUDE:'..\InForm.ui'

View file

@ -1,38 +0,0 @@
': This form was generated by
': InForm - GUI library for QB64 - Beta version 9
': Fellippe Heitor, 2016-2019 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
SUB __UI_LoadForm
DIM __UI_NewID AS LONG
__UI_NewID = __UI_NewControl(__UI_Type_Form, "gifplaySample", 300, 281, 0, 0, 0)
SetCaption __UI_NewID, "gifplay Sample"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).Font = SetFont("arial.ttf", 12)
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "PictureBox1", 230, 230, 36, 12, 0)
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_Button, "LoadBT", 123, 23, 36, 247, 0)
SetCaption __UI_NewID, "Load globe.gif"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "PlayBT", 80, 23, 186, 247, 0)
SetCaption __UI_NewID, "Play"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).CanHaveFocus = True
END SUB
SUB __UI_AssignIDs
gifplaySample = __UI_GetID("gifplaySample")
PictureBox1 = __UI_GetID("PictureBox1")
LoadBT = __UI_GetID("LoadBT")
PlayBT = __UI_GetID("PlayBT")
END SUB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 1.4 MiB

View file

@ -1,21 +0,0 @@
'INI Manager
'Fellippe Heitor, 2017-2019 - fellippe@qb64.org - @fellippeheitor
'This file isn't required to be at the top of your programs,
'unless you intend to use OPTION _EXPLICIT
'Global variables declaration
DIM currentIniFileName$
DIM currentIniFileLOF AS _UNSIGNED LONG
DIM IniWholeFile$
DIM IniSectionData$
DIM IniPosition AS _UNSIGNED LONG
DIM IniNewFile$
DIM IniLastSection$
DIM IniLastKey$
DIM IniLF$
DIM IniDisableAutoCommit
DIM IniCODE
DIM IniAllowBasicComments
DIM IniForceReload

View file

@ -1,758 +0,0 @@
'INI Manager - Beta 4
'Fellippe Heitor, 2017 - fellippe@qb64.org - @fellippeheitor
SUB IniSortSection (file$, __section$)
SHARED IniCODE, IniLastKey$, IniWholeFile$
SHARED IniDisableAutoCommit
REDIM Keys(1 TO 100) AS STRING
DIM TotalKeys, tempValue$, i AS LONG, Backup$, CommitBackup
IF IniFormatSection$(__section$) = "[]" THEN IniCODE = 15: EXIT SUB
DO
tempValue$ = ReadSetting(file$, __section$, "")
IF LEFT$(IniINFO$, 7) = "ERROR: " THEN EXIT SUB
IF IniCODE = 10 THEN EXIT DO
TotalKeys = TotalKeys + 1
IF TotalKeys > UBOUND(Keys) THEN
REDIM _PRESERVE Keys(1 TO UBOUND(Keys) + 100) AS STRING
END IF
Keys(TotalKeys) = IniLastKey$ + "=" + tempValue$
LOOP
REDIM _PRESERVE Keys(1 TO TotalKeys) AS STRING
IF IniArraySort(Keys()) = 0 THEN IniCODE = 23: EXIT SUB
CommitBackup = IniDisableAutoCommit
IniDisableAutoCommit = -1 'Prevent every minor change from being written to disk
Backup$ = IniWholeFile$
FOR i = 1 TO TotalKeys
IniDeleteKey file$, __section$, LEFT$(Keys(i), INSTR(Keys(i), "=") - 1)
IF LEFT$(IniINFO$, 7) = "ERROR: " THEN
IniDisableAutoCommit = CommitBackup
IniWholeFile$ = Backup$
EXIT SUB
END IF
NEXT
FOR i = 1 TO TotalKeys
WriteSetting file$, __section$, LEFT$(Keys(i), INSTR(Keys(i), "=") - 1), MID$(Keys(i), INSTR(Keys(i), "=") + 1)
IF LEFT$(IniINFO$, 7) = "ERROR: " THEN
IniDisableAutoCommit = CommitBackup
IniWholeFile$ = Backup$
EXIT SUB
END IF
NEXT
IniDisableAutoCommit = CommitBackup 'Restore writing to disk (or previously set state) and
IniCommit ' commit changes.
IniCODE = 22
END SUB
SUB IniDeleteSection (file$, __section$)
SHARED IniNewFile$, IniCODE, currentIniFileName$
SHARED IniLF$, IniWholeFile$, currentIniFileLOF AS _UNSIGNED LONG
IniLoad file$
IF IniCODE THEN EXIT SUB
DIM a$
IniCODE = 0
a$ = IniGetSection(__section$)
IF IniCODE THEN EXIT SUB
IniNewFile$ = LEFT$(IniWholeFile$, INSTR(IniWholeFile$, a$) - 1)
IniNewFile$ = IniNewFile$ + MID$(IniWholeFile$, INSTR(IniWholeFile$, a$) + LEN(a$ + IniLF$))
IniCommit
IniCODE = 13
END SUB
SUB IniDeleteKey (file$, __section$, __key$)
SHARED IniPosition AS _UNSIGNED LONG, IniCODE
SHARED IniLF$, IniWholeFile$, IniSectionData$
SHARED IniLastSection$, IniLastKey$, IniNewFile$
DIM tempValue$, fileNum AS INTEGER
DIM section$, key$, thisLine$
DIM FoundLF AS _UNSIGNED LONG
IniCODE = 0
'prepare variables for the write operation
section$ = IniFormatSection$(__section$)
IF IniCODE THEN EXIT SUB
key$ = LTRIM$(RTRIM$(__key$))
IF key$ = "" THEN IniCODE = 12: EXIT SUB
IniLastKey$ = key$
'Read the existing key to fill IniPosition
tempValue$ = ReadSetting$(file$, section$, key$)
IF IniCODE > 0 AND IniCODE <> 2 THEN EXIT SUB 'key not found
'map IniPosition (set in the section block) to the global file position
IniPosition = INSTR(IniWholeFile$, IniSectionData$) + IniPosition - 1
FoundLF = INSTR(IniPosition, IniWholeFile$, IniLF$)
IF FoundLF = 0 THEN FoundLF = LEN(IniWholeFile$)
IniNewFile$ = LEFT$(IniWholeFile$, IniPosition - 1) + MID$(IniWholeFile$, FoundLF + LEN(IniLF$))
IniCommit
IniCODE = 19
END SUB
SUB IniMoveKey (file$, __section$, __key$, __newsection$)
'A move operation is a copy operation + a delete operation
SHARED IniCODE
DIM tempValue$
tempValue$ = ReadSetting(file$, __section$, __key$)
IF IniCODE > 0 AND IniCODE <> 2 THEN EXIT SUB
WriteSetting file$, __newsection$, __key$, tempValue$
IF IniCODE > 0 AND IniCODE <> 2 AND IniCODE <> 7 AND IniCODE <> 9 THEN EXIT SUB
IniDeleteKey file$, __section$, __key$
IF IniCODE = 19 THEN IniCODE = 20
END SUB
SUB IniCommit
SHARED currentIniFileName$, IniWholeFile$, currentIniFileLOF AS _UNSIGNED LONG
SHARED IniNewFile$, IniDisableAutoCommit, IniCODE
IF currentIniFileName$ = "" THEN IniCODE = 18: EXIT SUB
IniWholeFile$ = IniNewFile$
currentIniFileLOF = LEN(IniNewFile$)
IF NOT IniDisableAutoCommit THEN
DIM fileNum AS INTEGER
fileNum = FREEFILE
OPEN currentIniFileName$ FOR BINARY AS #fileNum
IF LEN(IniWholeFile$) < LOF(fileNum) THEN
CLOSE fileNum
OPEN currentIniFileName$ FOR OUTPUT AS #fileNum: CLOSE #fileNum
OPEN currentIniFileName$ FOR BINARY AS #fileNum
END IF
PUT #fileNum, 1, IniNewFile$
CLOSE #fileNum
END IF
END SUB
FUNCTION IniGetSection$ (__section$)
SHARED IniPosition AS _UNSIGNED LONG, IniCODE, currentIniFileName$
SHARED IniLF$, IniWholeFile$, currentIniFileLOF AS _UNSIGNED LONG
IF currentIniFileName$ = "" THEN IniCODE = 18: EXIT FUNCTION
IF currentIniFileLOF = 0 OR LEN(LTRIM$(RTRIM$(IniWholeFile$))) = 0 THEN IniCODE = 17: EXIT FUNCTION
IniCODE = 0
DIM section$, foundSection AS _UNSIGNED LONG, endSection AS _UNSIGNED LONG
DIM i AS _UNSIGNED LONG, Bracket1 AS _UNSIGNED LONG, sectionStart AS _UNSIGNED LONG
DIM inQuote AS _BYTE
section$ = IniFormatSection$(__section$)
IF IniCODE THEN EXIT FUNCTION
IF section$ = "[]" THEN
'fetch the "global" section, if present
sectionStart = INSTR(IniWholeFile$, "[")
IF sectionStart = 0 THEN IniGetSection$ = IniWholeFile$: EXIT FUNCTION
FOR i = sectionStart - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN foundSection = i + 1: EXIT FOR
IF ASC(IniWholeFile$, i) <> 32 THEN EXIT FOR
NEXT
IF i = 0 THEN foundSection = 1
IniGetSection$ = LEFT$(IniWholeFile$, foundSection - 1)
ELSE
DO
sectionStart = INSTR(sectionStart + 1, LCASE$(IniWholeFile$), LCASE$(section$))
IF sectionStart = 0 THEN IniCODE = 14: EXIT DO
'make sure it's a valid section header
foundSection = 0
FOR i = sectionStart - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN foundSection = i + 1: EXIT FOR
IF ASC(IniWholeFile$, i) <> 32 THEN EXIT FOR
NEXT
IF i = 0 THEN foundSection = 1
IF foundSection > 0 THEN
'we found it; time to identify where this section ends
'(either another [section] or the end of the file
Bracket1 = sectionStart
checkAgain:
Bracket1 = INSTR(Bracket1 + 1, IniWholeFile$, "[")
IF Bracket1 > 0 THEN
'found a bracket; check if it's inside quotes
inQuote = 0
FOR i = 1 TO Bracket1 - 1
IF ASC(IniWholeFile$, i) = 34 THEN inQuote = NOT inQuote
NEXT
IF inQuote THEN GOTO checkAgain
FOR i = Bracket1 - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN endSection = i + 1 - LEN(IniLF$): EXIT FOR
IF ASC(IniWholeFile$, i) = 61 THEN GOTO checkAgain 'bracket is inside a key's value
IF i <= foundSection THEN EXIT FOR
NEXT
IniGetSection$ = MID$(IniWholeFile$, foundSection, endSection - foundSection)
ELSE
IniGetSection$ = MID$(IniWholeFile$, foundSection)
END IF
EXIT FUNCTION
END IF
LOOP
END IF
END FUNCTION
FUNCTION IniFormatSection$ (__section$)
SHARED IniCODE
DIM section$
section$ = LTRIM$(RTRIM$(__section$))
'sections are in the format [section name] - add brackets if not passed
IF LEFT$(section$, 1) <> "[" THEN section$ = "[" + section$
IF RIGHT$(section$, 1) <> "]" THEN section$ = section$ + "]"
IF INSTR(MID$(section$, 2, LEN(section$) - 3), "[") OR INSTR(MID$(section$, 2, LEN(section$) - 3), "]") THEN
IniCODE = 15
EXIT FUNCTION
END IF
IniFormatSection$ = section$
END FUNCTION
FUNCTION ReadSetting$ (file$, __section$, __key$)
SHARED IniLastSection$, IniLastKey$, IniWholeFile$, IniLF$
SHARED IniPosition AS _UNSIGNED LONG, IniSectionData$
SHARED IniCODE, IniAllowBasicComments
SHARED currentIniFileLOF AS _UNSIGNED LONG
IniLoad file$
IF IniCODE THEN EXIT SUB
IF currentIniFileLOF = 0 OR LEN(LTRIM$(RTRIM$(IniWholeFile$))) = 0 THEN IniCODE = 17: EXIT FUNCTION
DIM Equal AS _UNSIGNED LONG, tempValue$, key$, section$
DIM Quote AS _UNSIGNED LONG, Comment AS _UNSIGNED LONG
DIM i AS LONG, FoundLF AS _UNSIGNED LONG
section$ = IniFormatSection(__section$)
IF IniCODE THEN EXIT SUB
'fetch the desired section$
IniSectionData$ = IniGetSection(section$)
IF IniCODE > 0 AND IniCODE <> 17 THEN EXIT SUB
IF LEN(IniSectionData$) = 0 AND section$ <> "[]" THEN IniCODE = 14: EXIT SUB
IniLastSection$ = section$
IniPosition = 0
key$ = LTRIM$(RTRIM$(__key$))
IniLastKey$ = ""
IF key$ = "" THEN
IF section$ = "[]" THEN IniSectionData$ = IniWholeFile$
key$ = IniNextKey
IF IniCODE THEN EXIT SUB
IF key$ = "" THEN
IniCODE = 10
EXIT SUB
END IF
END IF
IF LEFT$(key$, 1) = ";" OR LEFT$(key$, 1) = "'" OR INSTR(key$, "[") > 0 OR INSTR(key$, "]") > 0 OR INSTR(key$, "=") > 0 THEN
IniCODE = 12
EXIT SUB
END IF
IniLastKey$ = key$
IF IniPosition > 0 THEN Equal = IniPosition: GOTO KeyFound
CheckKey:
IniPosition = INSTR(IniPosition + 1, LCASE$(IniSectionData$), LCASE$(key$))
IF IniPosition > 0 THEN
'identify if this occurrence is actually a key and not part of a key name/value
FOR i = IniPosition - 1 TO 1 STEP -1
IF ASC(IniSectionData$, i) = 10 THEN EXIT FOR
IF ASC(IniSectionData$, i) <> 10 AND ASC(IniSectionData$, i) <> 32 THEN
'not a key
GOTO CheckKey
END IF
NEXT
'check if there's nothing but an equal sign ahead
FOR i = IniPosition + LEN(key$) TO LEN(IniSectionData$)
IF ASC(IniSectionData$, i) = ASC("=") THEN EXIT FOR
IF ASC(IniSectionData$, i) <> ASC("=") AND ASC(IniSectionData$, i) <> 32 THEN
'not the key
GOTO CheckKey
END IF
NEXT
'so far so good; check if there is an assignment
Equal = INSTR(IniPosition, IniSectionData$, "=")
KeyFound:
FoundLF = INSTR(IniPosition, IniSectionData$, IniLF$)
IF FoundLF > 0 THEN
IF Equal > FoundLF THEN GOTO CheckKey
ELSE
FoundLF = LEN(IniSectionData$) + 1
IF Equal = 0 THEN GOTO CheckKey
END IF
tempValue$ = LTRIM$(RTRIM$(MID$(IniSectionData$, Equal + 1, FoundLF - Equal - 1)))
IF LEN(tempValue$) > 0 THEN
IF LEFT$(tempValue$, 1) = CHR$(34) THEN
tempValue$ = MID$(tempValue$, 2)
Quote = INSTR(tempValue$, CHR$(34))
IF Quote > 0 THEN
tempValue$ = LEFT$(tempValue$, Quote - 1)
END IF
ELSE
IF IniAllowBasicComments THEN Comment = INSTR(tempValue$, "'") 'BASIC style comments accepted
IF Comment = 0 THEN Comment = INSTR(tempValue$, ";")
IF Comment > 0 THEN
tempValue$ = LTRIM$(RTRIM$(LEFT$(tempValue$, Comment - 1)))
END IF
END IF
ELSE
IniCODE = 2
END IF
ELSE
IniCODE = 3
EXIT FUNCTION
END IF
ReadSetting$ = tempValue$
IniLastSection$ = IniCurrentSection$
END SUB
FUNCTION IniCurrentSection$
SHARED IniPosition AS _UNSIGNED LONG, IniSectionData$, IniWholeFile$
DIM GlobalPosition AS _UNSIGNED LONG, i AS _UNSIGNED LONG
DIM ClosingBracket AS _UNSIGNED LONG
GlobalPosition = INSTR(IniWholeFile$, IniSectionData$) + IniPosition - 1
CheckSection:
FOR i = GlobalPosition - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = ASC("[") THEN
GlobalPosition = i: EXIT FOR
END IF
NEXT
IF i = 0 THEN IniCurrentSection$ = "[]": EXIT FUNCTION
'identify if this occurrence is actually a section header and not something else
FOR i = GlobalPosition - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN EXIT FOR
IF ASC(IniWholeFile$, i) <> 10 AND ASC(IniWholeFile$, i) <> 32 THEN
'not a section header
GOTO CheckSection
END IF
NEXT
ClosingBracket = INSTR(GlobalPosition, IniWholeFile$, "]")
IF ClosingBracket > 0 THEN
IniCurrentSection$ = MID$(IniWholeFile$, GlobalPosition, ClosingBracket - GlobalPosition + 1)
END IF
END FUNCTION
SUB WriteSetting (file$, __section$, __key$, __value$)
SHARED IniPosition AS _UNSIGNED LONG, IniCODE, currentIniFileName$
SHARED IniLF$, IniWholeFile$, IniSectionData$
SHARED IniLastSection$, IniLastKey$, IniNewFile$
DIM tempValue$, section$, key$, value$, thisLine$
IniCODE = 0
'prepare variables for the write operation
section$ = IniFormatSection$(__section$)
IF IniCODE THEN EXIT SUB
key$ = LTRIM$(RTRIM$(__key$))
IF key$ = "" THEN IniCODE = 12: EXIT SUB
IniLastKey$ = key$
value$ = LTRIM$(RTRIM$(__value$))
IF LTRIM$(STR$(VAL(value$))) <> value$ THEN
'if not a numeric value and value contains spaces, add quotation marks
IF INSTR(value$, CHR$(32)) THEN value$ = CHR$(34) + value$ + CHR$(34)
END IF
'Read the existing key to fill IniPosition
tempValue$ = ReadSetting$(file$, section$, key$)
'map IniPosition (set in the section block) to the global file position
IniPosition = INSTR(IniWholeFile$, IniSectionData$) + IniPosition - 1
IF IniCODE = 1 OR IniCODE = 17 THEN
'file not found or empty; create a new one
IF file$ = "" THEN file$ = currentIniFileName$
IF file$ = "" THEN IniCODE = 21: EXIT SUB
currentIniFileName$ = file$
IF section$ <> "[]" THEN
IniNewFile$ = section$ + IniLF$
END IF
IniNewFile$ = IniNewFile$ + key$ + "=" + value$
IniCODE = 0
IniCommit
IniLoad file$
IF IniCODE = 0 THEN IniCODE = 11
IniLastSection$ = section$
EXIT SUB
END IF
IF IniCODE = 0 OR IniCODE = 2 THEN 'key found and read back; write new value$
IF LCASE$(IniLastSection$) = LCASE$(section$) THEN
IF LTRIM$(RTRIM$(__value$)) = tempValue$ AND LEN(LTRIM$(RTRIM$(__value$))) > 0 THEN
'identical values skip the writing routine
IniCODE = 8
EXIT SUB
END IF
DIM nextLine AS _UNSIGNED LONG
nextLine = INSTR(IniPosition + 1, IniWholeFile$, IniLF$)
'create new file contents
IniNewFile$ = LEFT$(IniWholeFile$, IniPosition - 1)
IniNewFile$ = IniNewFile$ + key$ + "=" + value$
IF nextLine > 0 THEN
IniNewFile$ = IniNewFile$ + MID$(IniWholeFile$, nextLine)
END IF
IniCommit
IniCODE = 4
END IF
ELSEIF IniCODE = 3 OR IniCODE = 14 THEN 'Key not found, Section not found
IniCODE = 0
IF LCASE$(IniLastSection$) = LCASE$(section$) THEN
'find this section$ in the current ini file;
DIM Bracket1 AS _UNSIGNED LONG, Bracket2 AS _UNSIGNED LONG, foundSection$
DIM beginSection AS _UNSIGNED LONG, endSection AS _UNSIGNED LONG
DIM currentPos AS _UNSIGNED LONG, i AS _UNSIGNED LONG
beginSection = 0
endSection = 0
CheckSection:
beginSection = INSTR(beginSection + 1, LCASE$(IniWholeFile$), LCASE$(section$))
IF beginSection = 0 THEN GOTO CreateSection
'identify if this occurrence is actually the section header and not something else
FOR i = beginSection - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN EXIT FOR
IF ASC(IniWholeFile$, i) <> 10 AND ASC(IniWholeFile$, i) <> 32 THEN
'not the section header
GOTO CheckSection
END IF
NEXT
'we found it; time to identify where this section ends
'(either another [section], a blank line or the end of the file
Bracket1 = INSTR(beginSection + 1, IniWholeFile$, "[")
IF Bracket1 > 0 THEN
FOR i = Bracket1 - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN endSection = i + 1 - LEN(IniLF$): EXIT FOR
IF i <= beginSection THEN EXIT FOR
NEXT
END IF
IF endSection > 0 THEN
'add values to the end of the specified section$
IniNewFile$ = LEFT$(IniWholeFile$, endSection - 1)
IniNewFile$ = IniNewFile$ + key$ + "=" + value$ + IniLF$
IF MID$(IniWholeFile$, endSection, 2) <> IniLF$ THEN IniNewFile$ = IniNewFile$ + IniLF$
IniNewFile$ = IniNewFile$ + MID$(IniWholeFile$, endSection)
ELSE
'add values to the end of the file
IniNewFile$ = IniWholeFile$
IF RIGHT$(IniNewFile$, 2) = IniLF$ THEN
IniNewFile$ = IniNewFile$ + key$ + "=" + value$
ELSE
IniNewFile$ = IniNewFile$ + IniLF$ + key$ + "=" + value$
END IF
END IF
IniCommit
IF IniCODE = 0 THEN IniCODE = 7
EXIT SUB
ELSE
CreateSection:
IniNewFile$ = IniWholeFile$
IF section$ = "[]" THEN GOTO WriteAtTop
IF RIGHT$(IniNewFile$, 4) = IniLF$ + IniLF$ THEN
IniNewFile$ = IniNewFile$ + section$ + IniLF$ + key$ + "=" + value$ + IniLF$
ELSEIF RIGHT$(IniNewFile$, 2) = IniLF$ THEN
IniNewFile$ = IniNewFile$ + IniLF$ + section$ + IniLF$ + key$ + "=" + value$ + IniLF$
ELSE
IniNewFile$ = IniNewFile$ + IniLF$ + IniLF$ + section$ + IniLF$ + key$ + "=" + value$ + IniLF$
END IF
IniCommit
IF IniCODE = 0 THEN IniCODE = 9 ELSE IniCODE = 16
EXIT SUB
END IF
'if not found, key$=value$ is written to the beginning of the file
WriteAtTop:
IniNewFile$ = key$ + "=" + value$ + IniLF$
IF LEFT$(LTRIM$(IniWholeFile$), 1) = "[" THEN IniNewFile$ = IniNewFile$ + IniLF$
IniNewFile$ = IniNewFile$ + IniWholeFile$
IniCommit
IniCODE = 5
END IF
END SUB
SUB IniSetForceReload (state AS _BYTE)
SHARED IniForceReload
IF state THEN
IniForceReload = -1
ELSE
IniForceReload = 0
END IF
END SUB
SUB IniClose
SHARED IniDisableAutoCommit, currentIniFileName$
IniDisableAutoCommit = 0
IniCommit
currentIniFileName$ = ""
END SUB
SUB IniLoad (file$)
SHARED IniCODE, currentIniFileName$, IniLF$, IniWholeFile$
SHARED currentIniFileLOF AS _UNSIGNED LONG
SHARED IniForceReload
DIM fileNum AS INTEGER
'Error messages are returned with IniCODE
'Error descriptions can be fetched with function IniINFO$
IniCODE = 0
IF file$ <> "" AND currentIniFileName$ <> file$ THEN currentIniFileName$ = ""
IF IniForceReload AND LEN(currentIniFileName$) > 0 THEN
file$ = currentIniFileName$
currentIniFileName$ = ""
END IF
'Passing an empty file$ is allowed if user already
'passed a valid file in this session.
IF currentIniFileName$ = "" THEN
'initialization
IF _FILEEXISTS(file$) THEN
currentIniFileName$ = file$
'Load file into memory
fileNum = FREEFILE
OPEN currentIniFileName$ FOR BINARY AS #fileNum
currentIniFileLOF = LOF(fileNum)
IniWholeFile$ = SPACE$(currentIniFileLOF)
GET #fileNum, 1, IniWholeFile$
CLOSE #fileNum
'Check if this ini file uses CRLF or LF
IF INSTR(IniWholeFile$, CHR$(13)) THEN IniLF$ = CHR$(13) + CHR$(10) ELSE IniLF$ = CHR$(10)
'IF RIGHT$(IniWholeFile$, 2) <> IniLF$ THEN IniWholeFile$ = IniWholeFile$ + IniLF$
ELSE
IniFileNotFound:
IniCODE = 1
$IF WIN THEN
IniLF$ = CHR$(13) + CHR$(10)
$ELSE
IniLF$ = CHR$(10)
$END IF
EXIT SUB
END IF
ELSEIF NOT _FILEEXISTS(currentIniFileName$) THEN
currentIniFileName$ = ""
GOTO IniFileNotFound
END IF
END SUB
FUNCTION IniNextKey$
SHARED IniCODE, IniLF$, currentIniFileName$, IniSectionData$
SHARED IniPosition AS _UNSIGNED LONG
STATIC lastDataBlock$, position AS _UNSIGNED LONG, tempLF$
IF currentIniFileName$ = "" THEN IniCODE = 18: EXIT FUNCTION
IF IniSectionData$ <> lastDataBlock$ THEN
position = 0
lastDataBlock$ = IniSectionData$
'data blocks must end with a line feed for parsing purposes
IF RIGHT$(IniSectionData$, LEN(IniLF$)) <> IniLF$ THEN tempLF$ = IniLF$ ELSE tempLF$ = ""
END IF
DIM Equal AS _UNSIGNED LONG, tempKey$
FindKey:
Equal = INSTR(position, IniSectionData$ + tempLF$, "=")
IF Equal = 0 THEN position = 0: EXIT FUNCTION
tempKey$ = LTRIM$(RTRIM$(MID$(IniSectionData$ + tempLF$, position + 1, Equal - position - 1)))
IF INSTR(tempKey$, CHR$(10)) > 0 THEN tempKey$ = MID$(tempKey$, INSTR(tempKey$, CHR$(10)) + 1)
DO WHILE LEFT$(tempKey$, LEN(IniLF$)) = IniLF$
tempKey$ = MID$(tempKey$, LEN(IniLF$) + 1)
position = position + LEN(IniLF$)
LOOP
position = INSTR(position, IniSectionData$ + tempLF$, IniLF$) + 1
IF LEFT$(tempKey$, 1) = ";" OR LEFT$(tempKey$, 1) = "'" OR INSTR(tempKey$, "[") > 0 OR INSTR(tempKey$, "]") > 0 OR INSTR(tempKey$, "=") > 0 THEN
GOTO FindKey
END IF
IniNextKey$ = tempKey$
IniPosition = Equal
END FUNCTION
FUNCTION IniNextSection$ (file$)
SHARED IniCODE, IniLF$, IniWholeFile$
STATIC sectionStart AS _UNSIGNED LONG
IniLoad file$
IF LEFT$(IniINFO$, 6) = "ERROR:" THEN EXIT SUB
IniCODE = 0
DIM section$, foundSection AS _UNSIGNED LONG, endSection AS _UNSIGNED LONG
DIM i AS _UNSIGNED LONG, Bracket1 AS _UNSIGNED LONG, Bracket2 AS _UNSIGNED LONG
FindNext:
sectionStart = INSTR(sectionStart + 1, IniWholeFile$, "[")
IF sectionStart = 0 THEN IniCODE = 24: EXIT FUNCTION
'make sure it's a valid section header
foundSection = 0
FOR i = sectionStart - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN foundSection = i + 1: EXIT FOR
IF ASC(IniWholeFile$, i) <> 32 THEN GOTO FindNext
NEXT
IF i = 0 THEN foundSection = 1
IF foundSection > 0 THEN
'we found it; time to identify where this section ends
'(either another [section] or the end of the file
Bracket2 = INSTR(sectionStart + 1, IniWholeFile$, "]")
IF Bracket2 = 0 THEN IniCODE = 24: EXIT FUNCTION
Bracket1 = INSTR(sectionStart + 1, IniWholeFile$, "[")
IF Bracket1 > 0 THEN
FOR i = Bracket1 - 1 TO 1 STEP -1
IF ASC(IniWholeFile$, i) = 10 THEN endSection = i + 1 - LEN(IniLF$): EXIT FOR
IF i <= foundSection THEN EXIT FOR
NEXT
IniNextSection$ = MID$(IniWholeFile$, foundSection, Bracket2 - foundSection + 1)
ELSE
IniNextSection$ = MID$(IniWholeFile$, foundSection, Bracket2 - foundSection + 1)
IniCODE = 24
sectionStart = 0
END IF
ELSE
IniCODE = 24
END IF
END FUNCTION
FUNCTION IniINFO$
SHARED IniCODE
SELECT CASE IniCODE
CASE 0: IniINFO$ = "Operation successful"
CASE 1: IniINFO$ = "ERROR: File not found"
CASE 2: IniINFO$ = "Empty value"
CASE 3: IniINFO$ = "ERROR: Key not found"
CASE 4: IniINFO$ = "Key updated"
CASE 5: IniINFO$ = "Global key created"
CASE 7: IniINFO$ = "Key created in existing section"
CASE 8: IniINFO$ = "No changes applied (same value)"
CASE 9: IniINFO$ = "New section created; key created"
CASE 10: IniINFO$ = "No more keys"
CASE 11: IniINFO$ = "File created; new key added"
CASE 12: IniINFO$ = "ERROR: Invalid key"
CASE 13: IniINFO$ = "Section deleted"
CASE 14: IniINFO$ = "ERROR: Section not found"
CASE 15: IniINFO$ = "ERROR: Invalid section"
CASE 16: IniINFO$ = "New section created; existing key moved"
CASE 17: IniINFO$ = "ERROR: Empty file"
CASE 18: IniINFO$ = "ERROR: No file open"
CASE 19: IniINFO$ = "Key deleted"
CASE 20: IniINFO$ = "Key moved"
CASE 21: IniINFO$ = "ERROR: Invalid file name/path"
CASE 22: IniINFO$ = "Section sorted"
CASE 23: IniINFO$ = "No changes applied; section already sorted"
CASE 24: IniINFO$ = "No more sections"
CASE ELSE: IniINFO$ = "ERROR: <invalid error code>"
END SELECT
END FUNCTION
'Written in BASIC by Luke Ceddia for ide_methods.bas (QB64)
'After Cormen, Leiserson, Rivest & Stein "Introduction To Algoritms" via Wikipedia
'Adapted for use in .INI Manager
FUNCTION IniArraySort%% (arr() AS STRING)
DIM i&, x$, j&, moves&
FOR i& = LBOUND(arr) + 1 TO UBOUND(arr)
x$ = arr(i&)
j& = i& - 1
WHILE j& >= LBOUND(arr)
IF arr(j&) <= x$ THEN EXIT WHILE
moves& = moves& + 1
arr$(j& + 1) = arr$(j&)
j& = j& - 1
WEND
arr$(j& + 1) = x$
NEXT i&
'Returns -1 (true) if any changes were made
IniArraySort%% = moves& > 0
END FUNCTION

View file

@ -4,10 +4,3 @@ Artist: Custom Icon Design (Available for custom work)
Iconset: Flatastic 11 Icons (60 icons)
License: Free for non-commercial use.
Commercial usage: Buy commercial license here: http://www.customicondesign.com/free-icons/flatastic-icon-set/flatastic-part-11
http://www.iconarchive.com/show/oxygen-icons-by-oxygen-icons.org/Apps-system-software-update-icon.html
"Apps system software update Icon"
Artist: Oxygen Team
Iconset: Oxygen Icons (883 icons)
License: GNU Lesser General Public License
Commercial usage: Allowed

Binary file not shown.

Before

Width:  |  Height:  |  Size: 211 KiB

File diff suppressed because it is too large Load diff

View file

@ -1,78 +0,0 @@
': This form was generated by
': InForm - GUI library for QB64 - Beta version 9
': Fellippe Heitor, 2016-2019 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
SUB __UI_LoadForm
$EXEICON:'./../resources/updater.ico'
DIM __UI_NewID AS LONG
__UI_NewID = __UI_NewControl(__UI_Type_Form, "InFormSetup", 500, 425, 0, 0, 0)
SetCaption __UI_NewID, "InForm Setup"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).Font = SetFont("segoeui.ttf?arial.ttf?/Library/Fonts/Arial.ttf?/usr/share/fonts/truetype/liberation/LiberationSans-Regular.ttf?/usr/share/fonts/TTF/arial.ttf?InForm/resources/NotoMono-Regular.ttf?cour.ttf", 12)
Control(__UI_NewID).CenteredWindow = True
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "PictureBox2", 500, 150, 0, 0, 0)
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).BackColor = _RGB32(255, 255, 255)
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "InFormresourcesApplicationicon128PX", 128, 128, 10, 11, 0)
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).BackStyle = __UI_Transparent
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_Label, "InFormLB", 258, 90, 199, 22, 0)
SetCaption __UI_NewID, "InForm"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).Font = SetFont("segoeui.ttf?arial.ttf?/Library/Fonts/Arial.ttf?/usr/share/fonts/truetype/liberation/LiberationSans-Regular.ttf?/usr/share/fonts/TTF/arial.ttf?InForm/resources/NotoMono-Regular.ttf?cour.ttf", 72)
Control(__UI_NewID).BackStyle = __UI_Transparent
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_Label, "forQB64LB", 152, 43, 305, 88, 0)
SetCaption __UI_NewID, "for QB64"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).Font = SetFont("segoeui.ttf?arial.ttf?/Library/Fonts/Arial.ttf?/usr/share/fonts/truetype/liberation/LiberationSans-Regular.ttf?/usr/share/fonts/TTF/arial.ttf?InForm/resources/NotoMono-Regular.ttf?cour.ttf", 32)
Control(__UI_NewID).BackStyle = __UI_Transparent
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_ListBox, "ListBox1", 480, 224, 10, 159, 0)
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).AutoScroll = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "RetryBT", 80, 23, 10, 392, 0)
SetCaption __UI_NewID, "&Retry"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).Hidden = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "CancelBT", 80, 23, 410, 392, 0)
SetCaption __UI_NewID, "&Cancel"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "ActivityIndicator", 266, 32, 117, 388, 0)
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
END SUB
SUB __UI_AssignIDs
InFormSetup = __UI_GetID("InFormSetup")
PictureBox2 = __UI_GetID("PictureBox2")
InFormresourcesApplicationicon128PX = __UI_GetID("InFormresourcesApplicationicon128PX")
InFormLB = __UI_GetID("InFormLB")
forQB64LB = __UI_GetID("forQB64LB")
ListBox1 = __UI_GetID("ListBox1")
RetryBT = __UI_GetID("RetryBT")
CancelBT = __UI_GetID("CancelBT")
ActivityIndicator = __UI_GetID("ActivityIndicator")
END SUB

View file

@ -1,420 +0,0 @@
': This program uses
': InForm - GUI library for QB64 - Beta version 9
': Fellippe Heitor, 2016-2019 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
': Controls' IDs: ------------------------------------------------------------------
DIM SHARED InFormUpdater AS LONG
DIM SHARED PictureBox2 AS LONG
DIM SHARED InFormresourcesApplicationicon128PX AS LONG
DIM SHARED InFormLB AS LONG
DIM SHARED forQB64LB AS LONG
DIM SHARED ListBox1 AS LONG
DIM SHARED RetryBT AS LONG
DIM SHARED CancelBT AS LONG
DIM SHARED ActivityIndicator AS LONG
DIM SHARED binaryExtension$, pathAppend$
DIM SHARED CheckDevUpdates AS _BYTE
$IF WIN THEN
binaryExtension$ = ".exe"
pathAppend$ = ""
$ELSE
binaryExtension$ = ""
pathAppend$ = "./"
$END IF
': External modules: ---------------------------------------------------------------
'$INCLUDE:'../InForm.bi'
'$INCLUDE:'../xp.uitheme'
'$INCLUDE:'InFormUpdater.frm'
'$INCLUDE:'../ini.bm'
'$include:'../extensions/download.bas'
': Event procedures: ---------------------------------------------------------------
SUB __UI_BeforeInit
END SUB
SUB __UI_OnLoad
Report "Contacting server..."
CHDIR "../.."
IF _FILEEXISTS("InFormUpdate.ini") THEN KILL "InFormUpdate.ini"
DIM value$
value$ = ReadSetting("InForm/InForm.ini", "InForm Settings", "Receive development updates")
IF LEN(value$) THEN
CheckDevUpdates = (value$ = "True")
ELSE
WriteSetting "InForm/InForm.ini", "InForm Settings", "Receive development updates", "False"
CheckDevUpdates = False
END IF
END SUB
SUB __UI_BeforeUpdateDisplay STATIC
DIM NextEvent AS LONG, remoteFile$
SHARED ThisStep AS INTEGER
IF ThisStep = 0 THEN ThisStep = 1
SELECT EVERYCASE ThisStep
CASE 1 'check availability
IF CheckDevUpdates THEN
remoteFile$ = "www.qb64.org/inform/update/latestdev.ini"
ELSE
remoteFile$ = "www.qb64.org/inform/update/latest.ini"
END IF
Result$ = Download$(remoteFile$, "InFormUpdate.ini", 30)
SELECT CASE CVI(LEFT$(Result$, 2))
CASE 1 'Success
Report "Script downloaded:" + STR$(CVL(MID$(Result$, 3))) + " bytes."
ThisStep = 2
NextEvent = True
CASE 2 'Can't reach server
Report "Can't reach server."
ThisStep = -1
NextEvent = True
CASE 3 'Timeout :-(
Report "Failed to download update script."
ThisStep = -1
NextEvent = True
END SELECT
CASE 2 'compare with current version
IF NextEvent THEN NextEvent = False: Report "Parsing update script..."
localVersion$ = ReadSetting("InForm/InFormVersion.bas", "", "CONST __UI_Version")
localVersionNumber! = VAL(ReadSetting("InForm/InFormVersion.bas", "", "CONST __UI_VersionNumber"))
localVersionisBeta%% = VAL(ReadSetting("InForm/InFormVersion.bas", "", "CONST __UI_VersionIsBeta"))
IF localVersionisBeta%% THEN localBeta$ = " Beta Version" ELSE localBeta$ = ""
Report "Local build:" + STR$(localVersionNumber!) + localBeta$
serverVersion$ = ReadSetting("InFormUpdate.ini", "", "version")
serverBeta$ = ReadSetting("InFormUpdate.ini", "", "beta")
serverBeta%% = (serverBeta$ = "true")
IF serverBeta%% THEN serverBeta$ = " Beta Version" ELSE serverBeta$ = ""
Report "Remote build: " + serverVersion$ + serverBeta$
IF VAL(serverVersion$) <= localVersionNumber! THEN
NextEvent = True: ThisStep = 7: EXIT SUB
END IF
thisFile% = 0
baseUrl$ = ReadSetting("InFormUpdate.ini", "", "baseurl")
NextEvent = True: ThisStep = 3
CASE 3 'download new content
IF NextEvent THEN NextEvent = False: Report "Downloading content..."
IF url$ = "" THEN
thisFile% = thisFile% + 1
url$ = ReadSetting("InFormUpdate.ini", LTRIM$(STR$(thisFile%)), "filename")
IF url$ = "" THEN
NextEvent = True: ThisStep = 4: EXIT SUB
END IF
IF INSTR(url$, "/") > 0 THEN
FOR i = LEN(url$) TO 1 STEP -1
IF ASC(url$, i) = 47 THEN '/
target$ = LEFT$(url$, i)
EXIT FOR
END IF
NEXT
IF _DIREXISTS(target$) = 0 THEN MKDIR target$
ELSE
target$ = ""
END IF
outputFileName$ = url$
checksum$ = ReadSetting("InFormUpdate.ini", LTRIM$(STR$(thisFile%)), "checksum")
IF _FILEEXISTS(outputFileName$) THEN
IF getChecksum$(outputFileName$) = checksum$ THEN
url$ = ""
END IF
END IF
IF LEN(url$) THEN Report "Downloading " + outputFileName$ + "...;"
END IF
IF LEN(url$) THEN
IF INSTR(url$, "updater") > 0 THEN
WriteSetting "InForm/InForm.ini", "InForm Settings", "Recompile updater", "True"
END IF
Result$ = Download$(baseUrl$ + url$, outputFileName$, 30)
ELSE
Result$ = MKI$(0)
END IF
SELECT CASE CVI(LEFT$(Result$, 2))
CASE 1 'Success
'Checksum:
IF getChecksum(outputFileName$) <> checksum$ THEN
Report "Failed."
ThisStep = -1
NextEvent = True
EXIT SUB
END IF
Report " done (" + LTRIM$(STR$(CVL(MID$(Result$, 3)))) + " bytes)"
url$ = ""
CASE 2 'Can't reach server
Report "failed."
Report "Can't reach server."
ThisStep = -1
NextEvent = True
CASE 3 'Timeout :-(
Report "failed."
Report "Failed to download update files from server."
ThisStep = -1
NextEvent = True
END SELECT
CASE 4 'compile UiEditor.bas
IF NextEvent THEN NextEvent = False: Report "Compiling UiEditor.bas...": EXIT SUB
SHELL _HIDE pathAppend$ + "qb64" + binaryExtension$ + " -s:exewithsource=false"
Result% = SHELL(pathAppend$ + "qb64" + binaryExtension$ + " -x InForm/UiEditor.bas")
IF Result% > 0 OR _FILEEXISTS(pathAppend$ + "qb64" + binaryExtension$) = 0 THEN
Report "Compilation failed."
ThisStep = -1
NextEvent = True
ELSE
ThisStep = 5
NextEvent = True
END IF
CASE 5 'compile UiEditorPreview.bas
IF NextEvent THEN NextEvent = False: Report "Compiling UiEditorPreview.bas...": EXIT SUB
Result% = SHELL(pathAppend$ + "qb64" + binaryExtension$ + " -x InForm/UiEditorPreview.bas -o InForm/UiEditorPreview.exe")
IF Result% THEN
Report "Compilation failed."
ThisStep = -1
NextEvent = True
ELSE
ThisStep = 6
NextEvent = True
END IF
CASE 6 'clean up
IF NextEvent THEN NextEvent = False: Report "Cleaning up...": EXIT SUB
KILL "InFormUpdate.ini"
ThisStep = 8
NextEvent = True
CASE 7 'already up-to-date
DIM b$
b$ = ""
IF CheckDevUpdates THEN b$ = "\n(You are currently in the development channel; you can\nchange that in InForm Designer, Options menu -> Auto-update)"
Answer = MessageBox("You already have the latest version." + b$, "", MsgBox_OkOnly + MsgBox_Information)
KILL "InFormUpdate.ini"
SYSTEM
CASE 8 'done
IF NextEvent THEN NextEvent = False: Report "Update complete.": EXIT SUB
Result$ = Download$("", "", 30) 'close client
Control(ActivityIndicator).Hidden = True
Caption(CancelBT) = "Finish"
SetFocus CancelBT
CASE 1 TO 6
BeginDraw ActivityIndicator
CLS , __UI_DefaultColor(__UI_Type_Form, 2)
angle = angle + .05
indicatorSize = 2
IF angle > _PI(2) THEN angle = _PI(2) - angle
FOR i = 0 TO 360 STEP 90
CircleFill _WIDTH / 2 + COS(angle + _D2R(i)) * (_WIDTH * .2), _HEIGHT / 2, indicatorSize, _RGBA32(0, 0, 0, map(i, 0, 360, 20, 255))
NEXT
EndDraw ActivityIndicator
CASE ELSE
IF NextEvent THEN NextEvent = False: Report "Updated failed.": AddItem ListBox1, ""
Result$ = Download$("", "", 30)
KILL "InFormUpdate.ini"
Control(RetryBT).Hidden = False
Control(ActivityIndicator).Hidden = True
END SELECT
END SUB
SUB Report (__text$)
STATIC Continue%%
DIM text$
text$ = __text$
IF text$ = "" THEN
Continue%% = False
EXIT SUB
END IF
IF RIGHT$(text$, 1) = ";" THEN
text$ = LEFT$(text$, LEN(text$) - 1)
GOSUB AddThisItem
Continue%% = True
ELSE
GOSUB AddThisItem
Continue%% = False
END IF
EXIT SUB
AddThisItem:
IF Continue%% THEN
text$ = GetItem(ListBox1, Control(ListBox1).Max) + text$
ReplaceItem ListBox1, Control(ListBox1).Max, text$
ELSE
AddItem ListBox1, TIME$ + ": " + text$
END IF
RETURN
END SUB
FUNCTION getChecksum$ (File$)
DIM fileHandle AS LONG
IF _FILEEXISTS(File$) = 0 THEN EXIT SUB
fileHandle = FREEFILE
OPEN File$ FOR BINARY AS fileHandle
DataArray$ = SPACE$(LOF(fileHandle))
GET #fileHandle, 1, DataArray$
CLOSE #fileHandle
getChecksum$ = HEX$(crc32~&(DataArray$))
END FUNCTION
FUNCTION crc32~& (buf AS STRING)
'adapted from https://rosettacode.org/wiki/CRC-32
STATIC table(255) AS _UNSIGNED LONG
STATIC have_table AS _BYTE
DIM crc AS _UNSIGNED LONG, k AS _UNSIGNED LONG
DIM i AS LONG, j AS LONG
IF have_table = 0 THEN
FOR i = 0 TO 255
k = i
FOR j = 0 TO 7
IF (k AND 1) THEN
k = _SHR(k, 1)
k = k XOR &HEDB88320
ELSE
k = _SHR(k, 1)
END IF
table(i) = k
NEXT
NEXT
have_table = -1
END IF
crc = NOT crc ' crc = &Hffffffff
FOR i = 1 TO LEN(buf)
crc = (_SHR(crc, 8)) XOR table((crc AND &HFF) XOR ASC(buf, i))
NEXT
crc32~& = NOT crc
END FUNCTION
SUB CircleFill (x AS LONG, y AS LONG, R AS LONG, C AS _UNSIGNED LONG)
DIM x0 AS SINGLE, y0 AS SINGLE
DIM e AS SINGLE
x0 = R
y0 = 0
e = 0
DO WHILE y0 < x0
IF e <= 0 THEN
y0 = y0 + 1
LINE (x - x0, y + y0)-(x + x0, y + y0), C, BF
LINE (x - x0, y - y0)-(x + x0, y - y0), C, BF
e = e + 2 * y0
ELSE
LINE (x - y0, y - x0)-(x + y0, y - x0), C, BF
LINE (x - y0, y + x0)-(x + y0, y + x0), C, BF
x0 = x0 - 1
e = e - 2 * x0
END IF
LOOP
LINE (x - R, y)-(x + R, y), C, BF
END SUB
FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION
SUB __UI_BeforeUnload
'If you set __UI_UnloadSignal = False here you can
'cancel the user's request to close.
END SUB
SUB __UI_Click (id AS LONG)
SELECT CASE id
CASE InFormUpdater
CASE RetryBT
SHARED ThisStep AS INTEGER
ThisStep = 1
Control(RetryBT).Hidden = True
Control(ActivityIndicator).Hidden = False
Report "Contacting server"
IF _FILEEXISTS("InFormUpdate.ini") THEN KILL "InFormUpdate.ini"
CASE CancelBT
IF Caption(CancelBT) = "Finish" THEN
DIM Answer AS _BYTE
IF _FILEEXISTS("UiEditor" + binaryExtension$) THEN
Answer = MessageBox("Launch InForm Designer?", "", MsgBox_YesNo + MsgBox_Question)
IF Answer = MsgBox_Yes THEN
SHELL _DONTWAIT pathAppend$ + "UiEditor" + binaryExtension$
END IF
END IF
END IF
SYSTEM
END SELECT
END SUB
SUB __UI_MouseEnter (id AS LONG)
SELECT CASE id
END SELECT
END SUB
SUB __UI_MouseLeave (id AS LONG)
SELECT CASE id
END SELECT
END SUB
SUB __UI_FocusIn (id AS LONG)
SELECT CASE id
END SELECT
END SUB
SUB __UI_FocusOut (id AS LONG)
'This event occurs right before a control loses focus.
'To prevent a control from losing focus, set __UI_KeepFocus = True below.
SELECT CASE id
END SELECT
END SUB
SUB __UI_MouseDown (id AS LONG)
SELECT CASE id
END SELECT
END SUB
SUB __UI_MouseUp (id AS LONG)
SELECT CASE id
END SELECT
END SUB
SUB __UI_KeyPress (id AS LONG)
'When this event is fired, __UI_KeyHit will contain the code of the key hit.
'You can change it and even cancel it by making it = 0
SELECT CASE id
END SELECT
END SUB
SUB __UI_TextChanged (id AS LONG)
SELECT CASE id
END SELECT
END SUB
SUB __UI_ValueChanged (id AS LONG)
SELECT CASE id
END SELECT
END SUB
SUB __UI_FormResized
END SUB
'$INCLUDE:'../InForm.ui'

View file

@ -1,79 +0,0 @@
': This form was generated by
': InForm - GUI library for QB64 - Beta version 9
': Fellippe Heitor, 2016-2019 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
SUB __UI_LoadForm
$EXEICON:'./../resources/updater.ico'
DIM __UI_NewID AS LONG
__UI_NewID = __UI_NewControl(__UI_Type_Form, "InFormUpdater", 500, 425, 0, 0, 0)
SetCaption __UI_NewID, "InForm Updater"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).Font = SetFont("../resources/NotoMono-Regular.ttf", 12)
Control(__UI_NewID).CenteredWindow = True
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "PictureBox2", 500, 150, 0, 0, 0)
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).BackColor = _RGB32(255, 255, 255)
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "InFormresourcesApplicationicon128PX", 128, 128, 10, 11, 0)
LoadImage Control(__UI_NewID), "../resources/Application-icon-128.png"
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).BackStyle = __UI_Transparent
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_Label, "InFormLB", 258, 90, 199, 22, 0)
SetCaption __UI_NewID, "InForm"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).Font = SetFont("../resources/NotoMono-Regular.ttf", 72)
Control(__UI_NewID).BackStyle = __UI_Transparent
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_Label, "forQB64LB", 152, 43, 305, 88, 0)
SetCaption __UI_NewID, "for QB64"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).Font = SetFont("../resources/NotoMono-Regular.ttf", 32)
Control(__UI_NewID).BackStyle = __UI_Transparent
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_ListBox, "ListBox1", 480, 224, 10, 159, 0)
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).AutoScroll = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "RetryBT", 80, 23, 10, 392, 0)
SetCaption __UI_NewID, "&Retry"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).Hidden = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "CancelBT", 80, 23, 410, 392, 0)
SetCaption __UI_NewID, "&Cancel"
Control(__UI_NewID).Stretch = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "ActivityIndicator", 266, 32, 117, 388, 0)
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
END SUB
SUB __UI_AssignIDs
InFormUpdater = __UI_GetID("InFormUpdater")
PictureBox2 = __UI_GetID("PictureBox2")
InFormresourcesApplicationicon128PX = __UI_GetID("InFormresourcesApplicationicon128PX")
InFormLB = __UI_GetID("InFormLB")
forQB64LB = __UI_GetID("forQB64LB")
ListBox1 = __UI_GetID("ListBox1")
RetryBT = __UI_GetID("RetryBT")
CancelBT = __UI_GetID("CancelBT")
ActivityIndicator = __UI_GetID("ActivityIndicator")
END SUB

View file

@ -1,12 +1,27 @@
'$INCLUDE:'InFormVersion.bas'
'-----------------------------------------------------------------------------------------------------------------------
' VBDOS to InForm form conversion utility
' Copyright (c) 2024 Samuel Gomes
' Copyright (c) 2023 George McGinn
' Copyright (c) 2022 Fellippe Heitor
'-----------------------------------------------------------------------------------------------------------------------
PRINT "InForm - GUI system for QB64 - "; __UI_Version
$CONSOLE:ONLY
OPTION _EXPLICIT
CONST FALSE%% = 0%%, TRUE%% = NOT FALSE
'$INCLUDE:'InFormVersion.bi'
PRINT "InForm GUI engine for QB64-PE - v"; __UI_Version
PRINT "VBDOS to InForm form conversion utility"
PRINT "-------------------------------------------------"
DIM lf AS STRING * 1, q AS STRING * 1
DIM theFile$
lf = CHR$(10)
q = CHR$(34)
IF LEN(COMMAND$) > 0 THEN
IF _FILEEXISTS(COMMAND$) = 0 THEN PRINT "File not found.": END
theFile$ = COMMAND$
@ -18,8 +33,11 @@ ELSE
IF _FILEEXISTS(theFile$) = 0 THEN PRINT "File "; theFile$; " not found." ELSE EXIT DO
LOOP
END IF
OPEN theFile$ FOR BINARY AS #1
DIM a$
LINE INPUT #1, a$
IF a$ <> "Version 1.00" THEN
PRINT "Expected VBDOS text form file. Exiting."
@ -32,10 +50,11 @@ IF LEFT$(a$, 11) <> "BEGIN Form " THEN
END
END IF
FormName$ = MID$(a$, 12)
DIM FormName$: FormName$ = MID$(a$, 12)
o$ = "'InForm - GUI system for QB64 - " + __UI_Version
o$ = o$ + lf + "'Fellippe Heitor, " + __UI_CopyrightSpan + " - fellippe@qb64.org - @FellippeHeitor"
DIM o$: o$ = "' InForm GUI engine for QB64-PE - v" + __UI_Version
o$ = o$ + lf + "' Fellippe Heitor, (2016 - 2022) - @FellippeHeitor"
o$ = o$ + lf + "' Samuel Gomes, (2023 - 2024) - @a740g"
o$ = o$ + lf + "'-----------------------------------------------------------"
o$ = o$ + lf + "SUB __UI_LoadForm"
o$ = o$ + lf
@ -43,7 +62,13 @@ o$ = o$ + lf + " DIM __UI_NewID AS LONG"
o$ = o$ + lf
o$ = o$ + lf + " __UI_NewID = __UI_NewControl(__UI_Type_Form, " + q + FormName$ + q + ", "
row = CSRLIN
DIM row AS LONG: row = CSRLIN
DIM percentage%, eq AS LONG, i AS LONG
DIM property$, value$, width$, height$, backColor$, foreColor$, caption$, text$
DIM leftSide$, top$, disabled$, hidden$, controlType$, control$, controlName$, i$
DIM controlList$, caseAll$, caseFocus$, caseList$, caseTextBox$, assignIDs$
DIM controlIDsDIM$, Frame$
DO
IF EOF(1) THEN EXIT DO
@ -171,17 +196,18 @@ o$ = o$ + lf + "SUB __UI_AssignIDs"
o$ = o$ + assignIDs$
o$ = o$ + lf + "END SUB"
newFile$ = LEFT$(theFile$, INSTR(theFile$, ".") - 1) + "_InForm.frm"
DIM newFile$: newFile$ = LEFT$(theFile$, INSTR(theFile$, ".") - 1) + "_InForm.frm"
CLOSE
OPEN newFile$ FOR BINARY AS #1
PUT #1, , o$
CLOSE
TextFileNum = FREEFILE
newTextFile$ = LEFT$(theFile$, INSTR(theFile$, ".") - 1) + "_InForm.bas"
DIM TextFileNum AS LONG: TextFileNum = FREEFILE
DIM newTextFile$: newTextFile$ = LEFT$(theFile$, INSTR(theFile$, ".") - 1) + "_InForm.bas"
OPEN newTextFile$ FOR OUTPUT AS #TextFileNum
PRINT #TextFileNum, "': This program was generated by"
PRINT #TextFileNum, "': InForm - GUI system for QB64 - "; __UI_Version
PRINT #TextFileNum, "': Fellippe Heitor, " + __UI_CopyrightSpan + " - fellippe@qb64.org - @fellippeheitor"
PRINT #TextFileNum, "': InForm GUI engine for QB64-PE - v"; __UI_Version
PRINT #TextFileNum, "': Fellippe Heitor, (2016 - 2022) - @FellippeHeitor"
PRINT #TextFileNum, "': Samuel Gomes, (2023 - 2024) - @a740g"
PRINT #TextFileNum, "'-----------------------------------------------------------"
PRINT #TextFileNum,
PRINT #TextFileNum, "': Controls' IDs: ------------------------------------------------------------------";
@ -248,6 +274,7 @@ END
AddProperties:
IF LEN(caption$) THEN o$ = o$ + lf + " SetCaption __UI_NewID, " + caption$: caption$ = ""
DIM formBackColor$, formForeColor$
IF LEN(FormName$) = 0 THEN
IF backColor$ = formBackColor$ THEN backColor$ = ""
IF foreColor$ = formForeColor$ THEN foreColor$ = ""

File diff suppressed because it is too large Load diff

View file

@ -1,6 +1,8 @@
MIT License
Copyright (c) 2016-2019 Fellippe Heitor
Copyright (c) 2024 Samuel Gomes
Copyright (c) 2023 George McGinn
Copyright (c) 2022 Fellippe Heitor
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal

129
README.md
View file

@ -1,35 +1,110 @@
# INFORM-PE
![InForm logo](InForm/resources/Application-icon-128.png)
# InForm
A GUI engine and WYSIWYG interface designer for QB64
[InForm-PE](https://github.com/a740g/InForm-PE) is a GUI engine and WYSIWYG interface designer for [QB64-PE](https://github.com/QB64-Phoenix-Edition/QB64pe). It is a fork of [InForm](https://github.com/FellippeHeitor/InForm), authored by [Fellippe Heitor](https://github.com/FellippeHeitor).
Wiki: https://github.com/FellippeHeitor/InForm/wiki
InForm-PE's main goal is to generate *event-driven* QB64-PE applications. This means that you design a graphical user interface with interactive controls and then write the code to respond to such controls once they are manipulated.
Official page: https://www.qb64.org/inform
Wiki: <https://github.com/a740g/InForm-PE/wiki>
## Event-driven QB64 programs
InForm's main goal is to generate event-driven QB64 applications. This means that you design a graphical user interface with interactive controls and then write the code to respond to such controls once they are manipulated.
## FEATURES
## Workflow
After your form looks the way you want it to, click File -> Save to export its contents and generate a .bas source file. Two files are output:
* **.frm**
the generated form in QB64 code. This can be loaded back into InForm's designer or manually edited in QB64 or any text editor later, if you want to adjust fine details.
* **.bas**
the actual program you will add your code to.
- WYSIWYG interface designer
- Event-driven application design
- Works on Windows, Linux & macOS
- Everything is statically linked (no shared library dependencies)
### You add code to respond to events:
* *Click*
* *MouseEnter/MouseLeave* (hover)
* *FocusIn/FocusOut*
* *MouseDown/MouseUp* (events preceding a Click)
* *KeyPress*
* *TextChanged* (for text box controls)
* *ValueChanged* (for track bars, lists and dropdown lists)
## USAGE
### There are also events that occur in specific moments, to which you can respond/add code:
* *BeforeInit*, triggered just before the form is shown.
* *OnLoad*, triggered right after the form is first shown.
* *BeforeUpdateDisplay*, triggered everytime the form is about to be repainted.
* *BeforeUnload*, triggered when the user tries to close the program, either via clicking the window's X button, right click in the task bar -> Close or with Alt+F4 (Windows only).
* *FormResized*, triggered when a form with the CanResize property is resized at runtime.
Install InForm-PE and QB64-PE side-by-side in their own directories. There is no need to copy InForm-PE files to the QB64-PE directory.
> The following directory setup is recommended
```text
<some-drive-or-directory>
|
|-------<InForm-PE>
| |
| |-------<UiEditor[.exe]>
|
|-------<QB64pe>
|
|-------<qb64pe[.exe]>
```
Assuming your setup is like the above, do the following:
- Open Terminal and change to the InForm-PE directory using an appropriate OS command
- Run `setup_inform_lnx.sh`, `setup_inform_osx.command` or `setup_inform_win.cmd` depending on the OS you are on. This will run make with the correct parameters. If the build fails, ensure QB64-PE is installed in the **QB64pe** directory (next to the InForm-PE directory). If QB64-PE is installed elsewhere, then edit the setup scripts to change the location
- Once InForm-PE is compiled, you will find the UiEditor[.exe] executable in the InForm-PE directory
- Run UiEditor[.exe] to start designing your forms
- After your form looks the way you want it to, click **File > Save** to export its contents and generate a **.bas** source file. Two files are exported:
- **.frm** - the generated form in QB64-PE code. This can be loaded back into InForm-PE's designer or manually edited in QB64-PE or any text editor later, if you want to adjust fine details
- **.bas** - the actual program you will add your code to
***You add code to respond to events.***
- *Click*
- *MouseEnter/MouseLeave* (hover)
- *FocusIn/FocusOut*
- *MouseDown/MouseUp* (events preceding a Click)
- *KeyPress*
- *TextChanged* (for text box controls)
- *ValueChanged* (for track bars, lists and dropdown lists)
***There are also events that occur in specific moments, to which you can respond/add code.***
- *BeforeInit*, triggered just before the form is shown.
- *OnLoad*, triggered right after the form is first shown.
- *BeforeUpdateDisplay*, triggered every time the form is about to be repainted.
- *BeforeUnload*, triggered when the user tries to close the program, either via clicking the window's X button, right click in the task bar -> Close or with Alt+F4 (Windows only).
- *FormResized*, triggered when a form with the CanResize property is resized at runtime.
***IMPORTANT: The following files must be copied to your project directory for it to compile.***
```text
InForm/InForm.bi
InForm/InForm.ui
InForm/InFormCommon.bi
InForm/InFormVersion.bi
InForm/xp.uitheme
InForm/extensions/*.*
```
## EXAMPLES
| Name | Author |
|------|-------------|
| Bin2Include | Zachary Spriggs |
| Calculator | Terry Ritchie |
| ClickTheVoid | Fellippe Heitor |
| ClockPatience | Richard Notley |
| DuckShoot | Richard Notley |
| ebacCalculator | George McGinn |
| Fahrenheit-Celsius | Richard Notley |
| Fireworks2 | Fellippe Heitor |
| GIFPlaySample | Fellippe Heitor |
| GravitationSimulation | Richard Notley |
| InFormPaint | Fellippe Heitor |
| InsideOutsideTriangle | Richard Notley |
| Lander1 | B+ |
| Lander2 | B+ |
| Mahjong | Richard Notley |
| MasterMindGuessTheSequence | TempodiBasic |
| Pelmanism | Richard Notley |
| PictureGrid | Richard Notley |
| PlayFX | Samuel Gomes |
| RockPaperScissorsSpockLizard | TempodiBasic |
| Stopwatch | Fellippe Heitor |
| TextFetch | B+ |
| ThemePreview | Fellippe Heitor |
| TicTacToe | Fellippe Heitor |
| TicTacToe2 | Fellippe Heitor |
| Trackword | Richard Notley |
| WordClock | Fellippe Heitor |
| wordSearch | George McGinn |
## NOTES
- This requires the latest version of [QB64-PE](https://github.com/QB64-Phoenix-Edition/QB64pe/releases/latest). QB64, or other forks of QB64 will not work!

145
docs/GIFPlay.md Normal file
View file

@ -0,0 +1,145 @@
# Animated GIF Player Library
***By [a740g](https://github.com/a740g)***
## Usage instructions
You can use the Library either standalone or with InForm-PE.
### Standalone
```vb
' At the top of your code include GIFPlay.bi
'$INCLUDE:'GIFPlay.bi'
' Your code here...
' At the bottom of your code include GIFPlay.bas
'$INCLUDE:'GIFPlay.bas'
```
### With InForm-PE
Your form must contain a PictureBox control that'll serve as a container for the GIF file you'll load with this library.
In the **External modules section** of the .bas file generated by InForm, `$INCLUDE` both `GIFPlay.bi` and `GIFPlay.bas`.
The first must come ***before*** the line that includes `InForm.ui` and the second must come after that, as in the sample below:
```vb
': External modules: --------------------------------
'$INCLUDE:'InForm/extensions/GIFPlay.bi'
'$INCLUDE:'InForm/InForm.ui'
'$INCLUDE:'InForm/xp.uitheme'
'$INCLUDE:'gifplaySample.frm'
'$INCLUDE:'InForm/extensions/GIFPlay.bas'
```
## API
```vb
FUNCTION GIF_LoadFromFile%% (Id AS LONG, fileName AS STRING)
FUNCTION GIF_LoadFromMemory%% (Id AS LONG, buffer AS STRING)
```
GIF_LoadFromFile is a function that takes a PictureBox control ID (or any unique ID) and a GIF file name and returns True if loading the animation is successful.
GIF_LoadFromMemory does the same. However, it loads the animation from a STRING buffer.
```vb
SUB GIF_Free (Id AS LONG)
```
Frees resources used by the GIF file loaded previously using GIF_LoadFromFile or GIF_LoadFromMemory.
```vb
FUNCTION GIF_IsLoaded%% (Id AS LONG)
```
Returns True if GIF file is completely loaded and ready for use.
```vb
FUNCTION GIF_GetWidth~& (Id AS LONG)
```
Returns the width of the GIF in pixels.
```vb
FUNCTION GIF_GetHeight~& (Id AS LONG)
```
Returns the height of the GIF in pixels.
```vb
FUNCTION GIF_GetFrameNumber~& (Id AS LONG)
```
Returns the number of currently playing frame.
```vb
FUNCTION GIF_GetTotalFrames~& (Id AS LONG)
```
Returns the total number of frames in a loaded GIF. If not an animated GIF, it returns 1.
```vb
FUNCTION GIF_IsPlaying%% (Id AS LONG)
```
Returns True if a GIF is currently being played.
```vb
SUB GIF_Play (Id AS LONG)
SUB GIF_Pause (Id AS LONG)
SUB GIF_Stop (Id AS LONG)
```
Starts, pauses or stops playback of a loaded GIF file.
```vb
FUNCTION GIF_GetTotalDuration~&& (Id AS LONG)
```
Returns the total runtime of the animation in ms.
```vb
FUNCTION GIF_GetFrameDuration~&& (Id AS LONG)
```
Returns the total runtime of the current frame in ms.
```vb
FUNCTION GIF_GetElapsedTime~&& (Id AS LONG)
```
Returns the current runtime of the animation in ms.
```vb
SUB GIF_SetLoop (Id AS LONG, loops AS LONG)
```
Set the looping behavior, where < 0 means play once, 0 means loop forever and +n means loop n times.
```vb
SUB GIF_Draw (Id AS LONG)
```
Draws the current frame on a destination surface @ (0, 0) (stretching the frame if needed).
GIF_Draw must be called from within the __UI_BeforeUpdateDisplay event. That's where the frames will be updated in your PictureBox control.
```vb
FUNCTION GIF_GetFrame& (Id AS LONG)
```
Returns the current rendered frame image to be played. Playback is time sensitive so frames may be skipped or the last frame may be returned.
Use this if you want to do your own final _PUTIMAGE. Do not free the image. The library will do that when it is no longer needed.
```vb
FUNCTION GIF_GetBackgroundColor~& (Id AS LONG)
```
Returns the background color that should be used to clear the surface before drawing the final rendered frame.
Use this if you want to do your own final _PUTIMAGE.
```vb
SUB GIF_EnableOverlay (Id AS LONG, isEnabled AS _BYTE)
```
Hides the **GIF** overlay image when the GIF is not playing or paused.

View file

@ -1,6 +1,7 @@
InForm - GUI library for QB64
Fellippe Heitor, 2016-2019 - fellippe@qb64.org - @fellippeheitor
https://github.com/FellippeHeitor/InForm
-----------------------------------------------------------
Below is the binary format for exchange of controls data. It is
used for UiEditorPreview.frmbin, which is read/written to by both
@ -86,4 +87,4 @@ FOR EACH CONTROL (FORM INCLUDED):
INTEGER -48 (BoundTo) + INTEGER Which control + INTEGER Which
Property
-------------------
INTEGER -1024 (End of file)
INTEGER -1024 (End of file)

1
docs/wiki Submodule

@ -0,0 +1 @@
Subproject commit 3fdcd29cf67deba354ffd0848dd68a50da5dc93a

View file

@ -0,0 +1,715 @@
': This program uses
': InForm - GUI library for QB64 - v1.5
': Fellippe Heitor, 2016-2023 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
$VERSIONINFO:CompanyName='SpriggsySpriggs'
$VERSIONINFO:FileDescription='Converts a binary file into an INCLUDE-able'
$VERSIONINFO:LegalCopyright='(c) 2019-2020 SpriggsySpriggs'
$VERSIONINFO:ProductName='BIN2INCLUDE'
$VERSIONINFO:InternalName='BIN2INCLUDE'
$VERSIONINFO:OriginalFilename='BIN2INCLUDE.exe'
$VERSIONINFO:Web='https://github.com/a740g/QB64-Museum/tree/main/SpriggsySpriggs/Bin2Include'
$VERSIONINFO:Comments='QB64-PE and InForm-PE port by a740g'
$VERSIONINFO:FILEVERSION#=2,6,0,0
$VERSIONINFO:PRODUCTVERSION#=2,6,0,0
OPTION _EXPLICIT
$EXEICON:'./BIN2INCLUDE.ico'
': Controls' IDs: ------------------------------------------------------------------
DIM SHARED BIN2INCLUDE AS LONG
DIM SHARED SelectedFileTB AS LONG
DIM SHARED OpenBT AS LONG
DIM SHARED SaveBT AS LONG
DIM SHARED CONVERTBT AS LONG
DIM SHARED OutputFileTB AS LONG
DIM SHARED ListBox1 AS LONG
DIM SHARED ClearLogBT AS LONG
DIM SHARED BIN2BASRB AS LONG
DIM SHARED PIC2MEMRB AS LONG
DIM SHARED ResetBT AS LONG
': External modules: ---------------------------------------------------------------
'$INCLUDE:'../../InForm/InForm.bi'
'$INCLUDE:'BIN2INCLUDE.frm'
'$INCLUDE:'../../InForm/InForm.ui'
': Custom procedures: --------------------------------------------------------------
FUNCTION checkExt%% (OFile$)
IF UCASE$(RIGHT$(OFile$, 4)) <> ".BMP" AND UCASE$(RIGHT$(OFile$, 4)) <> ".JPG" _
AND UCASE$(RIGHT$(OFile$, 4)) <> ".PNG" AND UCASE$(RIGHT$(OFile$, 5)) <> ".JPEG" _
AND UCASE$(RIGHT$(OFile$, 4)) <> ".GIF" THEN
checkExt = FALSE
ELSE
checkExt = TRUE
END IF
END FUNCTION
FUNCTION ReplaceString$ (a AS STRING, b AS STRING, c AS STRING)
DIM j AS LONG: j = INSTR(a, b)
DIM r AS STRING
IF j > 0 THEN
r = LEFT$(a, j - 1) + c + ReplaceString(RIGHT$(a, LEN(a) - j + 1 - LEN(b)), b, c)
ELSE
r = a
END IF
ReplaceString = r
END FUNCTION
FUNCTION StripDirectory$ (s AS STRING)
DIM t AS STRING: t = MID$(s, _INSTRREV(s, "\") + 1)
StripDirectory = t
END FUNCTION
FUNCTION E$ (BS AS STRING)
DIM AS LONG t, b
FOR t = LEN(BS) TO 1 STEP -1
b = b * 256 + ASC(MID$(BS, t))
NEXT
DIM AS STRING a, g
FOR t = 1 TO LEN(BS) + 1
g = CHR$(48 + (b AND 63)): b = b \ 64
IF g = "@" THEN g = "#"
a = a + g
NEXT
E = a
END FUNCTION
SUB bin2bas (IN$, OUT$)
OPEN IN$ FOR BINARY AS 1
IF LOF(1) = 0 THEN
CLOSE 1
ELSE
DIM INDATA$: INDATA$ = (INPUT$(LOF(1), 1))
INDATA$ = _DEFLATE$(INDATA$)
OPEN OUT$ FOR OUTPUT AS 2
DIM Q$: Q$ = CHR$(34) 'quotation mark
DIM inFunc$: inFunc$ = LEFT$(IN$, LEN(IN$) - 4)
DIM i AS LONG
FOR i = 32 TO 64
IF INSTR(inFunc$, CHR$(i)) THEN
inFunc$ = ReplaceString(inFunc$, CHR$(i), "")
END IF
NEXT
FOR i = 91 TO 96
IF INSTR(inFunc$, CHR$(i)) THEN
IF i <> 92 THEN
inFunc$ = ReplaceString(inFunc$, CHR$(i), "")
END IF
END IF
NEXT
PRINT #2, "SUB __" + StripDirectory(inFunc$)
PRINT #2, "IF NOT _FILEEXISTS(" + Q$ + StripDirectory(IN$) + Q$ + ") THEN"
AddItem ListBox1, TIME$ + ": Opening file: " + IN$
AddItem ListBox1, TIME$ + ": Processing file..."
PRINT #2, "DIM A$:A$="; Q$;
AddItem ListBox1, TIME$ + ": Converting lines..."
DIM BC&: BC& = 1
DO
DIM a$: a$ = MID$(INDATA$, BC&, 3)
BC& = BC& + 3
DIM LL&: LL& = LL& + 4
IF LL& = 60 THEN
LL& = 0
PRINT #2, E$(a$);
PRINT #2, Q$
PRINT #2, "A$=A$+"; Q$;
ELSE
PRINT #2, E$(a$);
END IF
IF LEN(INDATA$) - BC& < 3 THEN
a$ = MID$(INDATA$, LEN(INDATA$) - BC&, 1)
DIM B$: B$ = E$(a$)
SELECT CASE LEN(B$)
CASE 0: a$ = Q$
CASE 1: a$ = "%%%" + B$ + Q$
CASE 2: a$ = "%%" + B$ + Q$
CASE 3: a$ = "%" + B$ + Q$
END SELECT:
PRINT #2, a$;
EXIT DO
END IF
LOOP
PRINT #2, ""
AddItem ListBox1, TIME$ + ": DONE"
AddItem ListBox1, TIME$ + ": Writing decoding function to file..."
PRINT #2, "DIM btemp$,i&,B$,C%,F$,C$,j,t%,B&,X$,BASFILE$"
PRINT #2, "FOR i&=1TO LEN(A$) STEP 4"
PRINT #2, "B$=MID$(A$,i&,4)"
PRINT #2, "IF INSTR(1,B$,"; Q$; "%"; Q$; ") THEN"
PRINT #2, "FOR C%=1 TO LEN(B$)"
PRINT #2, "F$=MID$(B$,C%,1)"
PRINT #2, "IF F$<>"; Q$; "%"; Q$; "THEN C$=C$+F$"
PRINT #2, "NEXT"
PRINT #2, "B$=C$"
PRINT #2, "END IF"
PRINT #2, "FOR j=1 TO LEN(B$)"
PRINT #2, "IF MID$(B$,j,1)="; Q$; "#"; Q$; " THEN"
PRINT #2, "MID$(B$,j)="; Q$; "@"; Q$
PRINT #2, "END IF"
PRINT #2, "NEXT"
PRINT #2, "FOR t%=LEN(B$) TO 1 STEP-1"
PRINT #2, "B&=B&*64+ASC(MID$(B$,t%))-48"
PRINT #2, "NEXT"
PRINT #2, "X$="; Q$; Q$
PRINT #2, "FOR t%=1 TO LEN(B$)-1"
PRINT #2, "X$=X$+CHR$(B& AND 255)"
PRINT #2, "B&=B&\256"
PRINT #2, "NEXT"
PRINT #2, "btemp$=btemp$+X$"
PRINT #2, "NEXT"
PRINT #2, "BASFILE$=_INFLATE$(btemp$,"; LTRIM$(STR$(LOF(1))); " )"
PRINT #2, "DIM FF&: FF&=FREEFILE"
PRINT #2, "OPEN "; Q$; StripDirectory(IN$); Q$; " FOR OUTPUT AS #FF&"
PRINT #2, "PRINT #FF&, BASFILE$;"
PRINT #2, "CLOSE #FF&"
PRINT #2, "END IF"
PRINT #2, "END SUB"
CLOSE #1
CLOSE #2
AddItem ListBox1, TIME$ + ": DONE"
AddItem ListBox1, TIME$ + ": File exported to " + OUT$
ToolTip(ListBox1) = TIME$ + ": File exported to " + OUT$
Text(SelectedFileTB) = ""
Text(OutputFileTB) = ""
Control(CONVERTBT).Disabled = TRUE
Control(OpenBT).Disabled = TRUE
Control(BIN2BASRB).Value = FALSE
Control(PIC2MEMRB).Value = FALSE
END IF
END SUB
SUB pic2mem (IN$, OUT$)
AddItem ListBox1, TIME$ + ": Opening file: " + IN$
AddItem ListBox1, TIME$ + ": Processing file..."
'Load image file to screen mode
DIM pic AS LONG: pic = _LOADIMAGE(IN$, 32)
DIM m AS _MEM: m = _MEMIMAGE(pic)
'Grab screen data
DIM INDATA$: INDATA$ = SPACE$(m.SIZE)
_MEMGET m, m.OFFSET, INDATA$
'Compress it
INDATA$ = _DEFLATE$(INDATA$)
'get screen specs
DIM AS LONG wid, hih
wid = _WIDTH(pic): hih = _HEIGHT(pic)
OPEN OUT$ FOR OUTPUT AS 2
DIM Q$: Q$ = CHR$(34) 'quotation mark
DIM inFunc$: inFunc$ = LEFT$(IN$, LEN(IN$) - 4)
DIM AS LONG i
FOR i = 32 TO 64
IF INSTR(inFunc$, CHR$(i)) THEN
inFunc$ = ReplaceString(inFunc$, CHR$(i), "")
END IF
NEXT
FOR i = 91 TO 96
IF INSTR(inFunc$, CHR$(i)) THEN
IF i <> 92 THEN
inFunc$ = ReplaceString(inFunc$, CHR$(i), "")
END IF
END IF
NEXT
PRINT #2, "FUNCTION __" + StripDirectory(inFunc$) + "&"
PRINT #2, "DIM A$,btemp$,i&,B$,C%,F$,C$,j,t%,B&,X$"
PRINT #2, "DIM v&:v&=_NEWIMAGE("; wid; ","; hih; ",32)"
PRINT #2, "DIM m AS _MEM:m=_MEMIMAGE(v&)"
PRINT #2, "A$="; Q$;
DIM BC&: BC& = 1
DO
DIM a$: a$ = MID$(INDATA$, BC&, 3)
BC& = BC& + 3
DIM LL&: LL& = LL& + 4
IF LL& = 60 THEN
LL& = 0
PRINT #2, E$(a$);: PRINT #2, Q$
PRINT #2, "A$=A$+"; Q$;
ELSE
PRINT #2, E$(a$);
END IF
IF LEN(INDATA$) - BC& < 3 THEN
a$ = MID$(INDATA$, LEN(INDATA$) - BC&, 1)
DIM B$: B$ = E$(a$)
SELECT CASE LEN(B$)
CASE 0: a$ = Q$
CASE 1: a$ = "%%%" + B$ + Q$
CASE 2: a$ = "%%" + B$ + Q$
CASE 3: a$ = "%" + B$ + Q$
END SELECT: PRINT #2, a$;: EXIT DO
END IF
LOOP: PRINT #2, ""
PRINT #2, "FOR i&=1TO LEN(A$) STEP 4"
PRINT #2, "B$=MID$(A$,i&,4)"
PRINT #2, "IF INSTR(1,B$,"; Q$; "%"; Q$; ") THEN"
PRINT #2, "FOR C%=1 TO LEN(B$)"
PRINT #2, "F$=MID$(B$,C%,1)"
PRINT #2, "IF F$<>"; Q$; "%"; Q$; "THEN C$=C$+F$"
PRINT #2, "NEXT"
PRINT #2, "B$=C$"
PRINT #2, "END IF"
PRINT #2, "FOR j=1 TO LEN(B$)"
PRINT #2, "IF MID$(B$,j,1)="; Q$; "#"; Q$; " THEN"
PRINT #2, "MID$(B$,j)="; Q$; "@"; Q$
PRINT #2, "END IF"
PRINT #2, "NEXT"
PRINT #2, "FOR t%=LEN(B$) TO 1 STEP-1"
PRINT #2, "B&=B&*64+ASC(MID$(B$,t%))-48"
PRINT #2, "NEXT"
PRINT #2, "X$="; Q$; Q$
PRINT #2, "FOR t%=1 TO LEN(B$)-1"
PRINT #2, "X$=X$+CHR$(B& AND 255)"
PRINT #2, "B&=B&\256"
PRINT #2, "NEXT"
PRINT #2, "btemp$=btemp$+X$"
PRINT #2, "NEXT"
PRINT #2, "btemp$=_INFLATE$(btemp$,m.SIZE)"
PRINT #2, "_MEMPUT m,m.OFFSET,btemp$"
PRINT #2, "_MEMFREE m"
PRINT #2, "__" + StripDirectory(inFunc$) + "&=v&"
PRINT #2, "END FUNCTION"
CLOSE #2
_MEMFREE m
_FREEIMAGE pic
AddItem ListBox1, TIME$ + ": Image converted to MEM successfully"
AddItem ListBox1, TIME$ + ": File exported to " + OUT$
ToolTip(ListBox1) = TIME$ + ": File exported to " + OUT$
Text(SelectedFileTB) = ""
Text(OutputFileTB) = ""
Control(CONVERTBT).Disabled = TRUE
Control(OpenBT).Disabled = TRUE
Control(BIN2BASRB).Value = FALSE
Control(PIC2MEMRB).Value = FALSE
END SUB
FUNCTION __opensmall&
DIM v&
DIM A$
DIM btemp$
DIM i&
DIM B$
DIM C%
DIM F$
DIM C$
DIM j
DIM t%
DIM B&
DIM X$
v& = _NEWIMAGE(16, 16, 32)
DIM m AS _MEM: m = _MEMIMAGE(v&)
A$ = "haiHP1:6<GPhK34O7Xh[24W99XooS3\jDXng<#lD#3g>#\\4Yna5n^0a\#1j"
A$ = A$ + "74FIlXoo0e>^1N`bS5moGPhf0R5Q82c`Vo?66P4V_MPhOCTn3HZ[1PHi0RO>"
A$ = A$ + "96><APhU14c7#l59Am^EPHV1RiV18aeTRN_4#<_#moMCRjmY<PJh?XdEKQ8`"
A$ = A$ + "K28^IPHa`GT1m600eW8R%%%0"
FOR i& = 1 TO LEN(A$) STEP 4
B$ = MID$(A$, i&, 4)
IF INSTR(1, B$, "%") THEN
FOR C% = 1 TO LEN(B$)
F$ = MID$(B$, C%, 1)
IF F$ <> "%" THEN C$ = C$ + F$
NEXT
B$ = C$
END IF
FOR j = 1 TO LEN(B$)
IF MID$(B$, j, 1) = "#" THEN
MID$(B$, j) = "@"
END IF
NEXT
FOR t% = LEN(B$) TO 1 STEP -1
B& = B& * 64 + ASC(MID$(B$, t%)) - 48
NEXT
X$ = ""
FOR t% = 1 TO LEN(B$) - 1
X$ = X$ + CHR$(B& AND 255)
B& = B& \ 256
NEXT
btemp$ = btemp$ + X$
NEXT
btemp$ = _INFLATE$(btemp$, m.SIZE)
_MEMPUT m, m.OFFSET, btemp$: _MEMFREE m
__opensmall& = v&
END FUNCTION
FUNCTION __convert&
DIM v&
DIM A$
DIM btemp$
DIM i&
DIM B$
DIM C%
DIM F$
DIM C$
DIM j
DIM t%
DIM B&
DIM X$
v& = _NEWIMAGE(16, 16, 32)
DIM m AS _MEM: m = _MEMIMAGE(v&)
A$ = "haIM#f6BC6557olUj3A#R44H98hDS4c\b:B]V:Jj23JiCBjl56FKfHVV6[Dc"
A$ = A$ + "5R_lm\_F8dl;1Q8EFOaNA4[Xd4eLY=L[mBZK=leIcmfYcARAbcj2ohN_?Wko"
A$ = A$ + "O?gkA_NQRd[G#E4#Bc=;7dYk2`2]E5h\MUBMgeEAJN[molNE0fKE1#WAM`PN"
A$ = A$ + "`=gLILS=F4GK=Kh#3e?bOW81>?OF2T`2A0RAMX_lThlDm[kcgjX7?^aEFI1d"
A$ = A$ + "U[i`16XGT7L=R4_o]_8H]UBUJBW0BcPikDBjdjn8P6J#V6ongPng;7fQ13M7"
A$ = A$ + "V2;<QF8P^ZA;<CSbQ>DY1NUVc1CMSRTA0eFKNJ34`;jekJKc1O?hg2G?C5e3"
A$ = A$ + "9;X?<2293?_VlH7PJeIGG`Pn#Onl8ba;7n3H^:^fCX<ZnGXlB:^h31bUO##Y"
A$ = A$ + "b<^IX#1#onm:bQQGlFLL;^a?>[3L4Sf`QoZE\Wn72Y\Z8T`i;[\CdHX#1a01"
A$ = A$ + "l;baSO6Ug\CLhY<Q_KRIaGo5Sh3jMP]j]DFe4988L4Mln8iXWnO3>YEghkoV"
A$ = A$ + "U`>J[K3Q9jSOi>b?oh_;ng1kPO;LoPkY?\_1AS>F6oT9kKc1O?hgBlbZ_>9B"
A$ = A$ + "f]VDCM?M69B<[26lk;^:>Vii5iH4SfahbGK300kR8V8A<IEIkcm;?h4fL9b1"
A$ = A$ + "gCS=gJd=Fa758TmX\C2dVb1P9;9MXf37;\gD??4cI[^9[;i5WNnU4ihcVF0i"
A$ = A$ + "jCOUC24m=CYW:MC:>=_6YIYAWB1`nbXbF]_R?L6W[:bahVMQLMcUW1HYR<Cj"
A$ = A$ + "7EVeX418\#Pdm?ZXBkBMjLmP8k`jBo6ig2g?hNZA7[RLM>?MN`FEW1LXD:h\"
A$ = A$ + "jL`W:;=YDnhfan?FCk<nLjno1EoFo1`f%%L2"
FOR i& = 1 TO LEN(A$) STEP 4
B$ = MID$(A$, i&, 4)
IF INSTR(1, B$, "%") THEN
FOR C% = 1 TO LEN(B$)
F$ = MID$(B$, C%, 1)
IF F$ <> "%" THEN C$ = C$ + F$
NEXT
B$ = C$
END IF
FOR j = 1 TO LEN(B$)
IF MID$(B$, j, 1) = "#" THEN
MID$(B$, j) = "@"
END IF
NEXT
FOR t% = LEN(B$) TO 1 STEP -1
B& = B& * 64 + ASC(MID$(B$, t%)) - 48
NEXT
X$ = ""
FOR t% = 1 TO LEN(B$) - 1
X$ = X$ + CHR$(B& AND 255)
B& = B& \ 256
NEXT
btemp$ = btemp$ + X$
NEXT
btemp$ = _INFLATE$(btemp$, m.SIZE)
_MEMPUT m, m.OFFSET, btemp$: _MEMFREE m
__convert& = v&
END FUNCTION
FUNCTION __reset&
DIM v&
DIM A$
DIM btemp$
DIM i&
DIM B$
DIM C%
DIM F$
DIM C$
DIM j
DIM t%
DIM B&
DIM X$
v& = _NEWIMAGE(16, 16, 32)
DIM m AS _MEM: m = _MEMIMAGE(v&)
A$ = "haiHP1J3`03<#1S<bXP<a4C:cHS=>;Pd6B<jc#3=D:PZO10a_08N30aM3D_["
A$ = A$ + "58mS0Rg;#\LhB_VK^ib0Dnk3dNKAK]eV7dTVAPVCQP<GPbK;jj=d#3UIPbM9"
A$ = A$ + "PbE0bRS^J1jnL6Xj^WeFK=_PhkP3>`2#ni3DM12TNoXK^05ki0MGRSVI>IPR"
A$ = A$ + "g3<g5#fG6Tj0jnf3#jSPVnOQYVJZ4Xi6<1Xh?59eh6#lo1R_6#\bX[O#f5#k"
A$ = A$ + "\NPH=19V:ZX2k05kGjYWNL3CM0]kT0:6oXkn19>#L3Pd?#ie0GjWD0Xkn9E0"
A$ = A$ + "JQOTZM3>n3;Y?84P9Pj[8LUn1G0PZ=EPjIM4CjG\10Znh1Rc4HJ038Ag;A10"
A$ = A$ + "0lQl%%h1"
FOR i& = 1 TO LEN(A$) STEP 4
B$ = MID$(A$, i&, 4)
IF INSTR(1, B$, "%") THEN
FOR C% = 1 TO LEN(B$)
F$ = MID$(B$, C%, 1)
IF F$ <> "%" THEN C$ = C$ + F$
NEXT
B$ = C$
END IF
FOR j = 1 TO LEN(B$)
IF MID$(B$, j, 1) = "#" THEN
MID$(B$, j) = "@"
END IF
NEXT
FOR t% = LEN(B$) TO 1 STEP -1
B& = B& * 64 + ASC(MID$(B$, t%)) - 48
NEXT
X$ = ""
FOR t% = 1 TO LEN(B$) - 1
X$ = X$ + CHR$(B& AND 255)
B& = B& \ 256
NEXT
btemp$ = btemp$ + X$
NEXT
btemp$ = _INFLATE$(btemp$, m.SIZE)
_MEMPUT m, m.OFFSET, btemp$: _MEMFREE m
__reset& = v&
END FUNCTION
FUNCTION __deletesmall&
DIM v&
DIM A$
DIM btemp$
DIM i&
DIM B$
DIM C%
DIM F$
DIM C$
DIM j
DIM t%
DIM B&
DIM X$
v& = _NEWIMAGE(16, 16, 32)
DIM m AS _MEM: m = _MEMIMAGE(v&)
A$ = "haiHP1D16JXQm04o7S=fhoS<6ZHMa010PDWEFI5_X;>8a0:g_aVN<b8Sj3Kf"
A$ = A$ + "9^`PD;#md9Q\CL1PjFn5BjoG0=g68Al?ABon2e]A\jmo0MonP\K2TH#Y;28^"
A$ = A$ + "#THG4d`XRQa6VJaQn1K74PmXjWfYo=1<^J34P=fdo[0:_iX;>j0C<a4[0VNk"
A$ = A$ + "5HAon34oBR8_c;0UN5Vn04BU%%h1"
FOR i& = 1 TO LEN(A$) STEP 4
B$ = MID$(A$, i&, 4)
IF INSTR(1, B$, "%") THEN
FOR C% = 1 TO LEN(B$)
F$ = MID$(B$, C%, 1)
IF F$ <> "%" THEN C$ = C$ + F$
NEXT
B$ = C$
END IF
FOR j = 1 TO LEN(B$)
IF MID$(B$, j, 1) = "#" THEN
MID$(B$, j) = "@"
END IF
NEXT
FOR t% = LEN(B$) TO 1 STEP -1
B& = B& * 64 + ASC(MID$(B$, t%)) - 48
NEXT
X$ = ""
FOR t% = 1 TO LEN(B$) - 1
X$ = X$ + CHR$(B& AND 255)
B& = B& \ 256
NEXT
btemp$ = btemp$ + X$
NEXT
btemp$ = _INFLATE$(btemp$, m.SIZE)
_MEMPUT m, m.OFFSET, btemp$: _MEMFREE m
__deletesmall& = v&
END FUNCTION
': Event procedures: ---------------------------------------------------------------
SUB __UI_BeforeInit
END SUB
SUB __UI_OnLoad
Control(OpenBT).HelperCanvas = __opensmall&
Control(CONVERTBT).HelperCanvas = __convert&
Control(ResetBT).HelperCanvas = __reset&
Control(ClearLogBT).HelperCanvas = __deletesmall&
Control(OpenBT).Disabled = TRUE
SetFrameRate 60
_ACCEPTFILEDROP
AddItem ListBox1, "Open a file above or drag and drop."
AddItem ListBox1, "Select BIN2BAS to convert a binary file to BM or select PIC2MEM to convert an image to MEM."
AddItem ListBox1, "To compile a file that is creating memory errors,"
AddItem ListBox1, "consult the readme on https://github.com/SpriggsySpriggs/BIN2INCLUDE"
END SUB
SUB __UI_BeforeUpdateDisplay
IF _TOTALDROPPEDFILES THEN
DIM drop$: drop$ = _DROPPEDFILE
IF _FILEEXISTS(drop$) THEN
IF NOT checkExt(drop$) AND Control(PIC2MEMRB).Value = FALSE THEN
Control(BIN2BASRB).Value = TRUE
Control(PIC2MEMRB).Disabled = TRUE
Text(SelectedFileTB) = drop$
Text(OutputFileTB) = drop$ + ".BM"
Control(CONVERTBT).Disabled = FALSE
ELSEIF checkExt(drop$) AND Control(PIC2MEMRB).Value = TRUE THEN
Control(BIN2BASRB).Disabled = TRUE
Text(SelectedFileTB) = drop$
Text(OutputFileTB) = drop$ + ".MEM"
Control(CONVERTBT).Disabled = FALSE
ELSEIF checkExt(drop$) = 0 AND Control(PIC2MEMRB).Value = TRUE THEN
MessageBox "Unsupported file type for PIC2MEM", Caption(BIN2INCLUDE), MsgBox_Critical
Control(BIN2BASRB).Disabled = FALSE
END IF
END IF
END IF
END SUB
SUB __UI_BeforeUnload
END SUB
SUB __UI_Click (id AS LONG)
SELECT CASE id
CASE BIN2INCLUDE
CASE SelectedFileTB
CASE OpenBT
IF Control(BIN2BASRB).Value = TRUE THEN
_DELAY 0.2 ' delay a bit to allow InFrom to draw and refresh all comtrols before the modal dialog box takes over
DIM oFile$: oFile$ = _OPENFILEDIALOG$(Caption(BIN2INCLUDE) + ": Open")
Control(PIC2MEMRB).Disabled = TRUE
ELSEIF Control(PIC2MEMRB).Value = TRUE THEN
_DELAY 0.2 ' delay a bit to allow InFrom to draw and refresh all comtrols before the modal dialog box takes over
oFile$ = _OPENFILEDIALOG$(Caption(BIN2INCLUDE) + ": Open", , "*.BMP|*.bmp|*.JPG|*.jpg|*.JPEG|*.jpeg|*.PNG|*.png|*.GIF|*.gif", "Supported image files")
Control(BIN2BASRB).Disabled = TRUE
END IF
IF oFile$ <> "" THEN
IF checkExt(oFile$) = 0 AND Control(PIC2MEMRB).Value = TRUE THEN
MessageBox "Unsupported file type for PIC2MEM", Caption(BIN2INCLUDE), MsgBox_Critical
Control(BIN2BASRB).Disabled = FALSE
ELSEIF checkExt(oFile$) AND Control(PIC2MEMRB).Value = TRUE THEN
Control(CONVERTBT).Disabled = FALSE
Text(SelectedFileTB) = oFile$
Text(OutputFileTB) = oFile$ + ".MEM"
ELSE
Control(CONVERTBT).Disabled = FALSE
Text(SelectedFileTB) = oFile$
Text(OutputFileTB) = oFile$ + ".BM"
END IF
ELSE
Text(SelectedFileTB) = ""
Text(OutputFileTB) = ""
Control(BIN2BASRB).Disabled = FALSE
Control(PIC2MEMRB).Disabled = FALSE
Control(CONVERTBT).Disabled = TRUE
END IF
CASE CONVERTBT
IF Control(BIN2BASRB).Value = TRUE THEN
Caption(BIN2INCLUDE) = Caption(BIN2INCLUDE) + " - WORKING..."
bin2bas Text(SelectedFileTB), Text(OutputFileTB)
Control(PIC2MEMRB).Disabled = FALSE
Caption(BIN2INCLUDE) = "BIN2INCLUDE"
ELSEIF Control(PIC2MEMRB).Value = TRUE THEN
Caption(BIN2INCLUDE) = Caption(BIN2INCLUDE) + " - WORKING..."
pic2mem Text(SelectedFileTB), Text(OutputFileTB)
Control(BIN2BASRB).Disabled = FALSE
Caption(BIN2INCLUDE) = "BIN2INCLUDE"
ELSE
MessageBox "Select an option BIN2BAS or PIC2MEM first.", Caption(BIN2INCLUDE), MsgBox_Exclamation
END IF
CASE OutputFileTB
CASE ListBox1
CASE ClearLogBT
ResetList ListBox1
CASE ResetBT
ResetScreen
END SELECT
END SUB
SUB ResetScreen
Text(SelectedFileTB) = ""
Text(OutputFileTB) = ""
Control(BIN2BASRB).Disabled = FALSE
Control(PIC2MEMRB).Disabled = FALSE
Control(CONVERTBT).Disabled = TRUE
ToolTip(ListBox1) = ""
END SUB
SUB __UI_MouseEnter (id AS LONG)
SELECT CASE id
CASE BIN2INCLUDE
CASE SelectedFileTB
CASE OpenBT
CASE CONVERTBT
CASE SaveBT
CASE OutputFileTB
CASE ListBox1
END SELECT
END SUB
SUB __UI_MouseLeave (id AS LONG)
SELECT CASE id
CASE BIN2INCLUDE
CASE SelectedFileTB
CASE OpenBT
CASE CONVERTBT
CASE SaveBT
CASE OutputFileTB
CASE ListBox1
END SELECT
END SUB
SUB __UI_FocusIn (id AS LONG)
SELECT CASE id
CASE SelectedFileTB
CASE OpenBT
CASE CONVERTBT
CASE SaveBT
CASE OutputFileTB
CASE ListBox1
END SELECT
END SUB
SUB __UI_FocusOut (id AS LONG)
SELECT CASE id
CASE SelectedFileTB
CASE OpenBT
CASE CONVERTBT
CASE SaveBT
CASE OutputFileTB
CASE ListBox1
END SELECT
END SUB
SUB __UI_MouseDown (id AS LONG)
SELECT CASE id
CASE BIN2INCLUDE
CASE SelectedFileTB
CASE OpenBT
CASE CONVERTBT
CASE SaveBT
CASE OutputFileTB
CASE ListBox1
END SELECT
END SUB
SUB __UI_MouseUp (id AS LONG)
SELECT CASE id
CASE BIN2INCLUDE
CASE SelectedFileTB
CASE OpenBT
CASE CONVERTBT
CASE SaveBT
CASE OutputFileTB
CASE ListBox1
END SELECT
END SUB
SUB __UI_KeyPress (id AS LONG)
SELECT CASE id
CASE SelectedFileTB
CASE OpenBT
CASE CONVERTBT
CASE OutputFileTB
CASE ListBox1
END SELECT
END SUB
SUB __UI_TextChanged (id AS LONG)
SELECT CASE id
CASE SelectedFileTB
CASE OutputFileTB
END SELECT
END SUB
SUB __UI_ValueChanged (id AS LONG)
SELECT CASE id
CASE ListBox1
CASE BIN2BASRB
Control(OpenBT).Disabled = FALSE
_TITLE "BIN2INCLUDE - BIN2BAS"
CASE PIC2MEMRB
Control(OpenBT).Disabled = FALSE
_TITLE "BIN2INCLUDE - PIC2MEM"
END SELECT
END SUB
SUB __UI_FormResized
END SUB

View file

@ -0,0 +1,90 @@
': This form was generated by
': InForm - GUI library for QB64 - v1.5
': Fellippe Heitor, 2016-2023 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
SUB __UI_LoadForm
DIM __UI_NewID AS LONG, __UI_RegisterResult AS LONG
__UI_NewID = __UI_NewControl(__UI_Type_Form, "BIN2INCLUDE", 589, 324, 0, 0, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "BIN2INCLUDE"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 12)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CenteredWindow = True
__UI_NewID = __UI_NewControl(__UI_Type_TextBox, "SelectedFileTB", 567, 23, 11, 10, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Selected File"
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).Disabled = True
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Button, "OpenBT", 80, 23, 11, 78, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Open"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "CONVERTBT", 80, 23, 96, 78, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Convert"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).Disabled = True
__UI_NewID = __UI_NewControl(__UI_Type_TextBox, "OutputFileTB", 567, 23, 11, 38, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Output File"
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).Disabled = True
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_ListBox, "ListBox1", 567, 200, 11, 114, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).BorderSize = 1
Control(__UI_NewID).AutoScroll = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "ClearLogBT", 80, 23, 498, 78, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Clear Log"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "BIN2BASRB", 76, 23, 189, 78, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "BIN2BAS"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "PIC2MEMRB", 82, 23, 270, 78, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "PIC2MEM"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "ResetBT", 80, 23, 413, 78, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Reset"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
END SUB
SUB __UI_AssignIDs
BIN2INCLUDE = __UI_GetID("BIN2INCLUDE")
SelectedFileTB = __UI_GetID("SelectedFileTB")
OpenBT = __UI_GetID("OpenBT")
CONVERTBT = __UI_GetID("CONVERTBT")
OutputFileTB = __UI_GetID("OutputFileTB")
ListBox1 = __UI_GetID("ListBox1")
ClearLogBT = __UI_GetID("ClearLogBT")
BIN2BASRB = __UI_GetID("BIN2BASRB")
PIC2MEMRB = __UI_GetID("PIC2MEMRB")
ResetBT = __UI_GetID("ResetBT")
END SUB

Binary file not shown.

After

Width:  |  Height:  |  Size: 7.8 KiB

File diff suppressed because it is too large Load diff

View file

@ -0,0 +1,293 @@
': This form was generated by
': InForm - GUI library for QB64 - v1.5
': Fellippe Heitor, 2016-2023 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
SUB __UI_LoadForm
DIM __UI_NewID AS LONG, __UI_RegisterResult AS LONG
__UI_NewID = __UI_NewControl(__UI_Type_Form, "Calculator", 235, 265, 0, 0, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Calculator"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 12)
Control(__UI_NewID).HasBorder = False
__UI_NewID = __UI_NewControl(__UI_Type_Frame, "frmResults", 220, 51, 8, 36, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Value = 3
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_MenuBar, "mnuEdit", 36, 23, 8, 0, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "&Edit"
Control(__UI_NewID).HasBorder = False
__UI_NewID = __UI_NewControl(__UI_Type_MenuBar, "mnuHelp", 41, 23, 44, 0, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Help"
Control(__UI_NewID).HasBorder = False
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butMC", 40, 23, 8, 92, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "MC"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butMR", 40, 23, 53, 92, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "MR"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butMS", 40, 23, 98, 92, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "MS"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butMplus", 40, 23, 143, 92, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "M+"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butMminus", 40, 23, 188, 92, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "M-"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butBS", 40, 23, 8, 120, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "BS"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butCE", 40, 23, 53, 120, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "CE"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butC", 40, 23, 98, 120, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "C"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butSign", 40, 23, 143, 120, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "+/-"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butSQR", 40, 23, 188, 120, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "SQR"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "but7", 40, 23, 8, 148, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "7"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "but8", 40, 23, 53, 148, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "8"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "but9", 40, 23, 98, 148, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "9"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butDivide", 40, 23, 143, 148, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "/"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butPercent", 40, 23, 188, 148, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "%"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "but4", 40, 23, 8, 176, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "4"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "but5", 40, 23, 53, 176, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "5"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "but6", 40, 23, 98, 176, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "6"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butMultiply", 40, 23, 143, 176, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "*"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butReciprocate", 40, 23, 188, 176, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "1/x"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "but1", 40, 23, 8, 204, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "1"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "but2", 40, 23, 53, 204, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "2"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "but3", 40, 23, 98, 204, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "3"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butSubtract", 40, 23, 143, 204, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "-"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "but0", 85, 23, 8, 232, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "0"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butPoint", 40, 23, 98, 232, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "."
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butAdd", 40, 23, 143, 232, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "+"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "butEqual", 40, 51, 188, 204, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "="
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_MenuItem, "mnuCopy", 124, 21, 0, 4, __UI_GetID("mnuEdit"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Copy CTRL+C"
Control(__UI_NewID).HasBorder = False
__UI_NewID = __UI_NewControl(__UI_Type_MenuItem, "mnuPaste", 123, 21, 0, 25, __UI_GetID("mnuEdit"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Paste CTRL+V"
Control(__UI_NewID).HasBorder = False
__UI_NewID = __UI_NewControl(__UI_Type_MenuItem, "mnuAbout", 134, 21, 0, 4, __UI_GetID("mnuHelp"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "About Calculator"
Control(__UI_NewID).HasBorder = False
__UI_NewID = __UI_NewControl(__UI_Type_Label, "lblAnswer", 195, 33, 22, 15, __UI_GetID("frmResults"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "123456789012345"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 21)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Align = __UI_Right
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_Label, "lblMemory", 13, 24, 6, 27, __UI_GetID("frmResults"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "M"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_Label, "lblHistory", 212, 21, 4, 4, __UI_GetID("frmResults"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "89 + 89 + 32"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Align = __UI_Right
Control(__UI_NewID).VAlign = __UI_Middle
END SUB
SUB __UI_AssignIDs
Calculator = __UI_GetID("Calculator")
frmResults = __UI_GetID("frmResults")
mnuEdit = __UI_GetID("mnuEdit")
mnuHelp = __UI_GetID("mnuHelp")
butMC = __UI_GetID("butMC")
butMR = __UI_GetID("butMR")
butMS = __UI_GetID("butMS")
butMplus = __UI_GetID("butMplus")
butMminus = __UI_GetID("butMminus")
butBS = __UI_GetID("butBS")
butCE = __UI_GetID("butCE")
butC = __UI_GetID("butC")
butSign = __UI_GetID("butSign")
butSQR = __UI_GetID("butSQR")
but7 = __UI_GetID("but7")
but8 = __UI_GetID("but8")
but9 = __UI_GetID("but9")
butDivide = __UI_GetID("butDivide")
butPercent = __UI_GetID("butPercent")
but4 = __UI_GetID("but4")
but5 = __UI_GetID("but5")
but6 = __UI_GetID("but6")
butMultiply = __UI_GetID("butMultiply")
butReciprocate = __UI_GetID("butReciprocate")
but1 = __UI_GetID("but1")
but2 = __UI_GetID("but2")
but3 = __UI_GetID("but3")
butSubtract = __UI_GetID("butSubtract")
but0 = __UI_GetID("but0")
butPoint = __UI_GetID("butPoint")
butAdd = __UI_GetID("butAdd")
butEqual = __UI_GetID("butEqual")
mnuCopy = __UI_GetID("mnuCopy")
mnuPaste = __UI_GetID("mnuPaste")
mnuAbout = __UI_GetID("mnuAbout")
lblAnswer = __UI_GetID("lblAnswer")
lblMemory = __UI_GetID("lblMemory")
lblHistory = __UI_GetID("lblHistory")
END SUB

View file

@ -0,0 +1,181 @@
': This program was generated by
': InForm - GUI system for QB64 - Beta version 7
': Fellippe Heitor, 2016-2018 - fellippe@qb64.org - @fellippeheitor
'-----------------------------------------------------------
OPTION _EXPLICIT
': Controls' IDs: ------------------------------------------------------------------
DIM SHARED ClickTheVoid AS LONG
DIM SHARED PictureBox1 AS LONG
DIM SHARED Button1 AS LONG
DIM SHARED TrackBar1 AS LONG
DIM SHARED fpsLB AS LONG
DIM SHARED start!, totalFrames AS _UNSIGNED LONG, fps AS INTEGER
DIM AS SINGLE CenterX, CenterY, Radius, MaxRadius
': External modules: ---------------------------------------------------------------
'$INCLUDE:'../../InForm/InForm.bi'
'$INCLUDE:'ClickTheVoid.frm'
'$INCLUDE:'../../InForm/InForm.ui'
': Event procedures: ---------------------------------------------------------------
SUB __UI_BeforeInit
END SUB
SUB __UI_OnLoad
Caption(Button1) = "Clear"
SetFrameRate 120
start! = TIMER
END SUB
SUB __UI_BeforeUpdateDisplay
SHARED CenterX, CenterY, Radius, MaxRadius
BeginDraw PictureBox1
LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA32(0, 0, 0, 10), BF
totalFrames = totalFrames + 1
fps% = totalFrames / (TIMER - start!)
_PRINTSTRING (0, 0), STR$(fps%)
EndDraw PictureBox1
Radius = Radius + 1
IF Radius <= MaxRadius THEN
BeginDraw PictureBox1
CIRCLE (CenterX, CenterY), Radius, _RGBA32(RND * 255, RND * 255, RND * 255, RND * 255)
EndDraw PictureBox1
END IF
END SUB
SUB __UI_BeforeUnload
END SUB
SUB __UI_Click (id AS LONG)
SELECT CASE id
CASE TrackBar1
CASE fpsLB
CASE ClickTheVoid
CASE PictureBox1
SHARED MaxRadius, CenterX, CenterY, Radius
Radius = 0
MaxRadius = RND * 100 + 30
CenterX = __UI_MouseLeft - Control(id).Left
CenterY = __UI_MouseTop - Control(id).Top
CASE Button1
BeginDraw PictureBox1
CLS
MaxRadius = 0
start! = TIMER
totalFrames = 0
EndDraw PictureBox1
END SELECT
END SUB
SUB __UI_MouseEnter (id AS LONG)
SELECT CASE id
CASE TrackBar1
CASE fpsLB
CASE ClickTheVoid
CASE PictureBox1
CASE Button1
END SELECT
END SUB
SUB __UI_MouseLeave (id AS LONG)
SELECT CASE id
CASE TrackBar1
CASE fpsLB
CASE ClickTheVoid
CASE PictureBox1
CASE Button1
END SELECT
END SUB
SUB __UI_FocusIn (id AS LONG)
SELECT CASE id
CASE TrackBar1
CASE Button1
END SELECT
END SUB
SUB __UI_FocusOut (id AS LONG)
SELECT CASE id
CASE TrackBar1
CASE Button1
END SELECT
END SUB
SUB __UI_MouseDown (id AS LONG)
SELECT CASE id
CASE TrackBar1
CASE fpsLB
CASE ClickTheVoid
CASE PictureBox1
CASE Button1
END SELECT
END SUB
SUB __UI_MouseUp (id AS LONG)
SELECT CASE id
CASE TrackBar1
CASE fpsLB
CASE ClickTheVoid
CASE PictureBox1
CASE Button1
END SELECT
END SUB
SUB __UI_KeyPress (id AS LONG)
SELECT CASE id
CASE TrackBar1
CASE Button1
END SELECT
END SUB
SUB __UI_TextChanged (id AS LONG)
SELECT CASE id
CASE ELSE
END SELECT
END SUB
SUB __UI_ValueChanged (id AS LONG)
SELECT CASE id
CASE TrackBar1
Caption(fpsLB) = LTRIM$(STR$(Control(id).Value)) + "fps"
SetFrameRate Control(id).Value
END SELECT
END SUB
SUB __UI_FormResized
END SUB

View file

@ -0,0 +1,54 @@
': This form was generated by
': InForm - GUI library for QB64 - v1.5
': Fellippe Heitor, 2016-2023 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
SUB __UI_LoadForm
DIM __UI_NewID AS LONG, __UI_RegisterResult AS LONG
__UI_NewID = __UI_NewControl(__UI_Type_Form, "ClickTheVoid", 300, 322, 0, 0, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Click the void"
Control(__UI_NewID).Font = SetFont("segoeui.ttf?arial.ttf?/Library/Fonts/Arial.ttf?InForm/resources/NotoMono-Regular.ttf?cour.ttf", 12)
Control(__UI_NewID).HasBorder = False
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "PictureBox1", 280, 258, 10, 10, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).BackColor = _RGB32(0, 0, 0)
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Button, "Button1", 80, 23, 210, 280, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Button1"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_TrackBar, "TrackBar1", 143, 40, 16, 272, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Value = 30
Control(__UI_NewID).Min = 30
Control(__UI_NewID).Max = 1000
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).Interval = 50
__UI_NewID = __UI_NewControl(__UI_Type_Label, "fpsLB", 38, 41, 164, 272, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "30fps"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).VAlign = __UI_Middle
END SUB
SUB __UI_AssignIDs
ClickTheVoid = __UI_GetID("ClickTheVoid")
PictureBox1 = __UI_GetID("PictureBox1")
Button1 = __UI_GetID("Button1")
TrackBar1 = __UI_GetID("TrackBar1")
fpsLB = __UI_GetID("fpsLB")
END SUB

View file

@ -0,0 +1,663 @@
': Clock Patience (extra animations) by QWERKEY 2019-01-30 (updated 2019-03-16)
': Version with card pick-up and placement animation
': Images from pngimg.com, all-free-download.com, openclipart.org
': This program uses
': InForm - GUI library for QB64 - Beta version 8
': Fellippe Heitor, 2016-2018 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
': Controls' IDs: ------------------------------------------------------------------
DIM SHARED ClockPatience AS LONG
DIM SHARED ExitBT AS LONG
DIM SHARED NewGameBT AS LONG
CONST Offset%% = 7, Pi! = 3.141592, Hours! = -Pi! / 6, ZOffset! = -398, XImage% = 182, YImage% = 252
CONST Halfwidth%% = 50, Halfheight%% = Halfwidth%% * YImage% / XImage%, Radius% = 320, Tucked%% = 7
DIM SHARED CardsImg&(51), Obverse&, RedHighlight&, GreenHighlight&, GameOver&, GameWon&, XM%, YM%
DIM SHARED PickedUp%%, PickedHour%%, PickedCard%%, CanPutDown%%, Orient!, Orient0!, OldHour%%
DIM SHARED Anime1%%, Anime2%%, DoPickUp%%, TurnOver%%, GreenValid%%, RedValid%%, Cards%%(51)
DIM SHARED DoPatience%%, Stock%%, IsComplete%%, GotOut%%, Positions!(4, 12, 1, 4), Phi!(12)
REDIM SHARED Clock%%(12, 4, 2)
': External modules: ---------------------------------------------------------------
'$INCLUDE:'../../InForm/InForm.bi'
'$INCLUDE:'Clock Patience.frm'
'$INCLUDE:'../../InForm/InForm.ui'
': Event procedures: ---------------------------------------------------------------
SUB __UI_BeforeInit
$EXEICON:'.\clubs.ico'
DoPatience%% = FALSE
Anime1%% = 31
Anime2%% = 43
'Set Data
FOR N%% = 0 TO 6
Phi!(N%%) = N%% * Hours!
NEXT N%%
FOR N%% = 7 TO 11
Phi!(N%%) = (N%% - 12) * Hours!
NEXT N%%
FOR S%% = 0 TO 4
Positions!(S%%, 0, 0, 4) = 0
Positions!(S%%, 0, 1, 4) = Radius% - Tucked%% * S%%
Positions!(S%%, 0, 0, 3) = Positions!(S%%, 0, 0, 4) + Halfwidth%%
Positions!(S%%, 0, 1, 3) = Positions!(S%%, 0, 1, 4) - Halfheight%%
Positions!(S%%, 0, 0, 2) = Positions!(S%%, 0, 0, 4) - Halfwidth%%
Positions!(S%%, 0, 1, 2) = Positions!(S%%, 0, 1, 4) - Halfheight%%
Positions!(S%%, 0, 0, 1) = Positions!(S%%, 0, 0, 4) + Halfwidth%%
Positions!(S%%, 0, 1, 1) = Positions!(S%%, 0, 1, 4) + Halfheight%%
Positions!(S%%, 0, 0, 0) = Positions!(S%%, 0, 0, 4) - Halfwidth%%
Positions!(S%%, 0, 1, 0) = Positions!(S%%, 0, 1, 4) + Halfheight%%
NEXT S%%
FOR S%% = 0 TO 4
FOR N%% = 1 TO 11
FOR M%% = 0 TO 4
CALL Angle((Positions!(S%%, 0, 0, M%%)), (Positions!(S%%, 0, 1, M%%)), Positions!(S%%, N%%, 0, M%%), Positions!(S%%, N%%, 1, M%%), (Phi!(N%%)))
NEXT M%%
NEXT N%%
NEXT S%%
FOR S%% = 0 TO 4
Positions!(S%%, 12, 0, 0) = Tucked%% * (3 - S%%) - Halfwidth%%
Positions!(S%%, 12, 1, 0) = Halfheight%%
Positions!(S%%, 12, 0, 1) = Positions!(S%%, 12, 0, 0) + 2 * Halfwidth%%
Positions!(S%%, 12, 1, 1) = Halfheight%%
Positions!(S%%, 12, 0, 2) = Tucked%% * (3 - S%%) - Halfwidth%%
Positions!(S%%, 12, 1, 2) = -Halfheight%%
Positions!(S%%, 12, 0, 3) = Positions!(S%%, 12, 0, 2) + 2 * Halfwidth%%
Positions!(S%%, 12, 1, 3) = -Halfheight%%
Positions!(S%%, 12, 0, 4) = Tucked%% * (3 - S%%)
Positions!(S%%, 12, 1, 4) = 0
NEXT S%%
'Images
playingcards& = _LOADIMAGE("pack of cards.png", 32)
Corner& = _NEWIMAGE(33, 33, 32)
_DEST Corner&
COLOR _RGB32(247, 247, 247), _RGBA32(100, 100, 100, 0)
CIRCLE (16, 16), 16
PAINT (16, 16)
CIRCLE (16, 16), 16, _RGB32(204, 119, 34)
FOR N%% = 0 TO 51
R1%% = N%% \ 13
C1%% = N%% MOD 13
R2%% = R1%% \ 2
C2%% = R1%% MOD 2
R3%% = C1%% \ 5
C3%% = C1%% MOD 5
TempImg& = _NEWIMAGE(XImage%, YImage%, 32)
_DEST TempImg&
COLOR _RGB32(247, 247, 247), _RGBA32(100, 100, 100, 0)
_PUTIMAGE (0, 0), Corner&
_PUTIMAGE (0, YImage% - 33), Corner&
_PUTIMAGE (XImage% - 33, 0), Corner&
_PUTIMAGE (XImage% - 33, YImage% - 33), Corner&
LINE (16, 0)-(XImage% - 17, YImage% - 1), , BF
LINE (0, 16)-(XImage% - 1, YImage% - 17), , BF
LINE (16, 0)-(XImage% - 17, 0), _RGB32(204, 119, 34)
LINE (16, YImage% - 1)-(XImage% - 17, YImage% - 1), _RGB32(204, 119, 34)
LINE (0, 16)-(0, YImage% - 17), _RGB32(204, 119, 34)
LINE (XImage% - 1, 16)-(XImage% - 1, YImage% - 17), _RGB32(204, 119, 34)
X1! = 7 + 203 * C3%% + 996 * C2%%
X2! = 167 + X1!
Y1! = 13 + 267 * R3%% + 786 * R2%%
Y2! = Y1! + 222
_PUTIMAGE (6, 14)-(XImage% - 7, YImage% - 15), playingcards&, , (7 + 203 * C3%% + 996 * C2%%, Y1!)-(X2!, Y2!)
IF N%% = 23 THEN
F& = _LOADFONT("cyberbit.ttf", 14)
_FONT F&
COLOR _RGB32(226, 226, 226)
Q1$ = "PVDQJDX"
FOR M%% = 1 TO 7
Q2$ = Q2$ + CHR$(ASC(MID$(Q1$, M%%, 1)) + 1)
NEXT M%%
_PRINTSTRING (XImage% - 110, YImage% - 20), Q2$
_FONT 16
_FREEFONT F&
END IF
CardsImg&(N%%) = _COPYIMAGE(TempImg&, 33)
_FREEIMAGE TempImg&
NEXT N%%
_FREEIMAGE Corner&
Corner& = _NEWIMAGE(33, 33, 32)
_DEST Corner&
COLOR _RGB32(200, 200, 247), _RGBA32(100, 100, 100, 0)
CIRCLE (16, 16), 16
PAINT (16, 16)
CIRCLE (16, 16), 16, _RGB32(204, 119, 34)
TempImg& = _NEWIMAGE(XImage%, YImage%, 32)
_DEST TempImg&
COLOR _RGB32(200, 200, 247)
_PUTIMAGE (0, 0), Corner&
_PUTIMAGE (0, YImage% - 33), Corner&
_PUTIMAGE (XImage% - 33, 0), Corner&
_PUTIMAGE (XImage% - 33, YImage% - 33), Corner&
LINE (16, 0)-(XImage% - 17, YImage% - 1), , BF
LINE (0, 16)-(XImage% - 1, YImage% - 17), , BF
LINE (16, 0)-(XImage% - 17, 0), _RGB32(204, 119, 34)
LINE (16, YImage% - 1)-(XImage% - 17, YImage% - 1), _RGB32(204, 119, 34)
LINE (0, 16)-(0, YImage% - 17), _RGB32(204, 119, 34)
LINE (XImage% - 1, 16)-(XImage% - 1, YImage% - 17), _RGB32(204, 119, 34)
C3%% = 4
C2%% = 0
R3%% = 2
R2%% = 0
X1! = 7 + 203 * C3%% + 996 * C2%%
X2! = 167 + X1!
Y1! = 13 + 267 * R3%% + 786 * R2%%
Y2! = Y1! + 222
_PUTIMAGE (14, 14)-(XImage% - 15, YImage% - 15), playingcards&, , (14 + 203 * C3%% + 996 * C2%%, Y1!)-(X2! - 4, Y2!)
Obverse& = _COPYIMAGE(TempImg&, 33)
_FREEIMAGE TempImg&
_FREEIMAGE Corner&
_FREEIMAGE playingcards&
TempImg& = _NEWIMAGE(81, 81, 32)
_DEST TempImg&
COLOR _RGB32(200, 0, 0)
CIRCLE (40, 40), 40
CIRCLE (40, 40), 39
CIRCLE (40, 40), 38
RedHighlight& = _COPYIMAGE(TempImg&, 33)
_FREEIMAGE TempImg&
TempImg& = _NEWIMAGE(81, 81, 32)
_DEST TempImg&
COLOR _RGB32(0, 200, 0)
CIRCLE (40, 40), 40
CIRCLE (40, 40), 39
CIRCLE (40, 40), 38
GreenHighlight& = _COPYIMAGE(TempImg&, 33)
_FREEIMAGE TempImg&
TempImg& = _NEWIMAGE(340, 80, 32)
_DEST TempImg&
COLOR _RGB32(0, 80, 32), _RGBA32(100, 100, 100, 0)
F& = _LOADFONT("cyberbit.ttf", 70)
_FONT F&
_PRINTSTRING (5, 5), "Game End"
_FONT 16
_FREEFONT F&
GameOver& = _COPYIMAGE(TempImg&, 33)
_FREEIMAGE TempImg&
TempImg& = _NEWIMAGE(356, 80, 32)
_DEST TempImg&
COLOR _RGB32(0, 80, 32), _RGBA32(100, 100, 100, 0)
F& = _LOADFONT("cyberbit.ttf", 70)
_FONT F&
_PRINTSTRING (5, 5), "Completed"
_FONT 16
_FREEFONT F&
GameWon& = _COPYIMAGE(TempImg&, 33)
_FREEIMAGE TempImg&
FOR N%% = 0 TO 51
Cards%%(N%%) = N%% + 1 'Cards%%() values adjusted to 1 - 13: then value 0 is empty
NEXT N%%
FOR N%% = 1 TO 4
CALL Shuffle(Cards%%())
NEXT N%%
END SUB
SUB __UI_OnLoad
_SCREENMOVE 50, 0
Caption(NewGameBT) = "Deal"
SetFocus NewGameBT
END SUB
SUB __UI_BeforeUpdateDisplay
'This event occurs at approximately 30 frames per second.
'You can change the update frequency by calling SetFrameRate DesiredRate%
STATIC Count%, InitDone%%, Grandad&, XStart%, YStart%
IF NOT InitDone%% THEN
InitDone%% = TRUE
XStart% = -120
YStart% = 0
Grandad& = _LOADIMAGE("Clock1.png", 33)
END IF
IF NOT DoPatience%% THEN
_PUTIMAGE (201, 10), Grandad&
ELSE
IF GreenValid%% THEN
_MAPTRIANGLE (0, 0)-(80, 0)-(0, 80), GreenHighlight& TO(Positions!(4, PickedHour%%, 0, 4) - 40, Positions!(4, PickedHour%%, 1, 4) + 40, ZOffset!)-(Positions!(4, PickedHour%%, 0, 4) + 40, Positions!(4, PickedHour%%, 1, 4) + 40, ZOffset!)-(Positions!(4, PickedHour%%, 0, 4) - 40, Positions!(4, PickedHour%%, 1, 4) - 40, ZOffset!)
_MAPTRIANGLE (80, 80)-(0, 80)-(80, 0), GreenHighlight& TO(Positions!(4, PickedHour%%, 0, 4) + 40, Positions!(4, PickedHour%%, 1, 4) + -40, ZOffset!)-(Positions!(4, PickedHour%%, 0, 4) - 40, Positions!(4, PickedHour%%, 1, 4) - 40, ZOffset!)-(Positions!(4, PickedHour%%, 0, 4) + 40, Positions!(4, PickedHour%%, 1, 4) + 40, ZOffset!)
ELSEIF RedValid%% THEN
_MAPTRIANGLE (0, 0)-(80, 0)-(0, 80), RedHighlight& TO(Positions!(4, PickedHour%%, 0, 4) - 40, Positions!(4, PickedHour%%, 1, 4) + 40, ZOffset!)-(Positions!(4, PickedHour%%, 0, 4) + 40, Positions!(4, PickedHour%%, 1, 4) + 40, ZOffset!)-(Positions!(4, PickedHour%%, 0, 4) - 40, Positions!(4, PickedHour%%, 1, 4) - 40, ZOffset!)
_MAPTRIANGLE (80, 80)-(0, 80)-(80, 0), RedHighlight& TO(Positions!(4, PickedHour%%, 0, 4) + 40, Positions!(4, PickedHour%%, 1, 4) + -40, ZOffset!)-(Positions!(4, PickedHour%%, 0, 4) - 40, Positions!(4, PickedHour%%, 1, 4) - 40, ZOffset!)-(Positions!(4, PickedHour%%, 0, 4) + 40, Positions!(4, PickedHour%%, 1, 4) + 40, ZOffset!)
END IF
IF Anime1%% < 31 THEN
'Display turning-over
IF OldHour%% = 12 THEN
IF Anime1%% > 15 THEN
Xtent! = 2 * Halfwidth%% * (Anime1%% - 15) / 15
X0! = Positions!(4, OldHour%%, 0, 0)
Y0! = Positions!(4, OldHour%%, 1, 0)
Z0! = 0.7 * SQR((4 * Halfwidth%% * Halfwidth%%) - (Xtent! * Xtent!))
X1! = Positions!(4, OldHour%%, 0, 0) + Xtent!
Y1! = Positions!(4, OldHour%%, 1, 0)
Z1! = 0
X2! = Positions!(4, OldHour%%, 0, 2)
Y2! = Positions!(4, OldHour%%, 1, 2)
Z2! = 0.7 * SQR((4 * Halfwidth%% * Halfwidth%%) - (Xtent! * Xtent!))
X3! = Positions!(4, OldHour%%, 0, 2) + Xtent!
Y3! = Positions!(4, OldHour%%, 1, 2)
Z3! = 0
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), CardsImg&(PickedCard%% - 1) TO(X0!, Y0!, Z0! + ZOffset!)-(X1!, Y1!, Z1! + ZOffset!)-(X2!, Y2!, Z2! + ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), CardsImg&(PickedCard%% - 1) TO(X3!, Y3!, Z3! + ZOffset!)-(X2!, Y2!, Z2! + ZOffset!)-(X1!, Y1!, Z1! + ZOffset!)
ELSE
Psi! = Anime1%% * Pi! / (2 * 15)
X0! = Positions!(4, OldHour%%, 0, 0)
Y0! = Positions!(4, OldHour%%, 1, 0)
Z0! = 0
X1! = X0! + 2 * Halfwidth%% * COS(Psi!)
Y1! = Y0!
Z1! = 0.7 * 2 * Halfwidth%% * SIN(Psi!)
X2! = Positions!(4, OldHour%%, 0, 2)
Y2! = Positions!(4, OldHour%%, 1, 2)
Z2! = 0
X3! = X2! + 2 * Halfwidth%% * COS(Psi!)
Y3! = Y2!
Z3! = 0.7 * 2 * Halfwidth%% * SIN(Psi!)
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), Obverse& TO(X0!, Y0!, Z0! + ZOffset!)-(X1!, Y1!, Z1! + ZOffset!)-(X2!, Y2!, Z2! + ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), Obverse& TO(X3!, Y3!, Z3! + ZOffset!)-(X2!, Y2!, Z2! + ZOffset!)-(X1!, Y1!, Z1! + ZOffset!)
END IF
ELSE
IF Anime1%% > 15 THEN
Xtent! = 2 * Halfwidth%% * (Anime1%% - 15) / 15
XA! = Positions!(4, 0, 0, 0)
YA! = Positions!(4, 0, 1, 0)
Z0! = 0.7 * SQR((4 * Halfwidth%% * Halfwidth%%) - (Xtent! * Xtent!))
XB! = Positions!(4, 0, 0, 0) + Xtent!
YB! = Positions!(4, 0, 1, 0)
Z1! = 0
XC! = Positions!(4, 0, 0, 2)
YC! = Positions!(4, 0, 1, 2)
Z2! = 0.7 * SQR((4 * Halfwidth%% * Halfwidth%%) - (Xtent! * Xtent!))
XD! = Positions!(4, 0, 0, 2) + Xtent!
YD! = Positions!(4, 0, 1, 2)
Z3! = 0
CALL Angle((XA!), (YA!), X0!, Y0!, Orient0!)
CALL Angle((XB!), (YB!), X1!, Y1!, Orient0!)
CALL Angle((XC!), (YC!), X2!, Y2!, Orient0!)
CALL Angle((XD!), (YD!), X3!, Y3!, Orient0!)
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), CardsImg&(PickedCard%% - 1) TO(X0!, Y0!, Z0! + ZOffset!)-(X1!, Y1!, Z1! + ZOffset!)-(X2!, Y2!, Z2! + ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), CardsImg&(PickedCard%% - 1) TO(X3!, Y3!, Z3! + ZOffset!)-(X2!, Y2!, Z2! + ZOffset!)-(X1!, Y1!, Z1! + ZOffset!)
ELSE
Psi! = Anime1%% * Pi! / (2 * 15)
XA! = Positions!(4, 0, 0, 0)
YA! = Positions!(4, 0, 1, 0)
Z0! = 0
XB! = XA! + 2 * Halfwidth%% * COS(Psi!)
YB! = YA!
Z1! = 0.7 * 2 * Halfwidth%% * SIN(Psi!)
XC! = Positions!(4, 0, 0, 2)
YC! = Positions!(4, 0, 1, 2)
Z2! = 0
XD! = XC! + 2 * Halfwidth%% * COS(Psi!)
YD! = YC!
Z3! = 0.7 * 2 * Halfwidth%% * SIN(Psi!)
CALL Angle((XA!), (YA!), X0!, Y0!, Orient0!)
CALL Angle((XB!), (YB!), X1!, Y1!, Orient0!)
CALL Angle((XC!), (YC!), X2!, Y2!, Orient0!)
CALL Angle((XD!), (YD!), X3!, Y3!, Orient0!)
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), Obverse& TO(X0!, Y0!, Z0! + ZOffset!)-(X1!, Y1!, Z1! + ZOffset!)-(X2!, Y2!, Z2! + ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), Obverse& TO(X3!, Y3!, Z3! + ZOffset!)-(X2!, Y2!, Z2! + ZOffset!)-(X1!, Y1!, Z1! + ZOffset!)
END IF
END IF
Anime1%% = Anime1%% + 1
IF Anime1%% = 31 THEN
TurnOver%% = FALSE
Clock%%(PickedHour%%, 4, 0) = PickedCard%%
Clock%%(PickedHour%%, 4, 1) = TRUE 'Temporary until picked up
END IF
ELSEIF Anime2%% < 43 THEN
'Display Tucking-in
IF PickedHour%% = 12 THEN
'Horizontal for Kings
IF Anime2%% > 22 THEN
Xdelta% = Positions!(1, PickedHour%%, 0, 1) - Positions!(4, PickedHour%%, 0, 0) + Tucked%%
X0! = Positions!(4, PickedHour%%, 0, 0) + Xdelta% * (45 - Anime2%%) / 23
Y0! = Positions!(4, PickedHour%%, 1, 0)
X1! = Positions!(4, PickedHour%%, 0, 1) + Xdelta% * (45 - Anime2%%) / 23
Y1! = Positions!(4, PickedHour%%, 1, 1)
X2! = Positions!(4, PickedHour%%, 0, 2) + Xdelta% * (45 - Anime2%%) / 23
Y2! = Positions!(4, PickedHour%%, 1, 2)
X3! = Positions!(4, PickedHour%%, 0, 3) + Xdelta% * (45 - Anime2%%) / 23
Y3! = Positions!(4, PickedHour%%, 1, 3)
Zpos! = -0.5
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), CardsImg&(PickedCard%% - 1) TO(X0!, Y0!, Zpos! + ZOffset!)-(X1!, Y1!, Zpos! + ZOffset!)-(X2!, Y2!, Zpos! + ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), CardsImg&(PickedCard%% - 1) TO(X3!, Y3!, Zpos! + ZOffset!)-(X2!, Y2!, Zpos! + ZOffset!)-(X1!, Y1!, Zpos! + ZOffset!)
ELSE
Xdelta% = Positions!(1, PickedHour%%, 0, 1) - Positions!(4, PickedHour%%, 0, 0) + Tucked%%
X0! = Positions!(4, PickedHour%%, 0, 0) + Xdelta% * Anime2%% / 22
Y0! = Positions!(4, PickedHour%%, 1, 0)
X1! = Positions!(4, PickedHour%%, 0, 1) + Xdelta% * Anime2%% / 22
Y1! = Positions!(4, PickedHour%%, 1, 1)
X2! = Positions!(4, PickedHour%%, 0, 2) + Xdelta% * Anime2%% / 22
Y2! = Positions!(4, PickedHour%%, 1, 2)
X3! = Positions!(4, PickedHour%%, 0, 3) + Xdelta% * Anime2%% / 22
Y3! = Positions!(4, PickedHour%%, 1, 3)
Zpos! = 0.5
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), CardsImg&(PickedCard%% - 1) TO(X0!, Y0!, Zpos! + ZOffset!)-(X1!, Y1!, Zpos! + ZOffset!)-(X2!, Y2!, Zpos! + ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), CardsImg&(PickedCard%% - 1) TO(X3!, Y3!, Zpos! + ZOffset!)-(X2!, Y2!, Zpos! + ZOffset!)-(X1!, Y1!, Zpos! + ZOffset!)
END IF
ELSE
'Vertical for others
IF Anime2%% > 22 THEN
Ydelta% = Positions!(0, 0, 1, 0) - Positions!(4, 0, 1, 2) + Tucked%%
XA! = Positions!(4, 0, 0, 0)
YA! = Positions!(4, 0, 1, 0) + Ydelta% * (45 - Anime2%%) / 23
XB! = Positions!(4, 0, 0, 1)
YB! = Positions!(4, 0, 1, 1) + Ydelta% * (45 - Anime2%%) / 23
XC! = Positions!(4, 0, 0, 2)
YC! = Positions!(4, 0, 1, 2) + Ydelta% * (45 - Anime2%%) / 23
XD! = Positions!(4, 0, 0, 3)
YD! = Positions!(4, 0, 1, 3) + Ydelta% * (45 - Anime2%%) / 23
CALL Angle((XA!), (YA!), X0!, Y0!, Orient!)
CALL Angle((XB!), (YB!), X1!, Y1!, Orient!)
CALL Angle((XC!), (YC!), X2!, Y2!, Orient!)
CALL Angle((XD!), (YD!), X3!, Y3!, Orient!)
Zpos! = -0.5
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), CardsImg&(PickedCard%% - 1) TO(X0!, Y0!, Zpos! + ZOffset!)-(X1!, Y1!, Zpos! + ZOffset!)-(X2!, Y2!, Zpos! + ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), CardsImg&(PickedCard%% - 1) TO(X3!, Y3!, Zpos! + ZOffset!)-(X2!, Y2!, Zpos! + ZOffset!)-(X1!, Y1!, Zpos! + ZOffset!)
ELSE
Ydelta% = Positions!(0, 0, 1, 0) - Positions!(4, 0, 1, 2) + Tucked%%
XA! = Positions!(4, 0, 0, 0)
YA! = Positions!(4, 0, 1, 0) + Ydelta% * Anime2%% / 22
XB! = Positions!(4, 0, 0, 1)
YB! = Positions!(4, 0, 1, 1) + Ydelta% * Anime2%% / 22
XC! = Positions!(4, 0, 0, 2)
YC! = Positions!(4, 0, 1, 2) + Ydelta% * Anime2%% / 22
XD! = Positions!(4, 0, 0, 3)
YD! = Positions!(4, 0, 1, 3) + Ydelta% * Anime2%% / 22
CALL Angle((XA!), (YA!), X0!, Y0!, Orient!)
CALL Angle((XB!), (YB!), X1!, Y1!, Orient!)
CALL Angle((XC!), (YC!), X2!, Y2!, Orient!)
CALL Angle((XD!), (YD!), X3!, Y3!, Orient!)
Zpos! = 0.5
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), CardsImg&(PickedCard%% - 1) TO(X0!, Y0!, Zpos! + ZOffset!)-(X1!, Y1!, Zpos! + ZOffset!)-(X2!, Y2!, Zpos! + ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), CardsImg&(PickedCard%% - 1) TO(X3!, Y3!, Zpos! + ZOffset!)-(X2!, Y2!, Zpos! + ZOffset!)-(X1!, Y1!, Zpos! + ZOffset!)
END IF
END IF
Anime2%% = Anime2%% + 1
IF Anime2%% = 43 THEN CanPutDown%% = TRUE
ELSEIF PickedUp%% THEN
'Display picked-up card
IF __UI_MouseLeft > 680 AND __UI_MouseTop > 738 THEN
'Do Nothing
ELSE
CALL Angle(-Halfwidth%%, Halfheight%, X0!, Y0!, Orient!)
CALL Angle(Halfwidth%%, Halfheight%, X1!, Y1!, Orient!)
CALL Angle(-Halfwidth%%, -Halfheight%, X2!, Y2!, Orient!)
CALL Angle(Halfwidth%%, -Halfheight%, X3!, Y3!, Orient!)
X0! = X0! + XM%
Y0! = Y0! + YM%
X1! = X1! + XM%
Y1! = Y1! + YM%
X2! = X2! + XM%
Y2! = Y2! + YM%
X3! = X3! + XM%
Y3! = Y3! + YM%
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), CardsImg&(PickedCard%% - 1) TO(X0!, Y0!, ZOffset!)-(X1!, Y1!, ZOffset!)-(X2!, Y2!, ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), CardsImg&(PickedCard%% - 1) TO(X3!, Y3!, ZOffset!)-(X2!, Y2!, ZOffset!)-(X1!, Y1!, ZOffset!)
END IF
END IF
'Display Piles
FOR S%% = 4 TO 0 STEP -1 'Maptriangle order is backwards
FOR N%% = 0 TO 12
IF Clock%%(N%%, S%%, 0) <> 0 THEN
IF Clock%%(N%%, S%%, 1) THEN
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), CardsImg&(Clock%%(N%%, S%%, 0) - 1) TO(Positions!(S%%, N%%, 0, 0), Positions!(S%%, N%%, 1, 0), ZOffset!)-(Positions!(S%%, N%%, 0, 1), Positions!(S%%, N%%, 1, 1), ZOffset!)-(Positions!(S%%, N%%, 0, 2), Positions!(S%%, N%%, 1, 2), ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), CardsImg&(Clock%%(N%%, S%%, 0) - 1) TO(Positions!(S%%, N%%, 0, 3), Positions!(S%%, N%%, 1, 3), ZOffset!)-(Positions!(S%%, N%%, 0, 2), Positions!(S%%, N%%, 1, 2), ZOffset!)-(Positions!(S%%, N%%, 0, 1), Positions!(S%%, N%%, 1, 1), ZOffset!)
ELSE
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), Obverse& TO(Positions!(S%%, N%%, 0, 0), Positions!(S%%, N%%, 1, 0), ZOffset!)-(Positions!(S%%, N%%, 0, 1), Positions!(S%%, N%%, 1, 1), ZOffset!)-(Positions!(S%%, N%%, 0, 2), Positions!(S%%, N%%, 1, 2), ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), Obverse& TO(Positions!(S%%, N%%, 0, 3), Positions!(S%%, N%%, 1, 3), ZOffset!)-(Positions!(S%%, N%%, 0, 2), Positions!(S%%, N%%, 1, 2), ZOffset!)-(Positions!(S%%, N%%, 0, 1), Positions!(S%%, N%%, 1, 1), ZOffset!)
END IF
END IF
NEXT N%%
NEXT S%%
IF Stock%% > 0 THEN
'Display Stock
IF Stock%% > 1 THEN
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), Obverse& TO(XStart% - Halfwidth%%, YStart% + Halfheight%%, ZOffset!)-(XStart% + Halfwidth%%, YStart% + Halfheight%%, ZOffset!)-(XStart% - Halfwidth%%, YStart% - Halfheight%%, ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), Obverse& TO(XStart% + Halfwidth%%, YStart% - Halfheight%%, ZOffset!)-(XStart% - Halfwidth%%, YStart% - Halfheight%%, ZOffset!)-(XStart% + Halfwidth%%, YStart% + Halfheight%%, ZOffset!)
END IF
IF Stock%% > 10 THEN
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), Obverse& TO(XStart% - Halfwidth%%, YStart% + Halfheight%% - 1, ZOffset!)-(XStart% + Halfwidth%%, YStart% + Halfheight%% - 1, ZOffset!)-(XStart% - Halfwidth%%, YStart% - Halfheight%% - 1, ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), Obverse& TO(XStart% + Halfwidth%%, YStart% - Halfheight%% - 1, ZOffset!)-(XStart% - Halfwidth%%, YStart% - Halfheight%% - 1, ZOffset!)-(XStart% + Halfwidth%%, YStart% + Halfheight%% - 1, ZOffset!)
END IF
IF Stock%% > 20 THEN
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), Obverse& TO(XStart% - Halfwidth%%, YStart% + Halfheight%% - 2, ZOffset!)-(XStart% + Halfwidth%%, YStart% + Halfheight%% - 2, ZOffset!)-(XStart% - Halfwidth%%, YStart% - Halfheight%% - 2, ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), Obverse& TO(XStart% + Halfwidth%%, YStart% - Halfheight%% - 2, ZOffset!)-(XStart% - Halfwidth%%, YStart% - Halfheight%% - 2, ZOffset!)-(XStart% + Halfwidth%%, YStart% + Halfheight%% - 2, ZOffset!)
END IF
IF Stock%% > 30 THEN
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), Obverse& TO(XStart% - Halfwidth%%, YStart% + Halfheight%% - 3, ZOffset!)-(XStart% + Halfwidth%%, YStart% + Halfheight%% - 3, ZOffset!)-(XStart% - Halfwidth%%, YStart% - Halfheight%% - 3, ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), Obverse& TO(XStart% + Halfwidth%%, YStart% - Halfheight%% - 3, ZOffset!)-(XStart% - Halfwidth%%, YStart% - Halfheight%% - 3, ZOffset!)-(XStart% + Halfwidth%%, YStart% + Halfheight%% - 3, ZOffset!)
END IF
IF Stock%% > 41 THEN
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), Obverse& TO(XStart% - Halfwidth%%, YStart% + Halfheight%% - 4, ZOffset!)-(XStart% + Halfwidth%%, YStart% + Halfheight%% - 4, ZOffset!)-(XStart% - Halfwidth%%, YStart% - Halfheight%% - 4, ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), Obverse& TO(XStart% + Halfwidth%%, YStart% - Halfheight%% - 4, ZOffset!)-(XStart% - Halfwidth%%, YStart% - Halfheight%% - 4, ZOffset!)-(XStart% + Halfwidth%%, YStart% + Halfheight%% - 4, ZOffset!)
END IF
'Display dealt card
S%% = (52 - Stock%%) \ 13
N%% = (52 - Stock%%) MOD 13
Count% = Count% + 1
Zpos! = 50 * SIN(Pi! * Count% / 15)
ActualAngle! = Phi!(N%%) * Count% / 15
XPos! = XStart% + (Positions!(S%%, N%%, 0, 4) - XStart%) * Count% / 15
YPos! = YStart% + (Positions!(S%%, N%%, 1, 4) - YStart%) * Count% / 15
CALL Angle((-Halfwidth%%), (Halfheight%%), X0!, Y0!, (ActualAngle!))
CALL Angle((Halfwidth%%), (Halfheight%%), X1!, Y1!, (ActualAngle!))
CALL Angle((-Halfwidth%%), (-Halfheight%%), X2!, Y2!, (ActualAngle!))
CALL Angle((Halfwidth%%), (-Halfheight%%), X3!, Y3!, (ActualAngle!))
X0! = XPos! + X0!
Y0! = YPos! + Y0!
X1! = XPos! + X1!
Y1! = YPos! + Y1!
X2! = XPos! + X2!
Y2! = YPos! + Y2!
X3! = XPos! + X3!
Y3! = YPos! + Y3!
_MAPTRIANGLE (0, 0)-(XImage% - 1, 0)-(0, YImage% - 1), Obverse& TO(X0!, Y0!, Zpos! + ZOffset!)-(X1!, Y1!, Zpos! + ZOffset!)-(X2!, Y2!, Zpos! + ZOffset!)
_MAPTRIANGLE (XImage% - 1, YImage% - 1)-(0, YImage% - 1)-(XImage% - 1, 0), Obverse& TO(X3!, Y3!, Zpos! + ZOffset!)-(X2!, Y2!, Zpos! + ZOffset!)-(X1!, Y1!, Zpos! + ZOffset!)
IF Count% = 15 THEN
Count% = 0
Clock%%((52 - Stock%%) MOD 13, 1 + ((52 - Stock%%) \ 13), 0) = Clock%%((52 - Stock%%) MOD 13, 1 + ((52 - Stock%%) \ 13), 2)
Stock%% = Stock%% - 1
END IF
END IF
IF IsComplete%% THEN
_PUTIMAGE (230, 246), GameOver&
IF GotOut%% THEN _PUTIMAGE (222, 490), GameWon&
END IF
END IF
END SUB
SUB __UI_BeforeUnload
'If you set __UI_UnloadSignal = False here you can
'cancel the user's request to close.
END SUB
SUB __UI_Click (id AS LONG)
SELECT CASE id
CASE ClockPatience
IF GreenValid%% THEN
DoPickUp%% = TRUE
ELSEIF RedValid%% THEN
Anime2%% = 0
END IF
CASE ExitBT
SYSTEM
CASE NewGameBT
IF NOT DoPatience%% THEN
Control(NewGameBT).Disabled = TRUE
Control(NewGameBT).Hidden = TRUE
Caption(NewGameBT) = "New Game"
SetFocus ExitBT
CALL Patience
ELSE
DoPatience%% = FALSE
Caption(NewGameBT) = "Deal"
END IF
END SELECT
END SUB
SUB __UI_MouseEnter (id AS LONG)
END SUB
SUB __UI_MouseLeave (id AS LONG)
END SUB
SUB __UI_FocusIn (id AS LONG)
END SUB
SUB __UI_FocusOut (id AS LONG)
'This event occurs right before a control loses focus.
'To prevent a control from losing focus, set __UI_KeepFocus = True below.
END SUB
SUB __UI_MouseDown (id AS LONG)
END SUB
SUB __UI_MouseUp (id AS LONG)
END SUB
SUB __UI_KeyPress (id AS LONG)
'When this event is fired, __UI_KeyHit will contain the code of the key hit.
'You can change it and even cancel it by making it = 0
END SUB
SUB __UI_TextChanged (id AS LONG)
END SUB
SUB __UI_ValueChanged (id AS LONG)
END SUB
SUB __UI_FormResized
END SUB
SUB Angle (Xin!, Yin!, Xout!, Yout!, Theta!)
Xout! = Xin! * COS(Theta!) - Yin! * SIN(Theta!)
Yout! = Xin! * SIN(Theta!) + Yin! * COS(Theta!)
END SUB
SUB Patience
RANDOMIZE (TIMER)
BadDeal%% = TRUE
WHILE BadDeal%%
REDIM Clock%%(12, 4, 2)
CALL Shuffle(Cards%%())
'Deal Sim
FOR N%% = 0 TO 51
S%% = N%% \ 13
R%% = N%% MOD 13
Clock%%(R%%, S%% + 1, 2) = Cards%%(N%%)
NEXT N%%
BadDeal%% = FALSE
FOR M%% = 0 TO 12 'Cards are in S 1 to 4
IF Clock%%(M%%, 1, 2) MOD 13 = Clock%%(M%%, 2, 2) MOD 13 AND Clock%%(M%%, 1, 2) MOD 13 = Clock%%(M%%, 3, 2) MOD 13 AND Clock%%(M%%, 1, 2) MOD 13 = Clock%%(M%%, 4, 2) MOD 13 THEN BadDeal%% = TRUE
NEXT M%%
WEND
Stock%% = 52
Anime1%% = 31
Anime2%% = 43
TurnOver%% = TRUE
DoPickUp%% = FALSE
PickedUp%% = FALSE
PickedCard%% = 0
PickedHour%% = 12
CanPutDown%% = FALSE
IsComplete%% = FALSE
DoPatience%% = TRUE
HangOn%% = TRUE
HangStop%% = 50
HCount%% = 0
WHILE DoPatience%%
_LIMIT 60
GreenValid%% = FALSE
RedValid%% = FALSE
IF Stock%% = 0 AND HangOn%% THEN
HCount%% = HCount%% + 1
IF HCount%% = HangStop%% THEN
HangOn%% = FALSE
HCount%% = 0
HangStop%% = 20
END IF
END IF
IF Stock%% = 0 AND NOT IsComplete%% AND Anime1%% = 31 AND Anime2%% = 43 AND NOT HangOn%% THEN
'In _MAPTRIANGLE3D, all distances relative to centre of screen
XM% = __UI_MouseLeft - _WIDTH / 2
YM% = _HEIGHT / 2 - __UI_MouseTop
IF TurnOver%% THEN
Orient0! = Phi!(PickedHour%%) 'Start orientation is from where the card is taken
PickedCard%% = Clock%%(PickedHour%%, 4, 0) 'From 1 to 52
Clock%%(PickedHour%%, 4, 0) = 0
OldHour%% = PickedHour%%
Anime1%% = 0
ELSEIF NOT DoPickUp%% AND NOT PickedUp%% THEN
IF SQR((Positions!(4, PickedHour%%, 0, 4) - XM%) * (Positions!(4, PickedHour%%, 0, 4) - XM%) + (Positions!(4, PickedHour%%, 1, 4) - YM%) * (Positions!(4, PickedHour%%, 1, 4) - YM%)) < 40 THEN GreenValid%% = TRUE
ELSEIF DoPickUp%% THEN
IF PickedHour%% = 12 THEN
FOR R%% = 4 TO 2 STEP -1
Clock%%(PickedHour%%, R%%, 0) = Clock%%(PickedHour%%, R%% - 1, 0)
Clock%%(PickedHour%%, R%%, 1) = Clock%%(PickedHour%%, R%% - 1, 1)
NEXT R%%
Clock%%(PickedHour%%, 1, 0) = 0
ELSE
FOR R%% = 4 TO 1 STEP -1
Clock%%(PickedHour%%, R%%, 0) = Clock%%(PickedHour%%, R%% - 1, 0)
Clock%%(PickedHour%%, R%%, 1) = Clock%%(PickedHour%%, R%% - 1, 1)
NEXT R%%
Clock%%(PickedHour%%, 0, 0) = 0
END IF
PickedHour%% = PickedCard%% MOD 13
IF PickedHour%% = 0 THEN
PickedHour%% = 12
ELSEIF PickedHour%% = 12 THEN
PickedHour%% = 0
END IF
Orient1! = Phi!(PickedHour%%)
PickedUp%% = TRUE
DoPickUp%% = FALSE
ELSEIF PickedUp%% THEN
IF SQR((Positions!(4, PickedHour%%, 0, 4) - XM%) * (Positions!(4, PickedHour%%, 0, 4) - XM%) + (Positions!(4, PickedHour%%, 1, 4) - YM%) * (Positions!(4, PickedHour%%, 1, 4) - YM%)) < 40 THEN
IF NOT CanPutDown%% THEN RedValid%% = TRUE
Orient! = Orient1!
ELSEIF SQR((Positions!(4, OldHour%%, 0, 4) - XM%) * (Positions!(4, OldHour%%, 0, 4) - XM%) + (Positions!(4, OldHour%%, 1, 4) - YM%) * (Positions!(4, OldHour%%, 1, 4) - YM%)) < 40 THEN
Orient! = Orient0!
ELSE
Orient! = 0
END IF
IF CanPutDown%% THEN
CanPutDown%% = FALSE
PickedUp%% = FALSE
HangOn%% = TRUE
IF PickedHour%% = 12 THEN
Clock%%(PickedHour%%, 1, 0) = PickedCard%%
Clock%%(PickedHour%%, 1, 1) = TRUE
ELSE
Clock%%(PickedHour%%, 0, 0) = PickedCard%%
Clock%%(PickedHour%%, 0, 1) = TRUE
END IF
PickedCard%% = 0
IF Clock%%(12, 4, 1) AND Clock%%(12, 1, 0) <> 0 THEN 'Game Finished
IsComplete%% = TRUE
Control(NewGameBT).Disabled = FALSE
Control(NewGameBT).Hidden = FALSE
SetFocus NewGameBT
GotOut%% = TRUE
M%% = 0
WHILE M%% <= 11 AND GotOut%%
IF NOT Clock%%(M%%, 4, 1) THEN GotOut%% = FALSE
M%% = M%% + 1
WEND
END IF
IF NOT IsComplete%% THEN TurnOver%% = TRUE
END IF
END IF
END IF
__UI_DoEvents
WEND
END SUB
SUB Shuffle (Pack%%()) 'Fisher Yates or Knuth shuffle
FOR S%% = 51 TO 1 STEP -1
R%% = INT(RND * S%%) '+ 1
SWAP Pack%%(R%%), Pack%%(S%%)
NEXT S%%
END SUB

View file

@ -0,0 +1,35 @@
': This form was generated by
': InForm - GUI library for QB64 - v1.5
': Fellippe Heitor, 2016-2023 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
SUB __UI_LoadForm
DIM __UI_NewID AS LONG, __UI_RegisterResult AS LONG
__UI_NewID = __UI_NewControl(__UI_Type_Form, "ClockPatience", 800, 800, 0, 0, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Clock Patience"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 12)
Control(__UI_NewID).BackColor = _RGB32(0, 141, 0)
Control(__UI_NewID).HasBorder = False
__UI_NewID = __UI_NewControl(__UI_Type_Button, "ExitBT", 80, 23, 710, 768, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Exit"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "NewGameBT", 80, 23, 710, 736, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "New Game"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
END SUB
SUB __UI_AssignIDs
ClockPatience = __UI_GetID("ClockPatience")
ExitBT = __UI_GetID("ExitBT")
NewGameBT = __UI_GetID("NewGameBT")
END SUB

Binary file not shown.

After

Width:  |  Height:  |  Size: 490 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 3.9 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 66 KiB

Binary file not shown.

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.8 MiB

Binary file not shown.

File diff suppressed because it is too large Load diff

View file

@ -0,0 +1,277 @@
': This form was generated by
': InForm - GUI library for QB64 - v1.5
': Fellippe Heitor, 2016-2023 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
SUB __UI_LoadForm
DIM __UI_NewID AS LONG, __UI_RegisterResult AS LONG
__UI_NewID = __UI_NewControl(__UI_Type_Form, "DuckShoot", 1240, 800, 0, 0, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Duck Shoot"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 12)
Control(__UI_NewID).HasBorder = False
__UI_NewID = __UI_NewControl(__UI_Type_Frame, "OptionsFR", 120, 160, 1120, 640, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Value = 4
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Frame, "GameLevelFR", 100, 174, 1130, 454, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Game Level"
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Value = 6
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Frame, "AudioFR", 100, 80, 1130, 360, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Audio"
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Value = 2
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Frame, "SetKeysFR", 177, 109, 510, 325, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Set Keys"
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Value = 4
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Frame, "LeftHandKeysFR", 150, 180, 510, 456, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Left Hand Keys"
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Value = 5
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Frame, "RightHandKeysFR", 140, 150, 763, 456, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Right Hand Keys"
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Value = 4
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Frame, "SelectKeyFR", 164, 80, 763, 325, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Select Key"
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Value = 3
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Button, "ExitBT", 80, 23, 20, 120, __UI_GetID("OptionsFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Exit"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "ResetBT", 80, 23, 20, 85, __UI_GetID("OptionsFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Reset"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "SetKeysBT", 80, 23, 20, 15, __UI_GetID("OptionsFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Set Keys"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "Level1RB", 80, 23, 12, 15, __UI_GetID("GameLevelFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Level 1"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Value = -1
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "Level2RB", 80, 23, 12, 40, __UI_GetID("GameLevelFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Level 2"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "Level3RB", 80, 23, 12, 65, __UI_GetID("GameLevelFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Level 3"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "Level4RB", 80, 23, 12, 90, __UI_GetID("GameLevelFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Level 4"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "Level5RB", 80, 23, 12, 115, __UI_GetID("GameLevelFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Level 5"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "Level6RB", 80, 23, 12, 140, __UI_GetID("GameLevelFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Level 6"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "AudioOffRB", 80, 23, 12, 15, __UI_GetID("AudioFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Audio Off"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "AudioOnRB", 80, 23, 12, 40, __UI_GetID("AudioFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Audio On"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Value = -1
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "RestartLevelBT", 80, 23, 20, 50, __UI_GetID("OptionsFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Restart Level"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "SetLeftHandKeysRB", 134, 23, 15, 15, __UI_GetID("SetKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Set Left Hand Keys"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Value = -1
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "SetRightHandKeysRB", 134, 23, 15, 45, __UI_GetID("SetKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Set Right Hand Keys"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "FarSightUpRB", 100, 23, 15, 15, __UI_GetID("RightHandKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Far Sight Up"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Value = -1
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "FarSightLeftRB", 100, 23, 15, 45, __UI_GetID("RightHandKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Far Sight Left"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "FarSightRightRB", 110, 23, 15, 75, __UI_GetID("RightHandKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Far Sight Right"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "FarSightDownRB", 110, 23, 15, 105, __UI_GetID("RightHandKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Far Sight Down"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "NearSightUpRB", 110, 23, 15, 15, __UI_GetID("LeftHandKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Near Sight Up"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Value = -1
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "NearSightLeftRB", 110, 23, 15, 45, __UI_GetID("LeftHandKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Near Sight Left"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "NearSightRightRB", 120, 23, 15, 75, __UI_GetID("LeftHandKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Near Sight Right"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "NearSightDownRB", 120, 23, 15, 105, __UI_GetID("LeftHandKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Near Sight Down"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "FireRB", 60, 23, 15, 135, __UI_GetID("LeftHandKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Fire"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_DropdownList, "SelectKeyDD", 60, 23, 15, 45, __UI_GetID("SelectKeyFR"))
__UI_RegisterResult = 0
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 14)
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Label, "SelectKeyLB", 140, 23, 15, 15, __UI_GetID("SelectKeyFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Select Key (Currently w):"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_Button, "DoneBT", 50, 23, 110, 75, __UI_GetID("SetKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Done"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "SetBT", 50, 23, 98, 45, __UI_GetID("SelectKeyFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Set"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "DefaultBT", 70, 23, 20, 75, __UI_GetID("SetKeysFR"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Default"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
END SUB
SUB __UI_AssignIDs
DuckShoot = __UI_GetID("DuckShoot")
OptionsFR = __UI_GetID("OptionsFR")
GameLevelFR = __UI_GetID("GameLevelFR")
AudioFR = __UI_GetID("AudioFR")
SetKeysFR = __UI_GetID("SetKeysFR")
LeftHandKeysFR = __UI_GetID("LeftHandKeysFR")
RightHandKeysFR = __UI_GetID("RightHandKeysFR")
SelectKeyFR = __UI_GetID("SelectKeyFR")
ExitBT = __UI_GetID("ExitBT")
ResetBT = __UI_GetID("ResetBT")
SetKeysBT = __UI_GetID("SetKeysBT")
Level1RB = __UI_GetID("Level1RB")
Level2RB = __UI_GetID("Level2RB")
Level3RB = __UI_GetID("Level3RB")
Level4RB = __UI_GetID("Level4RB")
Level5RB = __UI_GetID("Level5RB")
Level6RB = __UI_GetID("Level6RB")
AudioOffRB = __UI_GetID("AudioOffRB")
AudioOnRB = __UI_GetID("AudioOnRB")
RestartLevelBT = __UI_GetID("RestartLevelBT")
SetLeftHandKeysRB = __UI_GetID("SetLeftHandKeysRB")
SetRightHandKeysRB = __UI_GetID("SetRightHandKeysRB")
FarSightUpRB = __UI_GetID("FarSightUpRB")
FarSightLeftRB = __UI_GetID("FarSightLeftRB")
FarSightRightRB = __UI_GetID("FarSightRightRB")
FarSightDownRB = __UI_GetID("FarSightDownRB")
NearSightUpRB = __UI_GetID("NearSightUpRB")
NearSightLeftRB = __UI_GetID("NearSightLeftRB")
NearSightRightRB = __UI_GetID("NearSightRightRB")
NearSightDownRB = __UI_GetID("NearSightDownRB")
FireRB = __UI_GetID("FireRB")
SelectKeyDD = __UI_GetID("SelectKeyDD")
SelectKeyLB = __UI_GetID("SelectKeyLB")
DoneBT = __UI_GetID("DoneBT")
SetBT = __UI_GetID("SetBT")
DefaultBT = __UI_GetID("DefaultBT")
END SUB

Binary file not shown.

After

Width:  |  Height:  |  Size: 4.5 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 746 KiB

Binary file not shown.

View file

@ -0,0 +1,10 @@
119
115
97
100
112
46
108
39
101
1

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

After

Width:  |  Height:  |  Size: 41 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 82 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 128 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 2.4 MiB

BIN
examples/DuckShoot/tada.mp3 Normal file

Binary file not shown.

Binary file not shown.

After

Width:  |  Height:  |  Size: 8.6 KiB

View file

@ -0,0 +1,424 @@
': Fahrenheit-Celsius Converter by Qwerkey 16/05/20
': Images: pngimg.com
': This program uses
': InForm - GUI library for QB64 - v1.1
': Fellippe Heitor, 2016-2019 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
$ASSERTS
': Controls' IDs: ------------------------------------------------------------------
DIM SHARED FahrenheitToCelsius AS LONG
DIM SHARED ScaleFrame AS LONG
DIM SHARED FahrenheitPBox AS LONG
DIM SHARED CelsiusPBox AS LONG
DIM SHARED DispPB AS LONG
DIM SHARED BodyTempRB AS LONG
DIM SHARED RoomTempRB AS LONG
DIM SHARED FahrenheitTB AS LONG
DIM SHARED CelsiusTB AS LONG
DIM SHARED FahrenheitLB AS LONG
DIM SHARED CelsiusLB AS LONG
DIM SHARED FixTextBoxesTS AS LONG
DIM SHARED FixTextBoxesLB AS LONG
DIM SHARED ExitBT AS LONG
DIM SHARED PicUpdate%%, FSetTemp!, CSetTemp!
DIM SHARED InFahrenheit%%, InCelsius%%, TClicked%%, TempT!
CONST FPos% = 12, CPos% = 31, YPos% = 20, TFPos% = 28, TCPos% = 47, TYPos% = 38, ScaleMin% = 668
CONST TT% = 38, TB% = 668, FL% = 82, FR% = 106, CL% = 321, CR% = 345
': External modules: ---------------------------------------------------------------
'$INCLUDE:'../../InForm/InForm.bi'
'$INCLUDE:'Fahrenheit-Celsius.frm'
'$INCLUDE:'../../InForm/InForm.ui'
': Functions: ----------------------------------------------------------------------
FUNCTION FTOC! (T!, Deg%%)
IF Deg%% THEN
FTOC! = (T! - 32) * 5 / 9
ELSE
FTOC! = (T! * 9 / 5) + 32
END IF
END FUNCTION
FUNCTION OnePlace! (Qty!)
OnePlace! = CINT(10 * Qty!) / 10
END FUNCTION
FUNCTION IText$ (J!)
__IText$ = LTRIM$(STR$(J!))
IText$ = __IText$
IF LEFT$(__IText$, 1) = "." THEN
IText$ = "0" + __IText$
ELSEIF LEFT$(__IText$, 2) = "-." THEN
IText$ = "-0." + RIGHT$(__IText$, LEN(__IText$) - 2)
END IF
END FUNCTION
': Event procedures: ---------------------------------------------------------------
SUB __UI_BeforeInit
END SUB
SUB __UI_OnLoad
_SCREENMOVE 120, 5
END SUB
SUB __UI_BeforeUpdateDisplay
'This event occurs at approximately 30 frames per second.
'You can change the update frequency by calling SetFrameRate DesiredRate%
STATIC InitDone%%, FThermometer&, TBase&, FLiquid&, CThermometer&, CLiquid&
STATIC FT%, FB%, FS%, CT%, CB%, CS%, FTMax%, CTMax%, TD%, FTMin%, CTMin%, OldScale%%
STATIC Pics&(), TRange!()
IF NOT InitDone%% THEN
': Everything (except events) is done in the __UI_BeforeUpdateDisplay SUB
': All initiations, image loading & manipulations are done once here
InitDone%% = TRUE
DIM Pics&(1, 4), TRange!(1, 3)
': Read temperature Ranges
RESTORE temp_range
FOR I1%% = 0 TO 1
FOR J1%% = 0 TO 3
READ TRange!(I1%%, J1%%)
NEXT J1%%
NEXT I1%%
': Load Images
FOR J1%% = 0 TO 4
Pics&(0, J1%%) = _LOADIMAGE("temp" + IText$(J1%%) + ".png", 32)
_ASSERT Pics&(0, J1%%) < -1, "Failed to load temp" + IText$(J1%%) + ".png"
Pics&(1, J1%%) = _LOADIMAGE("temp1" + IText$(J1%%) + ".png", 32)
_ASSERT Pics&(1, J1%%) < -1, "Failed to load temp1" + IText$(J1%%) + ".png"
NEXT J1%%
': _MEM processing to convert red into green for Celsius thermometer
DIM CMem AS _MEM, COff AS _OFFSET
FThermometer& = _LOADIMAGE("thermo.png", 32)
_ASSERT FThermometer& < -1, "Failed to load thermo.png"
TBase& = _LOADIMAGE("tbase.png", 32)
_ASSERT TBase& < -1, "Failed to load tbase.png"
FLiquid& = _LOADIMAGE("rbase.png", 32)
_ASSERT FLiquid& < -1, "Failed to load rbase.png"
CThermometer& = _LOADIMAGE("thermo.png", 32)
_ASSERT CThermometer& < -1, "Failed to load thermo.png"
CLiquid& = _LOADIMAGE("rbase.png", 32)
_ASSERT CLiquid& < -1, "Failed to load rbase.png"
CMem = _MEMIMAGE(CThermometer&)
COff = 0
WHILE COff < CMem.SIZE
B1~%% = _MEMGET(CMem, CMem.OFFSET + COff + 1, _UNSIGNED _BYTE) 'Green
B2~%% = _MEMGET(CMem, CMem.OFFSET + COff + 2, _UNSIGNED _BYTE) 'Red
IF _MEMGET(CMem, CMem.OFFSET + COff + 3, _UNSIGNED _BYTE) <> 0 THEN 'Alpha
IF B2~%% / B1~%% > 1.5 THEN
_MEMPUT CMem, CMem.OFFSET + COff + 1, B2~%% AS _UNSIGNED _BYTE 'Green
_MEMPUT CMem, CMem.OFFSET + COff + 2, B1~%% AS _UNSIGNED _BYTE 'Red
END IF
END IF
COff = COff + 4
WEND
_MEMFREE CMem
CMem = _MEMIMAGE(CLiquid&)
COff = 0
WHILE COff < CMem.SIZE
B1~%% = _MEMGET(CMem, CMem.OFFSET + COff + 1, _UNSIGNED _BYTE) 'Green
B2~%% = _MEMGET(CMem, CMem.OFFSET + COff + 2, _UNSIGNED _BYTE) 'Red
IF _MEMGET(CMem, CMem.OFFSET + COff + 3, _UNSIGNED _BYTE) <> 0 THEN 'Alpha
IF B2~%% / B1~%% > 1.5 THEN
_MEMPUT CMem, CMem.OFFSET + COff + 1, B2~%% AS _UNSIGNED _BYTE 'Green
_MEMPUT CMem, CMem.OFFSET + COff + 2, B1~%% AS _UNSIGNED _BYTE 'Red
END IF
END IF
COff = COff + 4
WEND
_MEMFREE CMem
': Display thermometer images in picture boxes
': All images are software (,32)
BeginDraw FahrenheitPBox
'Drawing code goes here
_PUTIMAGE (FPos%, YPos%), FThermometer&
COLOR _RGB32(0, 0, 0), _RGB32(235, 233, 237)
_PRINTSTRING (72, 20), CHR$(248) + "F"
EndDraw FahrenheitPBox
BeginDraw CelsiusPBox
'Drawing code goes here
_PUTIMAGE (CPos%, YPos%), CThermometer&
COLOR _RGB32(0, 0, 0), _RGB32(235, 233, 237)
_PRINTSTRING (10, 20), CHR$(248) + "C"
EndDraw CelsiusPBox
END IF
': New Scales
IF Control(BodyTempRB).Value <> OldScale%% THEN
OldScale%% = Control(BodyTempRB).Value
IF OldScale%% THEN
': Body Temperature Scales
FSetTemp! = 98.4
CSetTemp! = OnePlace!(FTOC!(FSetTemp!, TRUE))
Text(FahrenheitTB) = IText$(FSetTemp!)
Text(CelsiusTB) = IText$(CSetTemp!)
FT% = 44
FB% = 644
FS% = 5
CT% = 50
CB% = 610
CS% = 7
FTMax% = 106
CTMax% = 42
TD% = 10
FTMin% = FTMax% - (FB% - FT%) / (FS% * TD%)
CTMin% = CTMax% - (CB% - CT%) / (CS% * TD%)
ELSE
': Room Temperature Scales
FT% = 70
FB% = 590
FS% = 2
CT% = 60
CB% = 620
CS% = 4
FTMax% = 220
CTMax% = 100
TD% = 1
FTMin% = FTMax% - (FB% - FT%) / (FS% * TD%)
CTMin% = CTMax% - (CB% - CT%) / (CS% * TD%)
END IF
': Draw Scales
BeginDraw FahrenheitPBox
LINE (60, TT% - 1)-(100, TB% - 1), _RGB32(235, 233, 237), BF
LINE (62, FT%)-(62, FB% + 1), _RGB32(0, 0, 0)
LINE (63, FT%)-(63, FB% + 1), _RGB32(0, 0, 0)
FOR N% = 0 TO (FB% - FT%) / FS%
LINE (62, FT% + N% * FS%)-(67, FT% + N% * FS%), _RGB32(0, 0, 0)
IF N% \ 5 = N% / 5 THEN
LINE (62, FT% + N% * FS%)-(70, FT% + N% * FS%), _RGB32(0, 0, 0)
IF N% \ 10 = N% / 10 THEN
LINE (62, FT% + 1 + N% * FS%)-(70, FT% + 1 + N% * FS%), _RGB32(0, 0, 0)
_PRINTSTRING (72, FT% - 6 + N% * FS%), IText$(FTMax% - N% / TD%)
END IF
END IF
NEXT N%
EndDraw FahrenheitPBox
BeginDraw CelsiusPBox
LINE (0, TT% - 1)-(39, TB% - 1), _RGB32(235, 233, 237), BF
LINE (38, CT%)-(38, CB% + 1), _RGB32(0, 0, 0)
LINE (37, CT%)-(37, CB% + 1), _RGB32(0, 0, 0)
FOR N% = 0 TO (CB% - CT%) / CS%
LINE (33, CT% + N% * CS%)-(38, CT% + N% * CS%), _RGB32(0, 0, 0)
IF N% \ 5 = N% / 5 THEN
LINE (30, CT% + N% * CS%)-(38, CT% + N% * CS%), _RGB32(0, 0, 0)
IF N% \ 10 = N% / 10 THEN
LINE (30, CT% + 1 + N% * CS%)-(38, CT% + 1 + N% * CS%), _RGB32(0, 0, 0)
M% = CTMax% - N% / TD%
MS$ = IText$(M%)
IF M% > 0 AND M% < 100 THEN
MS$ = " " + MS$
ELSEIF M% = 0 THEN
MS$ = " " + MS$
END IF
_PRINTSTRING (4, CT% - 6 + N% * CS%), MS$
END IF
END IF
NEXT N%
EndDraw CelsiusPBox
PicUpdate%% = TRUE
END IF
': Poll Mouse
LM% = __UI_MouseLeft
TM% = __UI_MouseTop
': Look for position inside thermometer tubes and check Click
IF LM% > 70 + TFPos% AND LM% < 70 + TFPos% + 24 AND TM% > FT% AND TM% < FB% THEN
InFahrenheit%% = TRUE
TempT! = OnePlace!(FTMax% + ((TM% - FT%) * (FTMin% - FTMax%) / (FB% - FT%)))
IF NOT TClicked%% THEN Text(FahrenheitTB) = IText$(TempT!)
ELSEIF LM% > 290 + TCPos% AND LM% < 290 + TCPos% + 24 AND TM% > CT% AND TM% < CB% THEN
InCelsius%% = TRUE
TempT! = OnePlace!(CTMax% + (TM% - CT%) * (CTMin% - CTMax%) / (CB% - CT%))
IF NOT TClicked%% THEN Text(CelsiusTB) = IText$(TempT!)
ELSE
IF InFahrenheit%% AND NOT TClicked%% THEN
Text(FahrenheitTB) = IText$(FSetTemp!)
ELSEIF InCelsius%% AND NOT TClicked%% THEN
Text(CelsiusTB) = IText$(CSetTemp!)
END IF
InFahrenheit%% = FALSE
InCelsius%% = FALSE
IF TClicked%% THEN TClicked%% = FALSE
END IF
': Update thermometers
IF PicUpdate%% THEN
PicUpdate%% = FALSE
YF% = FT% + (FSetTemp! - FTMax%) * (FB% - FT%) / (FTMin% - FTMax%)
YC% = CT% + (CSetTemp! - CTMax%) * (CB% - CT%) / (CTMin% - CTMax%)
BeginDraw FahrenheitPBox
_PUTIMAGE (TFPos%, TYPos%), TBase&
IF YF% >= FT% AND YF% <= FB% THEN _PUTIMAGE (TFPos%, YF%)-(TFPos% + 24, ScaleMin%), FLiquid&, , (0, 0)-(24, ScaleMin% - YF%)
EndDraw FahrenheitPBox
BeginDraw CelsiusPBox
_PUTIMAGE (TCPos%, TYPos%), TBase&
IF YC% >= CT% AND YC% <= CB% THEN _PUTIMAGE (TCPos%, YC%)-(TCPos% + 24, ScaleMin%), CLiquid&, , (0, 0)-(24, ScaleMin% - YC%)
EndDraw CelsiusPBox
': If temperature outside thermometer scale do not display liquid column
IF YF% < FT% OR YF% > FB% THEN YF% = ScaleMin%
IF YC% < CT% OR YC% > CB% THEN YC% = ScaleMin%
': If fixed text boxes, set at default
IF Control(FixTextBoxesTS).Value THEN
YF% = 396
YC% = 396
END IF
Control(FahrenheitTB).Top = YF% - 8
Control(CelsiusTB).Top = YC% - 8
Control(FahrenheitLB).Top = YF% - 8 - 23
Control(CelsiusLB).Top = YC% - 8 - 23
': Display Image dependent upon temperature range
BeginDraw DispPB
LINE (0, 0)-(119, 199), _RGB32(235, 233, 237), BF
IF Control(BodyTempRB).Value THEN
SELECT CASE FSetTemp!
CASE IS < TRange!(0, 0)
_PUTIMAGE , Pics&(0, 0)
CASE TRange!(0, 0) TO TRange!(0, 1)
_PUTIMAGE , Pics&(0, 1)
CASE TRange!(0, 1) TO TRange!(0, 2)
_PUTIMAGE , Pics&(0, 2)
CASE TRange!(0, 2) TO TRange!(0, 3)
_PUTIMAGE , Pics&(0, 3)
CASE IS > TRange!(0, 3)
_PUTIMAGE , Pics&(0, 4)
END SELECT
ELSE
SELECT CASE CSetTemp!
CASE IS < TRange!(1, 0)
_PUTIMAGE , Pics&(1, 0)
CASE TRange!(1, 0) TO TRange!(1, 1)
_PUTIMAGE , Pics&(1, 1)
CASE TRange!(1, 1) TO TRange!(1, 2)
_PUTIMAGE , Pics&(1, 2)
CASE TRange!(1, 2) TO TRange!(1, 3)
_PUTIMAGE , Pics&(1, 3)
CASE IS > TRange!(1, 3)
_PUTIMAGE , Pics&(1, 4)
END SELECT
END IF
EndDraw DispPB
END IF
temp_range:
DATA 96.4,97.4,99.4,100.4
DATA -10,10,30,50
END SUB
SUB __UI_BeforeUnload
'If you set __UI_UnloadSignal = False here you can
'cancel the user's request to close.
END SUB
SUB __UI_Click (id AS LONG)
SELECT CASE id
CASE FahrenheitToCelsius
CASE ScaleFrame
CASE DispPB
CASE BodyTempRB
CASE RoomTempRB
CASE FahrenheitTB
CASE CelsiusTB
CASE FahrenheitLB
CASE CelsiusLB
CASE FixTextBoxesLB
CASE FahrenheitPBox
': Check for click in thermometer columns
IF InFahrenheit%% AND NOT TClicked%% THEN
TClicked%% = TRUE
FSetTemp! = OnePlace!(TempT!)
Text(FahrenheitTB) = IText$(FSetTemp!)
CSetTemp! = OnePlace!(FTOC!(FSetTemp!, TRUE))
Text(CelsiusTB) = IText$(CSetTemp!)
PicUpdate%% = TRUE
END IF
CASE CelsiusPBox
': Check for click in thermometer columns
IF InCelsius%% AND NOT TClicked%% THEN
TClicked%% = TRUE
CSetTemp! = OnePlace!(TempT!)
Text(CelsiusTB) = IText$(CSetTemp!)
FSetTemp! = OnePlace!(FTOC!(CSetTemp!, FALSE))
Text(FahrenheitTB) = IText$(FSetTemp!)
PicUpdate%% = TRUE
END IF
CASE FixTextBoxesTS
': Check for Toggle Switch Click
PicUpdate%% = TRUE
CASE ExitBT
': Click Exit Button
SYSTEM
END SELECT
END SUB
SUB __UI_MouseEnter (id AS LONG)
END SUB
SUB __UI_MouseLeave (id AS LONG)
END SUB
SUB __UI_FocusIn (id AS LONG)
END SUB
SUB __UI_FocusOut (id AS LONG)
'This event occurs right before a control loses focus.
'To prevent a control from losing focus, set __UI_KeepFocus = True below.
END SUB
SUB __UI_MouseDown (id AS LONG)
END SUB
SUB __UI_MouseUp (id AS LONG)
END SUB
SUB __UI_KeyPress (id AS LONG)
'When this event is fired, __UI_KeyHit will contain the code of the key hit.
'You can change it and even cancel it by making it = 0
IF __UI_KeyHit = 27 THEN 'Esc key (only responds after a Click event has happened)
SYSTEM
ELSEIF __UI_KeyHit = 13 THEN 'CR
SELECT CASE id
CASE BodyTempRB
CASE RoomTempRB
CASE FixTextBoxesTS
CASE FahrenheitTB
': Update Fahrenheit temperature & convert
FSetTemp! = OnePlace!(VAL(Text(FahrenheitTB)))
Text(FahrenheitTB) = IText$(FSetTemp!)
CSetTemp! = OnePlace!(FTOC!(FSetTemp!, TRUE))
Text(CelsiusTB) = IText$(CSetTemp!)
PicUpdate%% = TRUE
CASE CelsiusTB
': Update Celsius temperature & convert
CSetTemp! = OnePlace!(VAL(Text(CelsiusTB)))
Text(CelsiusTB) = IText$(CSetTemp!)
FSetTemp! = OnePlace!(FTOC!(CSetTemp!, FALSE))
Text(FahrenheitTB) = IText$(FSetTemp!)
PicUpdate%% = TRUE
CASE ExitBT
SYSTEM 'Does this condition ever get met?
END SELECT
END IF
END SUB
SUB __UI_TextChanged (id AS LONG)
END SUB
SUB __UI_ValueChanged (id AS LONG)
END SUB
SUB __UI_FormResized
END SUB

View file

@ -0,0 +1,121 @@
': This form was generated by
': InForm - GUI library for QB64 - v1.5
': Fellippe Heitor, 2016-2023 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
SUB __UI_LoadForm
DIM __UI_NewID AS LONG, __UI_RegisterResult AS LONG
__UI_NewID = __UI_NewControl(__UI_Type_Form, "FahrenheitToCelsius", 460, 750, 0, 0, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Fahrenheit To Celsius"
Control(__UI_NewID).Font = SetFont("segoeui.ttf", 12)
Control(__UI_NewID).HasBorder = False
__UI_NewID = __UI_NewControl(__UI_Type_Frame, "ScaleFrame", 110, 90, 175, 75, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Scale"
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Value = 2
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "FahrenheitPBox", 100, 750, 70, 0, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "CelsiusPBox", 100, 750, 290, 0, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "DispPB", 120, 120, 170, 320, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "BodyTempRB", 90, 23, 10, 16, __UI_GetID("ScaleFrame"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "BodyT emp"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Value = -1
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_RadioButton, "RoomTempRB", 90, 23, 10, 46, __UI_GetID("ScaleFrame"))
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Room Temp"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_TextBox, "FahrenheitTB", 60, 23, 5, 388, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_TextBox, "CelsiusTB", 60, 23, 395, 388, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Label, "FahrenheitLB", 60, 23, 5, 365, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Fahrenheit"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
Control(__UI_NewID).Value = -1
__UI_NewID = __UI_NewControl(__UI_Type_Label, "CelsiusLB", 60, 22, 395, 365, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Celsius"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_ToggleSwitch, "FixTextBoxesTS", 40, 17, 210, 600, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Label, "FixTextBoxesLB", 90, 23, 185, 570, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Fix Text Boxes"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_Button, "ExitBT", 80, 23, 190, 714, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Exit"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
END SUB
SUB __UI_AssignIDs
FahrenheitToCelsius = __UI_GetID("FahrenheitToCelsius")
ScaleFrame = __UI_GetID("ScaleFrame")
FahrenheitPBox = __UI_GetID("FahrenheitPBox")
CelsiusPBox = __UI_GetID("CelsiusPBox")
DispPB = __UI_GetID("DispPB")
BodyTempRB = __UI_GetID("BodyTempRB")
RoomTempRB = __UI_GetID("RoomTempRB")
FahrenheitTB = __UI_GetID("FahrenheitTB")
CelsiusTB = __UI_GetID("CelsiusTB")
FahrenheitLB = __UI_GetID("FahrenheitLB")
CelsiusLB = __UI_GetID("CelsiusLB")
FixTextBoxesTS = __UI_GetID("FixTextBoxesTS")
FixTextBoxesLB = __UI_GetID("FixTextBoxesLB")
ExitBT = __UI_GetID("ExitBT")
END SUB

Binary file not shown.

After

Width:  |  Height:  |  Size: 2.3 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 4.8 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 7 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 6.3 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 37 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 41 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 47 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 44 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 25 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 7.4 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 7.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 7.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 14 KiB

View file

@ -0,0 +1,422 @@
': This program uses
': InForm - GUI library for QB64 - v1.0
': Fellippe Heitor, 2016-2019 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
'Improved fireworks:
' - Particles now leave a trail behind
' - Round explosions (sin/cos been used...)
' - Explosion sound effect.
OPTION _EXPLICIT
TYPE Vector
x AS SINGLE
y AS SINGLE
END TYPE
TYPE Particle
Pos AS Vector
Vel AS Vector
Acc AS Vector
Visible AS _BYTE
Exploded AS _BYTE
ExplosionStep AS _BYTE
ExplosionMax AS _BYTE
Color AS _UNSIGNED LONG
Size AS _BYTE
END TYPE
REDIM SHARED Firework(1 TO 1) AS Particle
REDIM SHARED Boom(1 TO UBOUND(Firework) * 2, 1) AS Particle
DIM SHARED Trail(1 TO 20000) AS Particle
DIM SHARED StartPointLimit AS SINGLE, InitialVel AS SINGLE
DIM SHARED Gravity AS Vector, Pause AS _BYTE, distant AS LONG
InitialVel = -30
Gravity.y = .8
distant = _SNDOPEN("distant.wav")
RANDOMIZE TIMER
': Controls' IDs: ------------------------------------------------------------------
DIM SHARED BabyYoureAFirework AS LONG
DIM SHARED Canvas AS LONG
DIM SHARED MaxFireworksLB AS LONG
DIM SHARED MaxFireworksTrackBar AS LONG
DIM SHARED MaxParticlesLB AS LONG
DIM SHARED MaxParticlesTrackBar AS LONG
DIM SHARED ShowTextCB AS LONG
DIM SHARED YourTextHereTB AS LONG
DIM SHARED HappyNewYearLB AS LONG
': External modules: ---------------------------------------------------------------
'$INCLUDE:'../../InForm/InForm.bi'
'$INCLUDE:'Fireworks.frm'
'$INCLUDE:'../../InForm/InForm.ui'
': Event procedures: ---------------------------------------------------------------
SUB __UI_BeforeInit
END SUB
SUB __UI_OnLoad
_TITLE "Baby, you're a firework"
StartPointLimit = Control(Canvas).Height / 3
Control(MaxFireworksTrackBar).Value = 20
Control(MaxParticlesTrackBar).Value = 150
ToolTip(MaxFireworksTrackBar) = "20"
ToolTip(MaxParticlesTrackBar) = "150"
REDIM _PRESERVE Firework(1 TO Control(MaxFireworksTrackBar).Value) AS Particle
REDIM _PRESERVE Boom(1 TO UBOUND(Firework) * 2, Control(MaxParticlesTrackBar).Value) AS Particle
END SUB
SUB __UI_BeforeUpdateDisplay
STATIC JustExploded AS _BYTE
STATIC t AS INTEGER, Initial AS _BYTE, InitialX AS INTEGER, lastInitial#
DIM AS LONG j, i, a
DIM AS _UNSIGNED LONG thisColor
_DEST Control(Canvas).HelperCanvas
IF JustExploded THEN
JustExploded = FALSE
CLS , _RGB32(0, 0, 50)
ELSE
CLS
END IF
IF _CEIL(RND * 20) < 2 OR (Initial = FALSE AND TIMER - lastInitial# > .1) THEN
'Create a new particle
FOR j = 1 TO UBOUND(Firework)
IF Firework(j).Visible = FALSE THEN
Firework(j).Vel.y = InitialVel
Firework(j).Vel.x = 3 - _CEIL(RND * 6)
IF Initial = TRUE THEN
Firework(j).Pos.x = _CEIL(RND * Control(Canvas).Width)
ELSE
Firework(j).Pos.x = InitialX * (Control(Canvas).Width / 15)
InitialX = InitialX + 1
lastInitial# = TIMER
IF InitialX > 15 THEN Initial = TRUE
END IF
Firework(j).Pos.y = Control(Canvas).Height + _CEIL(RND * StartPointLimit)
Firework(j).Visible = TRUE
Firework(j).Exploded = FALSE
Firework(j).ExplosionStep = 0
Firework(j).Size = _CEIL(RND * 2)
IF Firework(j).Size = 1 THEN
Firework(j).ExplosionMax = 9 + _CEIL(RND * 41)
ELSE
Firework(j).ExplosionMax = 9 + _CEIL(RND * 71)
END IF
Firework(j).ExplosionMax = 20 '0
EXIT FOR
END IF
NEXT j
END IF
'Show trail
FOR i = 1 TO UBOUND(Trail)
IF NOT Pause THEN Trail(i).Color = Darken(Trail(i).Color, 70)
IF Trail(i).Size = 1 THEN
PSET (Trail(i).Pos.x, Trail(i).Pos.y), Trail(i).Color
ELSE
PSET (Trail(i).Pos.x, Trail(i).Pos.y), Trail(i).Color
PSET (Trail(i).Pos.x - 1, Trail(i).Pos.y), Trail(i).Color
PSET (Trail(i).Pos.x + 1, Trail(i).Pos.y), Trail(i).Color
PSET (Trail(i).Pos.x, Trail(i).Pos.y - 1), Trail(i).Color
PSET (Trail(i).Pos.x, Trail(i).Pos.y + 1), Trail(i).Color
END IF
NEXT i
'Update and show particles
FOR i = 1 TO UBOUND(Firework)
'Update trail particles
IF Firework(i).Visible = TRUE AND Firework(i).Exploded = FALSE AND NOT Pause THEN
t = t + 1: IF t > UBOUND(Trail) THEN t = 1
Trail(t).Pos.x = Firework(i).Pos.x
Trail(t).Pos.y = Firework(i).Pos.y
Trail(t).Color = _RGB32(255, 255, 255)
'New position
Firework(i).Vel.y = Firework(i).Vel.y + Gravity.y
Firework(i).Pos.y = Firework(i).Pos.y + Firework(i).Vel.y
Firework(i).Pos.x = Firework(i).Pos.x + Firework(i).Vel.x
END IF
'Explode the particle if it reaches max height
IF Firework(i).Vel.y > 0 THEN
IF Firework(i).Exploded = FALSE THEN
Firework(i).Exploded = TRUE
JustExploded = TRUE
IF Firework(1).Size = 1 THEN
IF distant THEN _SNDPLAYCOPY distant, .5
ELSE
IF distant THEN _SNDPLAYCOPY distant, 1
END IF
thisColor~& = _RGB32(_CEIL(RND * 255), _CEIL(RND * 255), _CEIL(RND * 255))
a = 0
FOR j = 1 TO UBOUND(Boom, 2)
Boom(i, j).Pos.x = Firework(i).Pos.x
Boom(i, j).Pos.y = Firework(i).Pos.y
Boom(i, j).Vel.y = SIN(a) * (RND * 10)
Boom(i, j).Vel.x = COS(a) * (RND * 10)
a = a + 1
Boom(i, j).Color = thisColor~&
Boom(i * 2, j).Pos.x = Firework(i).Pos.x + 5
Boom(i * 2, j).Pos.y = Firework(i).Pos.y + 5
Boom(i * 2, j).Vel.y = Boom(i, j).Vel.y
Boom(i * 2, j).Vel.x = Boom(i, j).Vel.x
a = a + 1
Boom(i * 2, j).Color = thisColor~&
NEXT
END IF
END IF
'Show particle
IF Firework(i).Exploded = FALSE THEN
IF Firework(i).Size = 1 THEN
PSET (Firework(i).Pos.x, Firework(i).Pos.y), _RGB32(255, 255, 255)
ELSE
PSET (Firework(i).Pos.x, Firework(i).Pos.y), _RGB32(255, 255, 255)
PSET (Firework(i).Pos.x - 1, Firework(i).Pos.y), _RGB32(255, 255, 255)
PSET (Firework(i).Pos.x + 1, Firework(i).Pos.y), _RGB32(255, 255, 255)
PSET (Firework(i).Pos.x, Firework(i).Pos.y - 1), _RGB32(255, 255, 255)
PSET (Firework(i).Pos.x, Firework(i).Pos.y + 1), _RGB32(255, 255, 255)
END IF
ELSEIF Firework(i).Visible THEN
IF NOT Pause THEN Firework(i).ExplosionStep = Firework(i).ExplosionStep + 1
FOR j = 1 TO UBOUND(Boom, 2)
IF Firework(i).Size = 1 THEN
PSET (Boom(i, j).Pos.x, Boom(i, j).Pos.y), Boom(i, j).Color
ELSE
PSET (Boom(i, j).Pos.x, Boom(i, j).Pos.y), Darken(Boom(i, j).Color, 100 - (Firework(i).ExplosionStep * 100) / Firework(i).ExplosionMax)
PSET (Boom(i, j).Pos.x - 1, Boom(i, j).Pos.y), Darken(Boom(i, j).Color, 100 - (Firework(i).ExplosionStep * 100) / Firework(i).ExplosionMax)
PSET (Boom(i, j).Pos.x + 1, Boom(i, j).Pos.y), Darken(Boom(i, j).Color, 100 - (Firework(i).ExplosionStep * 100) / Firework(i).ExplosionMax)
PSET (Boom(i, j).Pos.x, Boom(i, j).Pos.y - 1), Darken(Boom(i, j).Color, 100 - (Firework(i).ExplosionStep * 100) / Firework(i).ExplosionMax)
PSET (Boom(i, j).Pos.x, Boom(i, j).Pos.y + 1), Darken(Boom(i, j).Color, 100 - (Firework(i).ExplosionStep * 100) / Firework(i).ExplosionMax)
END IF
IF NOT Pause THEN
t = t + 1: IF t > UBOUND(Trail) THEN t = 1
Trail(t).Pos.x = Boom(i, j).Pos.x
Trail(t).Pos.y = Boom(i, j).Pos.y
Trail(t).Size = Boom(i, j).Size
Trail(t).Color = Darken(Boom(i, j).Color, 100 - (Firework(i).ExplosionStep * 100) / Firework(i).ExplosionMax)
t = t + 1: IF t > UBOUND(Trail) THEN t = 1
Trail(t).Pos.x = Boom(i * 2, j).Pos.x
Trail(t).Pos.y = Boom(i * 2, j).Pos.y
Trail(t).Size = Boom(i * 2, j).Size
Trail(t).Color = Darken(Boom(i * 2, j).Color, 150)
Boom(i, j).Vel.y = Boom(i, j).Vel.y + Gravity.y / 10
Boom(i, j).Pos.x = Boom(i, j).Pos.x + Boom(i, j).Vel.x '+ Firework(i).Vel.x
Boom(i, j).Pos.y = Boom(i, j).Pos.y + Boom(i, j).Vel.y
Boom(i * 2, j).Vel.y = Boom(i * 2, j).Vel.y + Gravity.y / 10
Boom(i * 2, j).Pos.x = Boom(i * 2, j).Pos.x + Boom(i * 2, j).Vel.x '+ Firework(i).Vel.x
Boom(i * 2, j).Pos.y = Boom(i * 2, j).Pos.y + Boom(i * 2, j).Vel.y
END IF
NEXT
IF Firework(i).ExplosionStep > Firework(i).ExplosionMax THEN Firework(i).Visible = FALSE
END IF
NEXT
Control(HappyNewYearLB).Hidden = NOT Control(ShowTextCB).Value
_DEST 0
Control(Canvas).PreviousValue = 0
END SUB
SUB __UI_BeforeUnload
END SUB
SUB __UI_Click (id AS LONG)
SELECT CASE id
CASE BabyYoureAFirework
CASE Canvas
Pause = NOT Pause
IF Pause THEN
Caption(HappyNewYearLB) = "PAUSED"
ELSE
Caption(HappyNewYearLB) = Text(YourTextHereTB)
END IF
CASE MaxFireworksLB
CASE MaxFireworksTrackBar
CASE MaxParticlesLB
CASE MaxParticlesTrackBar
CASE ShowTextCB
CASE YourTextHereTB
CASE HappyNewYearLB
END SELECT
END SUB
SUB __UI_MouseEnter (id AS LONG)
SELECT CASE id
CASE BabyYoureAFirework
CASE Canvas
CASE MaxFireworksLB
CASE MaxFireworksTrackBar
CASE MaxParticlesLB
CASE MaxParticlesTrackBar
CASE ShowTextCB
CASE YourTextHereTB
CASE HappyNewYearLB
END SELECT
END SUB
SUB __UI_MouseLeave (id AS LONG)
SELECT CASE id
CASE BabyYoureAFirework
CASE Canvas
CASE MaxFireworksLB
CASE MaxFireworksTrackBar
CASE MaxParticlesLB
CASE MaxParticlesTrackBar
CASE ShowTextCB
CASE YourTextHereTB
CASE HappyNewYearLB
END SELECT
END SUB
SUB __UI_FocusIn (id AS LONG)
SELECT CASE id
CASE MaxFireworksTrackBar
CASE MaxParticlesTrackBar
CASE ShowTextCB
CASE YourTextHereTB
END SELECT
END SUB
SUB __UI_FocusOut (id AS LONG)
SELECT CASE id
CASE MaxFireworksTrackBar
CASE MaxParticlesTrackBar
CASE ShowTextCB
CASE YourTextHereTB
END SELECT
END SUB
SUB __UI_MouseDown (id AS LONG)
SELECT CASE id
CASE BabyYoureAFirework
CASE Canvas
CASE MaxFireworksLB
CASE MaxFireworksTrackBar
CASE MaxParticlesLB
CASE MaxParticlesTrackBar
CASE ShowTextCB
CASE YourTextHereTB
CASE HappyNewYearLB
END SELECT
END SUB
SUB __UI_MouseUp (id AS LONG)
SELECT CASE id
CASE BabyYoureAFirework
CASE Canvas
CASE MaxFireworksLB
CASE MaxFireworksTrackBar
CASE MaxParticlesLB
CASE MaxParticlesTrackBar
CASE ShowTextCB
CASE YourTextHereTB
CASE HappyNewYearLB
END SELECT
END SUB
SUB __UI_KeyPress (id AS LONG)
SELECT CASE id
CASE MaxFireworksTrackBar
CASE MaxParticlesTrackBar
CASE ShowTextCB
CASE YourTextHereTB
END SELECT
END SUB
SUB __UI_TextChanged (id AS LONG)
SELECT CASE id
CASE YourTextHereTB
Caption(HappyNewYearLB) = Text(YourTextHereTB)
END SELECT
END SUB
SUB __UI_ValueChanged (id AS LONG)
Control(id).Value = INT(Control(id).Value)
SELECT CASE id
CASE ShowTextCB
CASE MaxFireworksTrackBar
REDIM _PRESERVE Firework(1 TO Control(MaxFireworksTrackBar).Value) AS Particle
ToolTip(id) = STR$(Control(MaxFireworksTrackBar).Value)
CASE MaxParticlesTrackBar
REDIM _PRESERVE Boom(1 TO UBOUND(Firework) * 2, Control(MaxParticlesTrackBar).Value) AS Particle
ToolTip(id) = STR$(Control(MaxParticlesTrackBar).Value)
END SELECT
END SUB
SUB __UI_FormResized
END SUB

View file

@ -0,0 +1,90 @@
': This form was generated by
': InForm - GUI library for QB64 - v1.5
': Fellippe Heitor, 2016-2023 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
SUB __UI_LoadForm
DIM __UI_NewID AS LONG, __UI_RegisterResult AS LONG
__UI_NewID = __UI_NewControl(__UI_Type_Form, "BabyYoureAFirework", 810, 663, 0, 0, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Baby, you're a firework"
Control(__UI_NewID).Font = SetFont("arial.ttf?InForm/resources/NotoMono-Regular.ttf", 12)
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CenteredWindow = True
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "Canvas", 800, 600, 5, 5, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Label, "MaxFireworksLB", 86, 23, 5, 612, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Max fireworks:"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_TrackBar, "MaxFireworksTrackBar", 120, 40, 95, 612, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Min = 1
Control(__UI_NewID).Max = 20
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).Interval = 1
__UI_NewID = __UI_NewControl(__UI_Type_Label, "MaxParticlesLB", 86, 23, 235, 612, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Max particles:"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).VAlign = __UI_Middle
__UI_NewID = __UI_NewControl(__UI_Type_TrackBar, "MaxParticlesTrackBar", 250, 40, 325, 612, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Min = 1
Control(__UI_NewID).Max = 150
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).Interval = 30
__UI_NewID = __UI_NewControl(__UI_Type_CheckBox, "ShowTextCB", 87, 23, 590, 620, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Show text:"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Value = -1
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_TextBox, "YourTextHereTB", 129, 23, 676, 620, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Your text here"
Text(__UI_NewID) = "Happy New Year!"
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).CanHaveFocus = True
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Label, "HappyNewYearLB", 800, 78, 5, 527, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "Happy New Year!"
Control(__UI_NewID).Font = SetFont("cyberbit.ttf?times.ttf?arial.ttf?InForm/resources/NotoMono-Regular.ttf", 48)
Control(__UI_NewID).ForeColor = _RGB32(255, 255, 255)
Control(__UI_NewID).BackStyle = __UI_Transparent
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
END SUB
SUB __UI_AssignIDs
BabyYoureAFirework = __UI_GetID("BabyYoureAFirework")
Canvas = __UI_GetID("Canvas")
MaxFireworksLB = __UI_GetID("MaxFireworksLB")
MaxFireworksTrackBar = __UI_GetID("MaxFireworksTrackBar")
MaxParticlesLB = __UI_GetID("MaxParticlesLB")
MaxParticlesTrackBar = __UI_GetID("MaxParticlesTrackBar")
ShowTextCB = __UI_GetID("ShowTextCB")
YourTextHereTB = __UI_GetID("YourTextHereTB")
HappyNewYearLB = __UI_GetID("HappyNewYearLB")
END SUB

Binary file not shown.

View file

@ -0,0 +1,147 @@
': This program uses
': InForm - GUI library for QB64 - Beta version 9
': Fellippe Heitor, 2016-2019 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
DEFLNG A-Z
OPTION _EXPLICIT
': Controls' IDs: ------------------------------------------------------------------
DIM SHARED DoneProgressBar AS LONG
DIM SHARED AboutButton AS LONG
DIM SHARED GIFPlaySample AS LONG
DIM SHARED GIFPictureBox AS LONG
DIM SHARED LoadButton AS LONG
DIM SHARED PlayButton AS LONG
': External modules: ---------------------------------------------------------------
'$INCLUDE:'../../InForm/extensions/GIFPlay.bi'
'$INCLUDE:'../../InForm/InForm.bi'
'$INCLUDE:'GIFPlaySample.frm'
'$INCLUDE:'../../InForm/InForm.ui'
'$INCLUDE:'../../InForm/extensions/GIFPlay.bas'
': Event procedures: ---------------------------------------------------------------
SUB __UI_BeforeInit
END SUB
SUB __UI_OnLoad
Control(PlayButton).Disabled = TRUE
Control(DoneProgressBar).Disabled = TRUE
END SUB
SUB __UI_BeforeUpdateDisplay
IF GIF_IsLoaded(GIFPictureBox) THEN
GIF_Draw GIFPictureBox
Control(DoneProgressBar).Value = (GIF_GetElapsedTime(GIFPictureBox) / GIF_GetTotalDuration(GIFPictureBox)) * 100
END IF
END SUB
SUB __UI_BeforeUnload
END SUB
SUB __UI_Click (id AS LONG)
SELECT CASE id
CASE DoneProgressBar
CASE AboutButton
MessageBox "GIFPlay library + InForm-PE demo." + STRING$(2, 10) + "Get it from https://github.com/a740g/InForm-PE", "About " + Caption(GIFPlaySample), MsgBox_OkOnly + MsgBox_Information
CASE GIFPlaySample
CASE LoadButton
DIM fileName AS STRING: fileName = _OPENFILEDIALOG$(Caption(GIFPlaySample), , "*.gif|*.GIF|*.Gif", "GIF Files")
IF LEN(fileName) > 0 THEN
IF GIF_LoadFromFile(GIFPictureBox, fileName) THEN
' Calculate picturebox width based on the aspect ratio of the GIF
Control(GIFPictureBox).Width = GIF_GetWidth(GIFPictureBox) / GIF_GetHeight(GIFPictureBox) * Control(GIFPictureBox).Height
Control(GIFPlaySample).Width = Control(GIFPictureBox).Width + Control(LoadButton).Width + 24
Control(DoneProgressBar).Width = Control(GIFPictureBox).Width
Control(DoneProgressBar).Disabled = FALSE
IF GIF_GetTotalFrames(GIFPictureBox) > 1 THEN
Control(PlayButton).Disabled = FALSE
Caption(PlayButton) = "Play"
ELSE
Control(PlayButton).Disabled = TRUE
END IF
ELSE
Control(PlayButton).Disabled = TRUE
Control(DoneProgressBar).Disabled = TRUE
MessageBox fileName + " failed to load!", "", MsgBox_Exclamation
END IF
END IF
CASE PlayButton
IF GIF_IsPlaying(GIFPictureBox) THEN
GIF_Pause GIFPictureBox
Caption(PlayButton) = "Play"
ELSE
GIF_Play GIFPictureBox
Caption(PlayButton) = "Pause"
END IF
CASE GIFPictureBox
GIF_EnableOverlay GIFPictureBox, FALSE
END SELECT
END SUB
SUB __UI_MouseEnter (id AS LONG)
SELECT CASE id
CASE ELSE
END SELECT
END SUB
SUB __UI_MouseLeave (id AS LONG)
SELECT CASE id
CASE ELSE
END SELECT
END SUB
SUB __UI_FocusIn (id AS LONG)
SELECT CASE id
CASE ELSE
END SELECT
END SUB
SUB __UI_FocusOut (id AS LONG)
SELECT CASE id
CASE ELSE
END SELECT
END SUB
SUB __UI_MouseDown (id AS LONG)
SELECT CASE id
CASE ELSE
END SELECT
END SUB
SUB __UI_MouseUp (id AS LONG)
SELECT CASE id
CASE ELSE
END SELECT
END SUB
SUB __UI_KeyPress (id AS LONG)
SELECT CASE id
CASE ELSE
END SELECT
END SUB
SUB __UI_TextChanged (id AS LONG)
SELECT CASE id
CASE ELSE
END SELECT
END SUB
SUB __UI_ValueChanged (id AS LONG)
SELECT CASE id
CASE ELSE
END SELECT
END SUB
SUB __UI_FormResized
END SUB

View file

@ -0,0 +1,59 @@
': This form was generated by
': InForm - GUI library for QB64 - v1.5
': Fellippe Heitor, 2016-2023 - fellippe@qb64.org - @fellippeheitor
': https://github.com/FellippeHeitor/InForm
'-----------------------------------------------------------
SUB __UI_LoadForm
DIM __UI_NewID AS LONG, __UI_RegisterResult AS LONG
__UI_NewID = __UI_NewControl(__UI_Type_Form, "GIFPlaySample", 425, 367, 0, 0, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "GIFPlay Sample"
Control(__UI_NewID).Font = SetFont("arial.ttf", 12)
Control(__UI_NewID).HasBorder = False
__UI_NewID = __UI_NewControl(__UI_Type_PictureBox, "GIFPictureBox", 320, 320, 95, 10, 0)
__UI_RegisterResult = 0
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).HasBorder = True
Control(__UI_NewID).Align = __UI_Center
Control(__UI_NewID).VAlign = __UI_Middle
Control(__UI_NewID).BorderSize = 1
__UI_NewID = __UI_NewControl(__UI_Type_Button, "LoadButton", 80, 40, 10, 10, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "&Load"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "PlayButton", 80, 40, 10, 55, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "&Play"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_Button, "AboutButton", 80, 40, 10, 100, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "&About"
Control(__UI_NewID).Stretch = True
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).CanHaveFocus = True
__UI_NewID = __UI_NewControl(__UI_Type_ProgressBar, "DoneProgressBar", 320, 23, 95, 335, 0)
__UI_RegisterResult = 0
SetCaption __UI_NewID, "\92;#"
Control(__UI_NewID).HasBorder = False
Control(__UI_NewID).Max = 100
Control(__UI_NewID).ShowPercentage = True
END SUB
SUB __UI_AssignIDs
GIFPlaySample = __UI_GetID("GIFPlaySample")
GIFPictureBox = __UI_GetID("GIFPictureBox")
LoadButton = __UI_GetID("LoadButton")
PlayButton = __UI_GetID("PlayButton")
AboutButton = __UI_GetID("AboutButton")
DoneProgressBar = __UI_GetID("DoneProgressBar")
END SUB

Binary file not shown.

After

Width:  |  Height:  |  Size: 301 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.6 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 978 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 53 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 27 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 104 KiB

Some files were not shown because too many files have changed in this diff Show more