PowerBASIC Users Meeting Point - Source Code Library

Enter PIN popup dialog in DLL.

Thu, 23 Apr 2026 14:54:46 +0000

A popup for user to enter a PIN for return to your app. The number of digits is specified in the call, and checked by the function in the DLL.

Longer description
at https://www.yarker-dsyc.info/Programs/Mi...N_DLL.html

Source, compiled, icons and Help file in ZIP
at https://www.yarker-dsyc.info/Programs/Mi...er_PIN.zip

DLL source:

Code:
#compile dll

#dim all

'================================================================

enum PIN_IDs singular

  '%en_update group

  ID_PINA1Txtbx = &h3000&

  ID_PINA2Txtbx

  ID_PINA3Txtbx

  ID_PINA4Txtbx

  ID_PINA5Txtbx

  ID_PINA6Txtbx

  ID_PINA7Txtbx

  ID_PINA8Txtbx

  ID_PINA9Txtbx

  ID_PINB1Txtbx = &h3010

  ID_PINB2Txtbx

  ID_PINB3Txtbx

  ID_PINB4Txtbx

  ID_PINB5Txtbx

  ID_PINB6Txtbx

  ID_PINB7Txtbx

  ID_PINB8Txtbx

  ID_PINB9Txtbx

  '%bn_clicked group

  ID_PINAExposeBtn

  ID_PINBExposeBtn

  ID_PINSubmitSnglBtn

  ID_PINSubmitDuplBtn

  ID_PINHelp

  ID_PINCanx

  'not selected in callback

  ID_PINInstruLbl

  ID_PINALbl

  ID_PINBLbl                                    'type rect '

end enum 'number up to &h3FF reserved

'

%EM_SETPASSWORDCHAR = &h00CC

%wm_syscommand = &h0112 '(not built into PBWin)

%DT_CalcRect = &h00000400

#resource icon, PIN16, ".\PIN16.ico"

#resource icon, ShowPWon24, ".\ShowPWon24.ico"

#resource icon, ShowPWoff24, ".\ShowPWoff24.ico"

#resource icon, PINSubmit, ".\PINSubmit48.ico"

#resource icon, PINHelp, ".\HelpQuesBtn48.ico"

#resource icon, PINCanx, ".\CancelPIN32.ico"

global gIsVariableDigits, gNumOfDigits as long '(is in PIN_Enter and callback)

global gEntryErrTitle as wstring

declare function ShellExecute lib "Shell32.dll" alias "ShellExecuteW" ( _

    byval hwnd as dword, lpOperation as wstringz, lpFile as wstringz, _

    lpParameters as wstringz, lpDirectory as wstringz, byval nShowCmd as long) _

    as dword

'############################################################# the function ####

function PIN_Enter alias "PIN_Enter" (byval hParent as dword, _

                                      byval DualPIN as long, _

                                      byval NumOfDigits as long) export as dword

'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  static Not1stCall, nFontMono14B as long

  static gEntryErrTitle as wstring

  static RatioX, RatioY as single

  local hPIN_Dlg, PIN as dword

  local TBY, TBX, ID_Dig, PosX as long

  local InstruStr, DigCnt as wstring

  '========================================================= initialization ====

  '····························································· persistent ····

  if Not1stCall = 0 then 'so it is first call

    Not1stCall = -1

    font new "Lucida Console", 14, 1, 1, 0, 0 to nFontMono14B

    dialog default font "Segoe UI", 12, 0, 1

    gEntryErrTitle = "PIN Entry Error"$$

  end if

  '······························································ each call ····

  if (NumOfDigits < 0) or (NumOfDigits > 9) then 'check range

    msgbox "The number of PIN digits can only be optionally"$$ + $$crlf + _

           "not used, or 0 to 9 digits long."$$ + $$crlf + _

           "Not used or 0 is for a variable length PIN of"$$ + $$crlf + _

           "1 to 9 digigits. Otherwise the number of digits is"$$ + $$crlf + _

           "fixed by the using program."$$, _

           %mb_ok or %mb_iconerror or %mb_taskmodal, gEntryErrTitle

    exit function

  end if

  if NumOfDigits = 0 then 'variable number

    gIsVariableDigits = -1

    gNumOfDigits = 9

  else

    gNumOfDigits = NumOfDigits

  end if

  '================================================================= dialog ====

  dialog new hParent, "Enter PIN."$$, _

      0, 10, 200, 120, _

     %ds_3dlook or %ds_modalframe or %ds_nofailcreate or %ds_setfont or _

     %ws_caption or %ws_clipsiblings or %ws_dlgframe or %ws_popup or _

     %ws_sysmenu, %ws_ex_left or %ws_ex_ltrreading to hPIN_Dlg

  dialog set icon hPIN_Dlg, "PIN16"

  '------------------------------------------------------- unit/pixel ratio ----

  #if %pb_revision = &h1004

    dialog units hPIN_Dlg, 1000, 1000 to pixels TBY, TBX 'precycle longs

  #else

    dialog units hPIN_Dlg, 1000, 1000 to pixels TBX, TBY

  #endif

  RatioX = 1000 /TBX : RatioY =  1000 / TBY 'mult img px for button units

  '------------------------------------------------------------- PIN instru ----

  if DualPIN then

    InstruStr = "The application requires dual entry for the requested "$$ + _

                "task. "$$

  end if

  if NumOfDigits then

    InstruStr +="Enter the "$$ + dec$(gNumOfDigits) + " digit PIN. "$$

  else

    InstruStr += "The number of digits is not fixed. The PIN may be 4 "$$ + _

                 "to 9 digits. Leave unused digits at right empty. "$$

  end if

  InstruStr += "The only characters allowed are ""0"" to ""9""."$$

  control add label, hPIN_Dlg, %ID_PINInstruLbl, InstruStr,  _

     5, 4, 185, 34, %ss_left, %ws_ex_left

  control set color hPIN_Dlg, %ID_PINInstruLbl, -1, &hFAFAFA

  '---------------------------------------------------- "A" digit textboxes ----

  control add label, hPIN_Dlg, %ID_PINALbl, "Enter PIN:"$$, _

     4, 45, 42, 10, %ss_right, %ws_ex_left   ''55

  '

  PosX = 49

  for ID_Dig = %ID_PINA1Txtbx to %ID_PINA1Txtbx + gNumOfDigits - 1

    control add textbox, hPIN_Dlg, ID_Dig, ""$$, _

       PosX, 44, 12, 10, %es_center or %es_number or %ws_border or _

       %ws_tabstop or %es_password, %ws_ex_clientedge or %ws_ex_left

    control set font hPIN_Dlg, ID_Dig, nFontMono14B

    PosX += 15

  next

  '

  control add imgbutton, hPIN_Dlg, %ID_PINAExposeBtn, "ShowPWon24", _

     181, 43, 28 * RatioX, 28 * RatioY

  if DualPIN = 0 then

    control add imgbutton, hPIN_Dlg, %ID_PINSubmitSnglBtn, "PINSubmit", _

       49 - (52 * RatioX), 59, 52 * RatioX, 52 * RatioY

   ' dialog set size hPIN_Dlg, 200, 75 + (52 * RatioY)

  else

  '---------------------------------------------------- "B" digit textboxes ----

    PosX = 49

    control add label, hPIN_Dlg, %ID_PINBLbl, "Reenter PIN:"$$, _

       4, 60, 42, 10, %ss_right, %ws_ex_left   ''55

    for ID_Dig = %ID_PINB1Txtbx to %ID_PINB1Txtbx + gNumOfDigits - 1

      control add textbox, hPIN_Dlg, ID_Dig, ""$$, _

         PosX, 60, 12, 10, %es_center or %es_number or %ws_border or _

         %ws_tabstop or %es_password, %ws_ex_clientedge or %ws_ex_left

      control set font hPIN_Dlg, ID_Dig, nFontMono14B

      PosX += 15

    next

  '

    control add imgbutton, hPIN_Dlg, %ID_PINBExposeBtn, "ShowPWon24", _

       181, 59, 28 * RatioX, 28 * RatioY

    control add imgbutton, hPIN_Dlg, %ID_PINSubmitDuplBtn, "PINSubmit", _

       49 - (52 * RatioX), 75, 52 * RatioX, 52 * RatioY

  end if

  '----------------------------------------------------- "A" and "B" common ----

  if DualPIN = 0 then

    control add imgbutton, hPIN_Dlg, %ID_PINHelp, "PINHelp", _

       191 - (99 * RatioX), 59, 52 * RatioX, 52 * RatioY

    control add imgbutton, hPIN_Dlg, %ID_PINCanx, "PINCanx", _

       191 - (36 * RatioX), 59 + (16 * RatioY), (36 * RatioX), (36 * RatioY)

    dialog set size hPIN_Dlg, 200, 76 + (52 * RatioY)

  else

    control add imgbutton, hPIN_Dlg, %ID_PINHelp, "PINHelp", _

       191 - (99 * RatioX), 75, 52 * RatioX, 52 * RatioY

    dialog set size hPIN_Dlg, 200, 92 + (52 * RatioY)

    control add imgbutton, hPIN_Dlg, %ID_PINCanx, "PINCanx", _

       191 - (36 * RatioX), 75 + (16 * RatioY), (36 * RatioX), (36 * RatioY)

  end if

  '

  dialog show modal hPIN_Dlg call  PINDlgCB to PIN

  function = PIN

end function

'================================================================= callback ====

callback function PINDlgCB() as long

  static A_IsExposed, B_IsExposed as long

  static PINStr as wstring

  local TmpL as long

  local TmpS as wstring

  if cb.msg = %wm_command then

    if cb.ctlmsg = %en_update then

      if (cb.ctl >= %ID_PINA1Txtbx) and (cb.ctl <= %ID_PINB9Txtbx) then

        if (gNumOfDigits - 1) > (&h00000F and cb.ctl) then

          control set focus cb.hndl, cb.ctl + 1

        else

          control set focus cb.hndl, %ID_PINB1Txtbx

        end if

      end if

    elseif cb.ctlmsg = %bn_clicked then

      select case as const cb.ctl

        case %ID_PINAExposeBtn

          if A_IsExposed then 'unexpose

            for TmpL = %ID_PINA1Txtbx to %ID_PINA9Txtbx

              control send cb.hndl, TmpL, %EM_SETPASSWORDCHAR,_

                 &h2A, 0

            next

            control set imgbutton cb.hndl, %ID_PINAExposeBtn, "ShowPWon24"

            A_IsExposed = 0

          else 'expose

            for TmpL = %ID_PINA1Txtbx to %ID_PINA9Txtbx

              control send cb.hndl, TmpL, %EM_SETPASSWORDCHAR, 0, 0

            next

            control set imgbutton cb.hndl, %ID_PINAExposeBtn, "ShowPWoff24"

            A_IsExposed = -1

          end if

          for TmpL = %ID_PINA1Txtbx to %ID_PINA9Txtbx

            control redraw cb.hndl, TmpL

          next

        case %ID_PINBExposeBtn

          if B_IsExposed then

            for TmpL = %ID_PINB1Txtbx to %ID_PINB9Txtbx

              control send cb.hndl, TmpL, %EM_SETPASSWORDCHAR,_

                 &h2A, 0

            next

            control set imgbutton cb.hndl, %ID_PINBExposeBtn, "ShowPWon24"

            B_IsExposed = 0

          else 'expose

            for TmpL = %ID_PINB1Txtbx to %ID_PINB9Txtbx

              control send cb.hndl, TmpL, %EM_SETPASSWORDCHAR, 0, 0

            next

            control set imgbutton cb.hndl, %ID_PINBExposeBtn, "ShowPWoff24"

            B_IsExposed = -1

          end if

          for TmpL = %ID_PINB1Txtbx to %ID_PINB9Txtbx

            control redraw cb.hndl, TmpL

          next

        '············································· submit single button ····

        case %ID_PINSubmitSnglBtn, %ID_PINSubmitDuplBtn

          control get text cb.hndl, %ID_PINA1Txtbx to TmpS

          PINStr = TmpS

          for TmpL = 1 to 8

            control get text cb.hndl, %ID_PINA1Txtbx + TmpL to TmpS

            PINStr += TmpS

          next

          TmpL = len(PINStr)

          if gIsVariableDigits then

            if Tmpl < 4 then

              msgbox "Varible length PINs must be 4 to 9 digits "$$ + _

                     "and exactly the same as when it was created."$$, _

                     %mb_ok or %mb_iconerror or %mb_taskmodal, gEntryErrTitle

              exit function

            end if

          else

            if TmpL < gNumOfDigits then

              msgbox "The program using this PIN requires "$$ + _

                     dec$(gNumOfDigits) + " digits."$$, _

                     %mb_ok or %mb_iconerror or %mb_taskmodal, gEntryErrTitle

              exit function

            end if

          end if

          if cb.ctl = %ID_PINSubmitDuplBtn then

            for TmpL = 0 to 8

              control get text cb.hndl, %ID_PINB1Txtbx + TmpL to TmpS

                if TmpS = mid$(PINStr, TmpL + 1, 1) then

                  iterate for

                else

                  msgbox "The and the repeat do not match."$$, _

                         %mb_ok or %mb_iconerror or %mb_taskmodal, _

                         gEntryErrTitle

                  exit function

                end if

              next

          end if

          if gIsVariableDigits then

            TmpL = 9 - len(PINStr)

            PINStr += string$$(TmpL, "0"$$)

          end if

          dialog end cb.hndl, val(PINStr)

        case %ID_PINHelp

         '' ShellExecute

            ShellExecute (0, "open"$$, "PIN_Enter_Help.html", ""$$, ""$$, %sw_shownormal)

        case %ID_PINCanx

          goto NoPIN

      end select

    end if

  elseif (lo(word, cb.wparam) = %sc_close) and (cb.msg = %wm_syscommand) then

    goto NoPIN

  end if

  exit function

  NoPIN:

  TmpL = msgbox("""Yes"", to quit PIN entry."$$ + $$crlf + _

                """No"", to stay and enter a PIN."$$, _

            %mb_yesno or %mb_iconquestion or %mb_defbutton2 or %mb_taskmodal, _

            "Verify Quitting PIN Entry"$$)

  if TmpL = %idno then

    function = -1

  else

    dialog end cb.hndl

  end if

end function

Demo source:

Code:
'File PIN_SLL_demo.bas

#compile exe

#dim all

#if %def(%pb_cc32)

  #console off

#endif

declare function PIN_Enter lib "EnterPIN.dll" alias "PIN_Enter" _

                                            (byval hParent as dword, _

                                             byval DuplPIN as long, _

                                             byval NumOfDigits as long) as dword

function pbmain () as long

  local hTWin, PIN as dword

  local Rspnc as wstring

  txt.window("PIN Enter Popup Demonstration"$$, 400, 70, 20, 75) to hTWin

  txt.color = %rgb_green

  txt.print "At any wait use any key to continue. (like now :) )"$$

  txt.waitkey$

  '

  txt.color = %rgb_blue

  txt.print "A dual PIN entry with number of digits set to 4. "$$;

  txt.color = %rgb_black

  txt.print "Returned PIN is: "$$ + dec$(PIN_Enter(hTWin, 1, 4), 4)"."$$

  txt.color = %rgb_green

  txt.print

  txt.print "Any key to continue."

  txt.waitkey$

  '

  txt.color = %rgb_blue

  txt.print "A single PIN entry with number of digits set to 4. "$$;

  txt.color = %rgb_black

  txt.print "Returned PIN is: "$$ + dec$(PIN_Enter(hTWin, 0, 4), 4)"."$$

  txt.print

  txt.color = %rgb_green

  txt.print """ESC"" to end demo, any other key to continue with next."

  Rspnc = txt.waitkey$

  if Rspnc = $$esc then exit function

  '

  txt.color = %rgb_blue

  txt.print "Number of PIN digits set to 9. "$$;

  txt.color = %rgb_black

  txt.print "Returned PIN is: "$$ + dec$(PIN_Enter(hTWin, 0, 9), 9)"."$$

  txt.color = %rgb_blue

  txt.print "You had to enter 9 digits, or ""Cancel PIN"" to get here."$$

  txt.print

  txt.color = %rgb_green

  txt.print """ESC"" to end demo, any other key to continue with next."

  Rspnc = txt.waitkey$

  if Rspnc = $$esc then exit function

  txt.color = %rgb_blue

  txt.print "Number of PIN digits set to 0 (user preference). "$$

  txt.print "Looks like previous, but 4 to 9 digits allowed."$$;

  txt.print "Returned PIN is: "$$ + dec$(PIN_Enter(hTWin, 0, 0), 9)"."$$

  '

  '---------------------------------------------------------------------

  txt.color = %rgb_green

  txt.print

  txt.print "Any key will close."$$

  txt.waitkey$

end function

How many "1" bits /Is Number a Power of 2

Mon, 16 Mar 2026 09:54:49 +0000

Code:
'The FASTPROCs here are for both PBWin 10 and PBCC 6.

'For older PB versions change FASTPROC to FUNCTION.

'The demo (in PBMAIN below) would need significant change to compile in older

'versions of PB.

#compile exe

#dim all

#if %def(%pb_cc32) 'ignore this in PBWin

  #console off     'no unneeded in PBCC

#endif

'

'#### Please start thread in Programming for comments/questions. ####

'

'I want a solitare game that was not in old PB formum Source Code.

'Do it myself.

'That requires shuffling cards. Instead of repeating shuffle code for other

'games make a DLL.

'Shuffling requires PRNG(s), and seeds for PRNDs. They are useful for more

'than just card game, so another DLL.

'One of the PRNG algorithms fails if seed is a power of 2.

'

'(PRNG is pseudo Random Number Generator, NUT is Number Under Test.)

'

'How many bits are "1"?

''Simple use of the assembly POPCNT needed in power of 2 procs.

''is DWORD/LONG agnostic

fastproc BitCount(byval NUT as long) as long

  ! popcnt eax, NUT

  ! mov NUT, eax

end fastproc = NUT

'

'Is a DWORD number a power of 2?

fastproc IsPowerOf2Dw (byval NUT as long) as long

  ! mov ebx, NUT        'so not to modify NUT

  ! and ebx, &h00000001 'without this 1 returns as PO2

  !  jz IsEven

  ! jmp NotPO2

  IsEven:

  ! popcnt ebx, NUT

  ! cmp ebx, 1

  ! jne NotPO2

  ! mov NUT, -1

  ! jmp Done

  NotPO2:          '   -4 -8

  ! mov NUT, 0

  Done:

end fastproc = NUT

'

'Is a LONG number a power of 2?

''(Second procedure because in DWORD bit 31 is MSB of the number, while

'''in a LONG it is the sign flag and remaining bits are in 2s compliment

'''format.)

fastproc IsPowerOf2Lg (byval NUT as long) as long

  'check if NUT is negative

  !  bt NUT, 31

  ! jc NotPO2

  ! mov ebx, NUT

  ! and ebx, &00000001

  !  jz IsEven

  ! jmp NotPO2

  IsEven:

  ! popcnt ebx, NUT

  ! cmp ebx, 1

  ! jne NotPO2

  ! mov NUT, -1

  ! jmp Done

  NotPO2:

  ! mov NUT, 0

  Done:

end fastproc = NUT

'

'###############################################################################

function pbmain () as long

  local hTWin, NumD as dword

  local NumL, Retrn as long

  txt.window("BitCount, IsPowerOf2Dw and IsPowerOf2Lg"$$, 75, 50, 27, 40) _

                                                                        to hTWin

  '

  txt.color = %rgb_blue : txt.print "BitCount" : txt.color = %rgb_black

  NumL = 1 : Retrn = BitCount(NumL) : gosub PrintCount

  NumL = 2 : Retrn = BitCount(NumL) : gosub PrintCount

  NumL = 15 : Retrn = BitCount(NumL) : gosub PrintCount

  NumL = &h80050006 : Retrn = BitCount(NumL) : gosub PrintCount

  '

  txt.print : txt.color = %rgb_blue

  txt.print "Is DWORD a power of 2?"$$ : txt.color = %rgb_black

  NumD = 1 : Retrn = IsPowerOf2Dw(NumD) : gosub PrintDwd

  NumD = 4 : Retrn = IsPowerOf2Dw(NumD) : gosub PrintDwd

  NumD = 5 : Retrn = IsPowerOf2Dw(NumD) : gosub PrintDwd

  NumD = 4294967294 : Retrn = IsPowerOf2Dw(NumD) : gosub PrintDwd

  '

  txt.print  : txt.color = %rgb_blue

  txt.print "Is LONG a power of 2?"$$ : txt.color = %rgb_black

  NumL = 1 : Retrn = IsPowerOf2Lg(NumL) : gosub PrintLng

  NumL = -1 : Retrn = IsPowerOf2Lg(NumL) : gosub PrintLng

  NumL = 8 : Retrn = IsPowerOf2Lg(NumL) : gosub PrintLng

  NumL = -8 : Retrn = IsPowerOf2Lg(NumL) : gosub PrintLng

  NumL = 128 : Retrn = IsPowerOf2Lg(NumL) : gosub PrintLng

  NumL = -128 : Retrn = IsPowerOf2Lg(NumL) : gosub PrintLng

  NumL = 1024 : Retrn = IsPowerOf2Lg(NumL) : gosub PrintLng

  NumL = -1024 : Retrn = IsPowerOf2Lg(NumL) : gosub PrintLng

  NumL = 1026 : Retrn = IsPowerOf2Lg(NumL) : gosub PrintLng

  NumL = -11026 : Retrn = IsPowerOf2Lg(NumL) : gosub PrintLng

  '

  txt.print

  txt.color = %rgb_green

  txt.print "Any key to close."$$

  txt.waitkey$

  exit function

  PrintCount:

    txt.print dec$(NumL) + " has " + dec$(Retrn) + " ""1"" bits."

  return

  PrintDwd:

    txt.print dec$(NumD);

    if Retrn then

      txt.print " is"$$

    else

      txt.print " is not"$$

    end if

  return

  PrintLng:

    txt.print dec$(NumL);

    if Retrn then

      txt.print " is"$$

    else

      txt.print " is not"$$

    end if

  return

end function

'#### Please start thread in Programming for comments/questions. ####

PB Hex Viewer

Tue, 27 Jan 2026 21:07:19 +0000

Ciao,

I've attached a project I was working some time ago where I experimented AI (OpenAI ChatGPT and Google Gemini together) to code with some help ... well ... a lot of help.

It's a classic visual HEX viewer control able to show some memory buffer.
Clicking on the left hidden panel there are some options to change viewer

Attached 100% 10.4 PowerBasic source code and executable.
Do whatever with the sources.

Hope it can help someone.

Ciao
Eros

  HexControl_v0.4.1.PNG (Size: 189.24 KB / Downloads: 15)

  HexControl_v0.4.1.bas (Size: 102 KB / Downloads: 21)

  HexControl_v0.4.1.EXE.zip (Size: 28.48 KB / Downloads: 8)

  HexControl_v0.4.1_2.PNG (Size: 205.51 KB / Downloads: 13)

Using #RESOURCE RCDATA to implement the missing #RESOURCE AVI

Wed, 14 Jan 2026 15:14:41 +0000

I posted this on the new community run PB Users Forum: https://pbusers.org/forum/viewtopic.php?t=239
Sharing here as well as I think it is useful for those that might not have joined there yet.

============================

It always bothered me that PowerBASIC never implemented a #RESOURCE AVI metastatement. If you want to include an AVI for the animation control via #RESOURCE metastatements it's impossible as you cannot animate directly from RCDATA (or other resource sections available via the #RESOURCE metastatement). It can only be done from an AVI resource section (or from a supplied file path). Yes, you can compile the AVI into an AVI resource section using an RC file compiler and add it as a PBR (which still works but was technically deprecated) or RES, but "you cannot add any other #RESOURCE metastatements in your program" as per the PowerBASIC documentation.

What this code does is allow you to embed AVIs into your code using #RESOURCE RCDATA. After you compile your code to DLL or EXE you run this patcher by supplying the DLL/EXE file path on the command line (or via drag-and-drop). It proceeds to enumerate the AVIs and moves them to an AVI resource section using UpdateResource.

Be aware that you will need to repatch the DLL/EXE each time you re-compile your code.
As such, this could be included in a tool chain to always run after a compile.

Processing is written to a log (AVIRscPtch_Log.csv) in the directory the targeted module is located. To facilitate running in a toolchain it runs silently if no errors occur, but uses MESSAGEBOX to report any errors (in addition to the log).

Code:
' Compiles under PBWIN or PBCC without changes

#COMPILE EXE "AVIRscPtch.exe"

#DIM ALL

'----------------------------------------------------------------------------(')

%UNICODE = 1

'----------------------------------------------------------------------------(')

$DDQ = $DQ + $DQ

'----------------------------------------------------------------------------(')

#INCLUDE "Win32API.inc" ' Roca Headers III_107

'----------------------------------------------------------------------------(')

GLOBAL v_ghMod AS DWORD

GLOBAL v_ghUpd AS DWORD

GLOBAL v_gsExe AS STRING

'----------------------------------------------------------------------------(')

FUNCTION fn_sCSV(BYVAL v_sText AS WSTRING) AS STRING

  IF INSTR(v_sText, ANY CHR$(34, 44)) THEN

      REPLACE $DQ WITH $DDQ IN v_sText

      FUNCTION = $DQ + v_sText + $DQ

  ELSE

      FUNCTION = v_sText

  END IF

END FUNCTION

'----------------------------------------------------------------------------(')

FUNCTION fn_sTimestamp() AS WSTRING

  LOCAL v_uST AS SYSTEMTIME

  GETSYSTEMTIME v_uST

  FUNCTION = _

      FORMAT$(v_uST.wYear, "0000") + "-" + _

      FORMAT$(v_uST.wMonth, "00") + "-" + _

      FORMAT$(v_uST.wDay, "00") + " " + _

      FORMAT$(v_uST.wHour, "00") + ":" + _

      FORMAT$(v_uST.wMinute, "00") + ":" + _

      FORMAT$(v_uST.wSecond, "00") + "Z"

END FUNCTION

'----------------------------------------------------------------------------(')

FUNCTION fn_sGetErrorText(BYVAL v_lError AS LONG) AS WSTRING

  LOCAL v_lReturn AS LONG

  LOCAL v_szBuffer AS WSTRINGZ * 256

  IF v_lError = %ERROR_SUCCESS THEN EXIT FUNCTION

  v_lReturn = FORMATMESSAGE(%FORMAT_MESSAGE_FROM_SYSTEM, BYVAL 0&, v_lError, BYVAL 0&, v_szBuffer, SIZEOF(v_szBuffer), BYVAL 0&)

  IF v_lReturn > 0 THEN FUNCTION = RTRIM$(LEFT$(v_szBuffer, v_lReturn), ANY $CRLF)

END FUNCTION

'----------------------------------------------------------------------------(')

SUB sub_Log(BYVAL v_bError AS LONG, v_sText AS WSTRING)

  LOCAL v_hFile AS LONG

  LOCAL v_lError AS LONG

  LOCAL v_sLogPath AS WSTRING

  LOCAL v_sTimestamp AS WSTRING

  v_sTimestamp = fn_sTimestamp

  v_sLogPath = PATHNAME$(PATH, v_gsExe) + "\AVIRscPtch_Log.csv"

  TRY

      OPEN v_sLogPath FOR APPEND AS # v_hFile

      PRINT # v_hFile, v_sTimestamp + "," + fn_sCSV(v_sText)

      CLOSE # v_hFile

      IF v_bError THEN MESSAGEBOX %HWND_DESKTOP, "Error during patching:" + $LF + v_sText, EXE.NAMEX$, %MB_ICONEXCLAMATION

  CATCH

      v_lError = ERR

      MESSAGEBOX %HWND_DESKTOP, _

        "Could not record message to the log file." + $LF + $LF + _

        "Timestamp:" + $LF + v_sTimestamp + $LF + $LF + _

        "Log Path:" + $LF + v_sLogPath + $LF + $LF + _

        "Error:" + ERROR$(v_lError) + $LF + $LF + _

        "Msg:" + $LF + v_sText, _

        EXE.NAMEX$, %MB_ICONEXCLAMATION

      IF v_hFile THEN CLOSE # v_hFile

  END TRY

END SUB

'----------------------------------------------------------------------------(')

FUNCTION fn_bIsAVI(BYVAL v_pData AS DWORD, BYVAL v_cbData AS DWORD) AS LONG

  IF v_pData = 0 THEN sub_Log 0, "pdata = 0" : EXIT FUNCTION

  IF v_cbData < 12 THEN sub_Log 0, "cbData < 12" : EXIT FUNCTION

  IF PEEK$(v_pData, 4) <> "RIFF" THEN sub_Log 0, "Not a RIFF" : EXIT FUNCTION

  IF PEEK$(v_pData + 8, 4) <> "AVI " THEN sub_Log 0, "Not an AVI" : EXIT FUNCTION

  FUNCTION = %TRUE

END FUNCTION

'----------------------------------------------------------------------------(')

FUNCTION fn_lEnumLangProc( _

      BYVAL v_hModule AS DWORD, _

      BYVAL v_lpType AS DWORD, _

      BYVAL v_lpName AS DWORD, _

      BYVAL v_wLang AS WORD, _

      BYVAL v_lParam AS LONG) AS LONG

  LOCAL v_bOK AS LONG

  LOCAL v_cbData AS DWORD

  LOCAL v_hData AS DWORD

  LOCAL v_hRes AS DWORD

  LOCAL v_lError AS LONG

  LOCAL v_pData AS DWORD

  LOCAL v_wzTypeAVI AS WSTRINGZ * 4

  ' FindResourceEx

  v_hRes = FINDRESOURCEEX(v_hModule, BYVAL %RT_RCDATA, BYVAL v_lpName, v_wLang)

  v_lError = GETLASTERROR

  IF v_hRes = 0 THEN

      sub_Log 0, "Error calling FindResourceEx: " + fn_sGetErrorText(v_lError)

      FUNCTION = %TRUE

      EXIT FUNCTION

  END IF

  v_cbData = SIZEOFRESOURCE(v_hModule, v_hRes)

  v_hData = LOADRESOURCE(v_hModule, v_hRes)

  v_pData = LOCKRESOURCE(v_hData)

  IF fn_bIsAVI(v_pData, v_cbData) THEN

      v_wzTypeAVI = "AVI"

      ' UpdateResource - Copy resource to new resource type

      v_bOK = UPDATERESOURCE(v_ghUpd, BYVAL VARPTR(v_wzTypeAVI), BYVAL v_lpName, v_wLang, BYVAL v_pData, v_cbData)

      v_lError = GETLASTERROR

      IF v_bOK THEN

        ' UpdateResource - Remove resource from old resource type

        v_bOK = UPDATERESOURCE(v_ghUpd, BYVAL %RT_RCDATA, BYVAL v_lpName, v_wLang, BYVAL %NULL, 0)

        v_lError = GETLASTERROR

        IF v_bOK = %FALSE THEN sub_Log 1, "Error calling UpdateResource (delete old): " + fn_sGetErrorText(v_lError)

      ELSE

        sub_Log 1, "Error calling UpdateResource (copy to new): " + fn_sGetErrorText(v_lError)

      END IF

  END IF

  FUNCTION = %TRUE

END FUNCTION

'----------------------------------------------------------------------------(')

FUNCTION fn_lEnumNameProc( _

      BYVAL v_hModule AS DWORD, _

      BYVAL v_lpType AS DWORD, _

      BYVAL v_lpName AS DWORD, _

      BYVAL v_lParam AS LONG) AS LONG

  ENUMRESOURCELANGUAGES(v_hModule, BYVAL %RT_RCDATA, BYVAL v_lpName, CODEPTR(fn_lEnumLangProc), 0)

  FUNCTION = %TRUE

END FUNCTION

'----------------------------------------------------------------------------(')

FUNCTION PBMAIN() AS LONG

  LOCAL v_bOK AS LONG

  LOCAL v_lError AS LONG

  LOCAL v_sCmd AS STRING

  LOCAL v_wzExe AS WSTRINGZ * %MAX_PATH

  v_sCmd = TRIM$(COMMAND$, ANY CHR$(32, 34))

  IF LEN(v_sCmd) THEN

      v_gsExe = v_sCmd

  ELSE

      sub_Log 1, "Please supply a module (DLL/EXE) path to patch"

      EXIT FUNCTION

  END IF

  IF ISFILE(v_gsExe) = %FALSE THEN

      sub_Log 1, "Module (DLL/EXE) path does not exist"

      EXIT FUNCTION

  END IF

  v_wzExe = v_gsExe

  sub_Log 0, "Attemping to patch module: " + $DQ + v_gsExe + $DQ

  v_ghMod = LOADLIBRARYEX(BYVAL VARPTR(v_wzExe), BYVAL %NULL, %LOAD_LIBRARY_AS_DATAFILE)

  v_lError = GETLASTERROR

  IF v_ghMod = 0 THEN

      sub_Log 1, "Error loading module: " + fn_sGetErrorText(v_lError)

      EXIT FUNCTION

  END IF

  ' BeginUpdateResource

  v_ghUpd = BEGINUPDATERESOURCE(BYVAL VARPTR(v_wzExe), %FALSE)

  v_lError = GETLASTERROR

  IF v_ghUpd = 0 THEN

      sub_Log 1, "Error calling BeginUpdateResource: " + fn_sGetErrorText(v_lError)

      FREELIBRARY v_ghMod

      EXIT FUNCTION

  END IF

  ' EnumResourceNames

  v_bOK = ENUMRESOURCENAMES(v_ghMod, BYVAL %RT_RCDATA, CODEPTR(fn_lEnumNameProc), 0)

  v_lError = GETLASTERROR

  IF v_bOK = %FALSE THEN

      sub_Log 1, "Error calling EnumResourceNames: " + fn_sGetErrorText(v_lError)

      FREELIBRARY v_ghMod

      EXIT FUNCTION

  END IF

  ' Release the module

  FREELIBRARY v_ghMod

  ' EndUpdateResource

  v_bOK = ENDUPDATERESOURCE(v_ghUpd, %FALSE)

  v_lError = GETLASTERROR

  IF v_bOK = %FALSE THEN

      sub_Log 1, "Error calling EndUpdateResource: " + fn_sGetErrorText(v_lError)

      EXIT FUNCTION

  END IF

  sub_Log 0, "Module patched"

END FUNCTION

Doubly Linked String/WString List (Parser?)

Sun, 05 Oct 2025 08:15:44 +0000

Compiler? Do you write a compiler or parse code for an existing compiler?
Two versions, String or WString. No dependencies. Fast, get 1,0000,000 values in less than 1/10 of a second.

This is something I did thinking it might be useful for parsing code. It’s a list, queue, stack and deque. You can push, peek pop from front or back.
But it also has a cursor that can be moved forward and backwards. The cursor position also acts as a queue, stack and deque. You can push, peek, pop and delete before and after cursor position. The cursor can save its position one time; you can move around and then return.
Supports Split/Join.
It can load a text file and be saved as a text file (code file). WString version uses UTF8.
It can be stored/restored to/from file, binary format.
It can get a list of files, folders, sub-folders and all files in sub-folders matching a mask.

There are probably a lot better tools out there, but simplicity appeals to me. It seems like each different tool is a whole new programming language to learn. And different versions of the same type of compiler have different tools.

The idea is that you have an input and output list containing lines of code. One or more temporary list can be used to split a line of code apart. Push the output to the output list.

It’s an allocated container, must call …New() before use. Call PtrFree(p) to free handle or pointer. Errors are logged if %LogOnError is defined. Message on error if %MessageOnError is defined. You can use the ExitIf() macro to log parsing errors.

It might be useful, might not.

Code:
'StrList.inc

'Public domain, use at own risk. SDurham

'Function StrListNew() As Long

    'allocate new instance : return container pointer : call PtrFree(p) to free pointer

'Sub StrListClear(ByVal p As StrListT Ptr)

    'empty container

'Function StrListCount(ByVal p As StrListT Ptr) As Long

    'get item count

'Sub StrListAdd(ByVal p As StrListT Ptr, ByRef value As String)

    'append value

'Function StrListCursor(ByVal p As StrListT Ptr) As Long

    'true/false if cursor valid

'Function StrListFirst(ByVal p As StrListT Ptr) As Long

    'move cursor to first node : true/false success

'Function StrListNext(ByVal p As StrListT Ptr) As Long

    'move cursor to next node : true/false success

'Function StrListLast(ByVal p As StrListT Ptr) As Long

    'move cursor to last node : true/false success

'Function StrListPervious(ByVal p As StrListT Ptr) As Long

    'move cursor to previous node : true/false success

'Function StrListRember(ByVal p As StrListT Ptr) As Long

    'remember cursor position : fail if cursor null : true/false success

'Function StrListReturn(ByVal p As StrListT Ptr) As Long

    'return to remembered position : fail if node deleted : true/false success

'Function StrListGet(ByVal p As StrListT Ptr) As String

    'get value at cursor position : null if cursor null

'Function StrListSet(ByVal p As StrListT Ptr, ByRef value As String) As Long

    'set value at cursor position : fail if cursor null : true/false success

'Function StrListDeleteForward(ByVal p As StrListT Ptr) As Long

    'move to next node and delete node at cursor position : fail if cursor null : true/false success

    'cursor will be null if no next node

'Function StrListDeleteBackward(ByVal p As StrListT Ptr) As Long

    'move to previous node and delete node at cursor position : fail if cursor null : true/false success

    'cursor will be null if no previous node

'Function StrListIsBefore(ByVal p As StrListT Ptr) As Long

    'true/false if there is a node before cursor position

'Function StrListIsAfter(ByVal p As StrListT Ptr) As Long

    'true/false if there is a node after cursor position

'Function StrListDeleteBefore(ByVal p As StrListT Ptr) As Long

    'delete node before cursor position : fail if cursor null or no previous node : true/false success

'Function StrListDeleteAfter(ByVal p As StrListT Ptr) As Long

    'delete node after cursor position : fail if cursor null or no next node : true/false success

'Function StrListPushBefore(ByVal p As StrListT Ptr, ByRef value As String) As Long

    'add value before cursor position : fail if cursor null : true/false success

'Function StrListPushAfter(ByVal p As StrListT Ptr, ByRef value As String) As Long

    'add value after cursor position : fail if cursor null : true/false success

    'add value before cursor position : fail if cursor null : true/false success

'Function StrListPeekBefore(ByVal p As StrListT Ptr) As String

    'get value before cursor position : null if cursor invalid or no previous node

'Function StrListPeekAfter(ByVal p As StrListT Ptr) As String

    'get value after cursor position : null if cursor invalid or no next node

'Function StrListPopBefore(ByVal p As StrListT Ptr) As String

    'get and remove value before cursor position : null if cursor invalid or no previous node

'Function StrListPopAfter(ByVal p As StrListT Ptr) As String

    'get and remove value after cursor position : null if cursor invalid or no next node

'Sub StrListPushFirst(ByVal p As StrListT Ptr, ByRef value As String)

    'insert at front

'Sub StrListPushLast(ByVal p As StrListT Ptr, ByRef value As String)

    'append to end

'Function StrListPeekFirst(ByVal p As StrListT Ptr) As String

    'get fist value : null if list empty

'Function StrListPeekLast(ByVal p As StrListT Ptr) As String

    'get last value : null list empty

'Function StrListPopFirst(ByVal p As StrListT Ptr) As String

    'get and remove fist value : null if list empty

'Function StrListPopLast(ByVal p As StrListT Ptr) As String

    'get and remove last value : null if list empty

'Sub StrListImport(ByVal p As StrListT Ptr, a() As String)

    'import PB array

'Sub StrListExport(ByVal p As StrListT Ptr, a() As String)

    'export to PB array

'Sub StrListSplit(ByVal p As StrListT Ptr, ByVal delimited As String, ByVal delimiter As String)

    'split array on delimited string

'Function StrListJoin(ByVal p As StrListT Ptr, ByVal delimiter As String) As String

    'join array on delimiter

'Sub StrListToText(ByVal p As StrListT Ptr, ByVal file As WString)

    'store list as text file

'Sub StrListFromText(ByVal p As StrListT Ptr, ByVal file As WString)

    'load text file

'Sub StrListFolders(ByVal p As StrListT Ptr, ByVal rootFolder As String)

    'get all folders in root folder

'Sub StrListFiles(ByVal p As StrListT Ptr, ByVal folder As String, ByVal mask As String)

    'get all files in folder matching mask

'Sub StrListAllFolders(ByVal p As StrListT Ptr, ByVal rootFolder As String)

    'get all folders in root folder and sub-folders, including root folder

'Sub StrListAllFiles(ByVal p As StrListT Ptr, ByVal rootFolder As String, ByVal mask As String)

    'get all files in root folder, and sub-folders, matching mask

'Function StrListStore(ByVal p As StrListT Ptr) As String

    'store container to String

'Sub StrListRestore(ByVal p As StrListT Ptr, ByRef stored As String)

    'restore container from String

'Sub StrListFileStore(ByVal p As StrListT Ptr, ByVal file As WString)

    'store container to File

'Sub StrListFileRestore(ByVal p As StrListT Ptr, ByVal file As WString)

    'restore container from File

#If Not %Def(%ExitIf240526)

    %ExitIf240526 = 1

    '----------------------------------------------------------------------

    'Error Exit Macro

    'Exit procedure with error message

    'if %LogOnError defined then errors logged to app folder

    'if %MessageOnError defined then message on error

    'if %HaltOnError defined then app halt with message on error

    'Public domain, use at own risk. SDurham

    '----------------------------------------------------------------------

    %ExitIfErr = 151

    '----------------------------------------------------------------------

    Macro ExitIf(test, message, exitWhat)

        If test Then

            ExitLog FuncName$ + "() " + message

            Error %ExitIfErr

            Exit exitWhat

        End If

    End Macro

    Macro ExitF(test, message) = ExitIf(test, message, Function)

    Macro ExitS(test, message) = ExitIf(test, message, Sub)

    Macro ExitM(test, message) = ExitIf(test, message, Method)

    Macro ExitP(test, message) = ExitIf(test, message, Property)

    Macro ExitMC(test, message) = ExitIf(test, message, Macro)

    'GoTo with error message

    Macro GoToIf(test, message, goWhere)

        If test Then

            ExitLog FuncName$ +": "+ message

            Error %ExitIfErr

            GoTo goWhere

        End If

    End Macro

    '----------------------------------------------------------------------

    Sub ExitLog(ByVal message As String) Private

        Local h As Long

        h = FreeFile

        #If %Def(%LogOnError) Or %Def(%MessageOnError) Or %Def(%HaltOnError)

            Open Exe.Path$+"Error.log" For Append As h

            If Lof(h) < 16000 Then

                Print# h, Date$ +", "+ Time$ +", "+ Exe.Full$ +", "+ message

            End If

            Close h

        #EndIf

        #If %Def(%MessageOnError) Or %Def(%HaltOnError)

            ? message,,"Error!"

        #EndIf

        #If %Def(%HaltOnError)

            End

        #EndIf

    End Sub

    '----------------------------------------------------------------------

#EndIf '%ExitIf240526

#If Not %Def(%Memory230925)

    %Memory230925 = 1

    '----------------------------------------------------------------------

    'Memory Allocation

    'Public domain, use at own risk. SDurham

    '----------------------------------------------------------------------

    Declare Function GlobalAlloc Lib "Kernel32.dll" Alias "GlobalAlloc" (ByVal uFlags As Dword, ByVal dwBytes As Dword) As Dword

    Declare Function GlobalReAlloc Lib "Kernel32.dll" Alias "GlobalReAlloc" (ByVal hMem As Dword, ByVal dwBytes As Dword, ByVal uFlags As Dword) As Dword

    Declare Function GlobalFree Lib "Kernel32.dll" Alias "GlobalFree" (ByVal hMem As Dword) As Dword

    %MEMFIXED = &H0000 : %MEMMOVEABLE = &H0002 : %MEMZEROINIT = &H0040 : %MEMGPTR = (%MEMZEROINIT Or %MEMFIXED)

    '----------------------------------------------------------------------

    Function MemAlloc(ByVal bytes As Long) As Long

        'allocate memory

        If bytes Then Function = GlobalAlloc(ByVal %MEMGPTR, ByVal bytes)

    End Function

    '----------------------------------------------------------------------

    Function MemReAlloc(ByVal hMem As Long, ByVal bytes As Long) As Long

        'reallocate new size

        If hMem And bytes Then

            Function = GlobalReAlloc(ByVal hMem, ByVal bytes, ByVal %MEMMOVEABLE Or %MEMZEROINIT)

        ElseIf bytes Then

            Function = GlobalAlloc(ByVal %MEMGPTR, ByVal bytes)

        ElseIf hMem Then

            Function = GlobalFree(ByVal hMem)

        End If

    End Function

    '----------------------------------------------------------------------

    Function MemFree(ByVal hMem As Long) As Long

        'free memory

        If hMem Then GlobalFree(ByVal hMem)

    End Function

    '----------------------------------------------------------------------

#EndIf '%Memory230925

#If Not %Def(%Ptr250717)

    %Ptr250717 = 1

    '----------------------------------------------------------------------

    'Allocate UDT Pointer

    'PtrT must be first item in UDT

    'call PtrNew() to allocate pointer

    'call PtrFree() to free pointer

    'if PtrNewCallback() supplied then called after memory allocated

    'if PtrFinalCallback() supplied then called before memory freed

    'instance count supported but shouldn't be used unless needed

    'should be made clear who is responsible for freeing pointer

    '----------------------------------------------------------------------

    Declare Sub PtrNewCallback(ByVal p As Long)

        'if supplied then called after ponter allocated

    Declare Sub PtrFinalCallback(ByVal p As Long)

        'if supplied then called before ponter freed

    Declare Function PtrStoreCallback(ByVal p As Long) As String

        'return String holding pointer's associated data

    Declare Function PtrRestorCallback(ByRef stored As String) As Long

        'return new instance with data restored

    '----------------------------------------------------------------------

    %PtrTag = 648910727

    Type PtrT

        tag As Long

        instances As Long

        finalCB As Long

    End Type

    '----------------------------------------------------------------------

    Function PtrNew(ByVal SizeOfUdt As Long, ByVal newCB As Long, ByVal finalCB As Long) As Long

        'allocate new pointer instance : return pointer

        'if new callback supplied then called after memory allocated

        'if final callback supplied then called before memory freed

        Local p As PtrT Ptr

        ExitF(SizeOfUdt < SizeOf(PtrT), "invalid size")

            p = MemAlloc(SizeOfUdt)

            If p Then

                @p.tag = %PtrTag

                @p.instances = 1

                @p.finalCB = finalCB

                If newCB Then Call Dword newCB Using PtrNewCallback(p)

                Function = p

            End If

    End Function

    '----------------------------------------------------------------------

    Function PtrFree(ByVal p As PtrT Ptr) As Long

        'free pointer allocated by PtrNew() : return null

        'if final callback was supplied then called before memory freed

        If p Then

            ExitF(@p.tag <> %PtrTag, "invalid ptr")

            ExitF(@p.instances < 1, "invalid instance count")

            Decr @p.instances

            If @p.instances = 0 Then

                If @p.finalCB Then Call Dword @p.finalCB Using PtrFinalCallback(p)

                MemFree(p)

            End If

        End If

    End Function

    '----------------------------------------------------------------------

    Sub PtrIncr(ByVal p As PtrT Ptr)

        'increment instance count

        ExitS(p = 0 Or @p.tag <> %PtrTag, "invalid ptr")

        Incr @p.instances

    End Sub

    '----------------------------------------------------------------------

#EndIf '%Ptr250717

#If Not %Def(%StrBuild250811)

    %StrBuild250811 = 1

    '----------------------------------------------------------------------

    'String Builder

    'Public domain, use at own risk. SDurham

    '----------------------------------------------------------------------

    %BytSize = 1

    %StrBuildBufferMax = 5000000

    '----------------------------------------------------------------------

    Type StrBuildT

        mem As Long

        count As Long

        max As Long

    End Type

    '----------------------------------------------------------------------

    Sub StrBuildPush(t As StrBuildT, ByVal value As String)

        'append value

        Local strlen, currentcount, buffer, newmax As Long

        strlen = Len(value)

        If strlen Then

            If strlen > t.max - t.count Then

                currentcount = t.count : t.count = 0 : t.max = 0

                buffer = Max&(1, 2 * currentcount)

                buffer = Min&(buffer, %StrBuildBufferMax)

                newmax = currentcount + buffer + strlen

                t.mem = MemReAlloc(t.mem, newmax * %BytSize)

                If t.mem = 0 Then Exit Sub

                t.count = currentcount : t.max = newmax

            End If

            Memory Copy StrPtr(value), t.mem + (t.count * %BytSize), strlen * %BytSize

            t.count += strlen

        End If

    End Sub

    '----------------------------------------------------------------------

    Function StrBuildPop(t As StrBuildT) As String

        'get whole string : free memory

        If t.mem And t.count Then Function = Peek$(t.mem, t.count)

        t.mem = MemFree(t.mem)

        t.count = 0

        t.max = 0

    End Function

    '----------------------------------------------------------------------

#EndIf '%StrBuild250811

#If Not %Def(%FileStore250717)

    %FileStore250717 = 1

    Sub FilePut(ByVal file As WString, ByRef value As WString)

        'store value to File

        Local f As Long

        If Len(file) = 0 Then Exit Sub

        f = FreeFile

        Open file For Binary As f

        SetEof f

        Put$ f, value

        Close f

    End Sub

    Function FileGet(ByRef file As WString) As WString

        'restore value from File

        Local f As Long, value As WString

        If IsFalse IsFile(file) Then Exit Function

        f = FreeFile

        Open file For Binary As f

        Get$ f, Lof(f), value

        Close f

        Function = value

    End Function

#EndIf '%FileStore250717

#If Not %Def(%PtrList250812)

    %PtrList250812 = 1

    '----------------------------------------------------------------------

    'Pointer Doubly Linked List : Stack : Queue : Deque

    'pointers to allocated UDTs

    'PtrT must be first item in UDT

    'pointer must have been allocated with PtrNew()

    'stored pointers can't be null

    'Public domain, use at own risk. SDurham

    '----------------------------------------------------------------------

    Declare Function PtrStoreCallback(ByVal p As Long) As String

        'return String holding pointer's associated data

    Declare Function PtrRestorCallback(ByRef stored As String) As Long

        'return new instance with data restored

    '----------------------------------------------------------------------

    %LngSize = 4

    %PtrListTag = -699621965

    Type PtrListNodeT

        allocator As PtrT

        next As PtrListNodeT Ptr

        prev As PtrListNodeT Ptr

        value As Long

    End Type

    Type PtrListT

        allocator As PtrT

        tag As Long

        count As Long

        first As PtrListNodeT Ptr

        last As PtrListNodeT Ptr

        cursor As PtrListNodeT Ptr

        remember As PtrListNodeT Ptr

    End Type

    '----------------------------------------------------------------------

    Function PtrListNew() As Long

        'allocate new instance : return container pointer : call PtrFree(p) to free pointer

        Function = PtrNew(SizeOf(PtrListT), CodePtr(PtrListNewCB), CodePtr(PtrListClear))

    End Function

    '----------------------------------------------------------------------

    Sub PtrListClear(ByVal p As PtrListT Ptr)

        'empty container

        Local node As PtrListNodeT Ptr

        ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        While @p.first

            node = @p.first

            @p.first = @node.next

            PtrFree(node)

        Wend

        @p.last = 0

        @p.count = 0

        @p.cursor = 0

        @p.remember = 0

    End Sub

    '----------------------------------------------------------------------

    Function PtrListCount(ByVal p As PtrListT Ptr) As Long

        'get item count

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        Function = @p.count

    End Function

    '----------------------------------------------------------------------

    Sub PtrListAdd(ByVal p As PtrListT Ptr, ByVal pItem As Long)

        'append value

        PtrListPushLast p, pItem

    End Sub

    '----------------------------------------------------------------------

    Function PtrListCursor(ByVal p As PtrListT Ptr) As Long

        'true/false if cursor valid

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.cursor Then Function = 1

    End Function

    '----------------------------------------------------------------------

    Function PtrListFirst(ByVal p As PtrListT Ptr) As Long

        'move cursor to first node : true/false success

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        @p.cursor = @p.first

        If @p.cursor Then Function = 1

    End Function

    '----------------------------------------------------------------------

    Function PtrListNext(ByVal p As PtrListT Ptr) As Long

        'move cursor to next node : true/false success

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.cursor Then @p.cursor = @p.@cursor.next

        If @p.cursor Then Function = 1

    End Function

    '----------------------------------------------------------------------

    Function PtrListLast(ByVal p As PtrListT Ptr) As Long

        'move cursor to last node : true/false success

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        @p.cursor = @p.last

        If @p.cursor Then Function = 1

    End Function

    '----------------------------------------------------------------------

    Function PtrListPervious(ByVal p As PtrListT Ptr) As Long

        'move cursor to previous node : true/false success

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.cursor Then @p.cursor = @p.@cursor.prev

        If @p.cursor Then Function = 1

    End Function

    '----------------------------------------------------------------------

    Function PtrListRember(ByVal p As PtrListT Ptr) As Long

        'remember cursor position : fail if cursor null : true/false success

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        @p.remember = @p.cursor

        If @p.remember Then Function = 1

    End Function

    '----------------------------------------------------------------------

    Function PtrListReturn(ByVal p As PtrListT Ptr) As Long

        'return to remembered position : fail if node deleted : true/false success

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        @p.cursor = @p.remember

        If @p.cursor Then Function = 1

    End Function

    '----------------------------------------------------------------------

    Function PtrListGet(ByVal p As PtrListT Ptr) As Long

        'get value at cursor position : null if cursor null

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.cursor Then Function = @p.@cursor.value

    End Function

    '----------------------------------------------------------------------

    Function PtrListDeleteForward(ByVal p As PtrListT Ptr) As Long

        'move to next node and delete node at cursor position : fail if cursor null : true/false success

        'cursor will be null if no next node

        Local n As PtrListNodeT Ptr

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.cursor Then

            Function = 1

            n = @p.cursor

            @p.cursor = @p.@cursor.next

            PtrListNodeDelete(p, n)

        End If

    End Function

    '----------------------------------------------------------------------

    Function PtrListDeleteBackward(ByVal p As PtrListT Ptr) As Long

        'move to previous node and delete node at cursor position : fail if cursor null : true/false success

        'cursor will be null if no previous node

        Local n As PtrListNodeT Ptr

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.cursor Then

            Function = 1

            n = @p.cursor

            @p.cursor = @p.@cursor.prev

            PtrListNodeDelete(p, n)

        End If

    End Function

    '----------------------------------------------------------------------

    Function PtrListIsBefore(ByVal p As PtrListT Ptr) As Long

        'true/false if there is a node before cursor position

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.cursor And @p.@cursor.prev Then Function = 1

    End Function

    '----------------------------------------------------------------------

    Function PtrListIsAfter(ByVal p As PtrListT Ptr) As Long

        'true/false if there is a node after cursor position

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.cursor And @p.@cursor.next Then Function = 1

    End Function

    '----------------------------------------------------------------------

    Function PtrListDeleteBefore(ByVal p As PtrListT Ptr) As Long

        'delete node before cursor position : fail if cursor null or no previous node : true/false success

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.cursor And @p.@cursor.prev Then

            PtrListNodeDelete p, @p.@cursor.prev

            Function = 1

        End If

    End Function

    '----------------------------------------------------------------------

    Function PtrListDeleteAfter(ByVal p As PtrListT Ptr) As Long

        'delete node after cursor position : fail if cursor null or no next node : true/false success

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.cursor And @p.@cursor.next Then

            PtrListNodeDelete p, @p.@cursor.next

            Function = 1

        End If

    End Function

    '----------------------------------------------------------------------

    Function PtrListPushBefore(ByVal p As PtrListT Ptr, ByVal pItem As Long) As Long

        'add value before cursor position : fail if cursor null : true/false success

        Local node As PtrListNodeT Ptr

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        ExitF(pItem = 0 Or Peek(Long, pItem) <> %PtrTag, "invalid item")

        If @p.cursor Then

            Function = 1

            If @p.cursor = @p.first Then

                PtrListPushFirst p, pItem

            Else

                ExitF(@p.@cursor.prev = 0, "previous node null")

                node = PtrNew(SizeOf(PtrListNodeT), 0, CodePtr(PtrListNodeFinalCB))

                ExitF(node = 0, "PtrNew fail")

                @node.value = pItem

                @node.next = @p.cursor

                @node.prev = @p.@cursor.prev

                @p.@cursor.@prev.next = node

                @p.@cursor.prev = node

            End If

        End If

    End Function

    '----------------------------------------------------------------------

    Function PtrListPushAfter(ByVal p As PtrListT Ptr, ByVal pItem As Long) As Long

        'add value after cursor position : fail if cursor null : true/false success

        Local node As PtrListNodeT Ptr

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        ExitF(pItem = 0 Or Peek(Long, pItem) <> %PtrTag, "invalid item")

        If @p.cursor Then

            Function = 1

            If @p.cursor = @p.last Then

                PtrListPushLast p, pItem

            Else

                ExitF(@p.@cursor.next = 0, "next node null")

                node = PtrNew(SizeOf(PtrListNodeT), 0, CodePtr(PtrListNodeFinalCB))

                ExitF(node = 0, "PtrNew fail")

                @node.value = pItem

                @node.prev = @p.cursor

                @node.next = @p.@cursor.next

                @p.@cursor.@next.prev = node

                @p.@cursor.next = node

            End If

        End If

    End Function

    '----------------------------------------------------------------------

    Function PtrListPeekBefore(ByVal p As PtrListT Ptr) As Long

        'get value before cursor position : null if cursor invalid or no previous node

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.cursor And @p.@cursor.prev Then Function = @p.@cursor.@prev.value

    End Function

    '----------------------------------------------------------------------

    Function PtrListPeekAfter(ByVal p As PtrListT Ptr) As Long

        'get value after cursor position : null if cursor invalid or no next node

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.cursor And @p.@cursor.next Then Function = @p.@cursor.@next.value

    End Function

    '----------------------------------------------------------------------

    Function PtrListPopBefore(ByVal p As PtrListT Ptr) As Long

        'get and remove value before cursor position : null if cursor invalid or no previous node

        'user responsible for freeing popped pointers

        Local h As Long

        h = PtrListPeekBefore(p)

        If h Then

            PtrIncr(h)

            Function = h

            PtrListDeleteBefore(p)

        End If

    End Function

    '----------------------------------------------------------------------

    Function PtrListPopAfter(ByVal p As PtrListT Ptr) As Long

        'get and remove value after cursor position : null if cursor invalid or no next node

        'user responsible for freeing popped pointers

        Local h As Long

        h = PtrListPeekAfter(p)

        If h Then

            PtrIncr(h)

            Function = h

            PtrListDeleteAfter(p)

        End If

    End Function

    '----------------------------------------------------------------------

    Sub PtrListPushFirst(ByVal p As PtrListT Ptr, ByVal pItem As Long)

        'insert at front

        Local node As PtrListNodeT Ptr

        ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        ExitS(pItem = 0 Or Peek(Long, pItem) <> %PtrTag, "invalid item")

        node = PtrNew(SizeOf(PtrListNodeT), 0, CodePtr(PtrListNodeFinalCB))

        ExitS(node = 0, "PtrNew fail")

        @node.value = pItem

        If @p.count Then

            ExitS(@p.first = 0, "first node null")

            @p.@first.prev = node

            @node.next = @p.first

            @p.first = node

            Incr @p.count

        Else

            @p.first = node

            @p.last = node

            @p.count = 1

        End If

    End Sub

    '----------------------------------------------------------------------

    Sub PtrListPushLast(ByVal p As PtrListT Ptr, ByVal pItem As Long)

        'append to end

        Local node As PtrListNodeT Ptr

        ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        ExitS(pItem = 0 Or Peek(Long, pItem) <> %PtrTag, "invalid item")

        node = PtrNew(SizeOf(PtrListNodeT), 0, CodePtr(PtrListNodeFinalCB))

        ExitS(node = 0, "PtrNew fail")

        @node.value = pItem

        If @p.count Then

            ExitS(@p.last = 0, "last node null")

            @p.@last.next = node

            @node.prev = @p.last

            @p.last = node

            Incr @p.count

        Else

            @p.first = node

            @p.last = node

            @p.count = 1

        End If

    End Sub

    '----------------------------------------------------------------------

    Function PtrListPeekFirst(ByVal p As PtrListT Ptr) As Long

        'get fist value : null if list empty

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.first Then Function = @p.@first.value

    End Function

    '----------------------------------------------------------------------

    Function PtrListPeekLast(ByVal p As PtrListT Ptr) As Long

        'get last value : null list empty

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.last Then Function = @p.@last.value

    End Function

    '----------------------------------------------------------------------

    Function PtrListPopFirst(ByVal p As PtrListT Ptr) As Long

        'get and remove fist value : null if list empty

        'user responsible for freeing popped pointers

        Local h As Long

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.first Then

            h = @p.@first.value

            PtrIncr(h)

            Function = h

            PtrListNodeDelete(p, @p.first)

        End If

    End Function

    '----------------------------------------------------------------------

    Function PtrListPopLast(ByVal p As PtrListT Ptr) As Long

        'get and remove last value : null if list empty

        'user responsible for freeing popped pointers

        Local h As Long

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        If @p.last Then

            h = @p.@last.value

            PtrIncr(h)

            Function = h

            PtrListNodeDelete(p, @p.last)

        End If

    End Function

    '----------------------------------------------------------------------

    Function PtrListStore(ByVal p As PtrListT Ptr, ByVal storeCB As Long) As String

        'store container to String

        'Declare Function PtrStoreCallback(ByVal p As Long) As String

        Local more, h As Long

        Local sb As StrBuildT

        Local s As String

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        ExitF(storeCB = 0, "null callback")

        If @p.count Then

            StrBuildPush sb, Mkl$(@p.count)

            more = PtrListFirst(p)

            While more

                h = PtrListGet(p)

                ExitF(h = 0, "unexpected null")

                Call Dword storeCB Using PtrStoreCallback(h) To s

                StrBuildPush sb, Mkl$(Len(s))

                StrBuildPush sb, s

                more = PtrListNext(p)

            Wend

        End If

        Function = StrBuildPop(sb)

    End Function

    '----------------------------------------------------------------------

    Sub PtrListRestore(ByVal p As PtrListT Ptr, ByRef stored As String, ByVal restoreCB As Long)

        'restore container from String

        'Declare Function PtrRestorCallback(ByRef stored As String) As Long

        Register i As Long

        Local items, bytes, h As Long

        Local s As String

        Local pl As Long Ptr

        ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        ExitS(restoreCB = 0, "null callback")

        PtrListClear p

        If Len(stored) Then

            pl = StrPtr(stored)

            items = @pl : Incr pl

            For i = 1 To items

                bytes = @pl : Incr pl

                s = Peek$(pl, bytes) : pl += bytes

                Call Dword restoreCB Using PtrRestorCallback(s) To h

                ExitS(h = 0,"null callback return")

                PtrListAdd p, h

            Next i

        End If

    End Sub

    '----------------------------------------------------------------------

    Sub PtrListFileStore(ByVal p As PtrListT Ptr, ByVal file As WString, ByVal storeCB As Long)

        'store container to File

        'Declare Function PtrStoreCallback(ByVal p As Long) As String

        ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        ExitS(storeCB = 0, "null callback")

        ExitS(Len(file) = 0, "invalid file")

        FilePut file, PtrListStore(p, storeCB)

    End Sub

    '----------------------------------------------------------------------

    Sub PtrListFileRestore(ByVal p As PtrListT Ptr, ByVal file As WString, ByVal restoreCB As Long)

        'restore container from File

        'Declare Function PtrRestorCallback(ByRef stored As String) As Long

        ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")

        ExitS(IsFalse IsFile(file), "invalid file" + file)

        PtrListRestore p, FileGet(file), restoreCB

    End Sub

    '----------------------------------------------------------------------

    'PRIVATE:

    '----------------------------------------------------------------------

    Sub PtrListNewCB(ByVal p As PtrListT Ptr) Private

        'PRIVATE: list new callback

        If p Then @p.tag = %PtrListTag

    End Sub

    '----------------------------------------------------------------------

    Sub PtrListNodeFinalCB(ByVal node As PtrListNodeT Ptr)

        If node Then

            PtrFree(@node.value)

        End If

    End Sub

    '----------------------------------------------------------------------

    Sub PtrListNodeDelete(ByVal p As PtrListT Ptr, ByVal node As PtrListNodeT Ptr) Private

        'PRIVATE: remove node from list

        If node Then

            If @p.cursor = node Then @p.cursor = 0

            If @p.remember = node Then @p.remember = 0

            If @p.first = node Then @p.first = @node.next

            If @p.last = node Then @p.last = @node.prev

            If @node.prev Then @node.@prev.next = @node.next

            If @node.next Then @node.@next.prev = @node.prev

            ExitS(@p.count = 0, "invalid count")

            Decr @p.count

            PtrFree(node)

        End If

    End Sub

    '----------------------------------------------------------------------

#EndIf '%PtrList250812

#If Not %Def(%Str250724)

    %Str250724 = 1

    '----------------------------------------------------------------------

    'Dynamic String Container

    '----------------------------------------------------------------------

    Declare Function StrCompareCallback(ByVal a As Long, ByVal b As Long) As Long

        'a < b : return < 0    a = b : return = 0    a > b : return > 0

    '----------------------------------------------------------------------

    %BytSize = 1

    %StrTag = 653170298

    Type StrT

        allocator As PtrT

        tag As Long

        mem As Byte Ptr

        count As Long

    End Type

    '----------------------------------------------------------------------

    Function StrNew() As Long

        'allocate new instance : return container pointer : call PtrFree(p) to free pointer

        Function = PtrNew(SizeOf(StrT), CodePtr(StrNewCB), CodePtr(StrClear))

    End Function

    '----------------------------------------------------------------------

    Sub StrClear(ByVal p As StrT Ptr)

        'empty container

        ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %StrTag, "invalid ptr")

        @p.mem = MemFree(@p.mem)

        @p.count = 0

    End Sub

    '----------------------------------------------------------------------

    Function StrGet(ByVal p As StrT Ptr) As String

        'get value

        ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %StrTag, "invalid ptr")

        Function = Peek$(@p.mem, @p.count)

    End Function

    '----------------------------------------------------------------------

    Sub StrSet(ByVal p As StrT Ptr, ByRef value As String)

        Local strlen As Long : strlen = Len(value)

        Local bytes As Long : bytes = strlen * %BytSize

        ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %StrTag, "invalid ptr")

        @p.mem = MemFree(@p.mem) : @p.count = 0

        If strlen Then

            @p.mem = MemAlloc(bytes)

            If @p.mem Then

                @p.count = strlen

                Memory Copy StrPtr(value), @p.mem, bytes

            End If

        End If

    End Sub

    '----------------------------------------------------------------------

    Function StrNewValue(ByRef value As String) As Long

        'allocate new instance : store value : return pointer

        Local h As Long

        h = StrNew()

        StrSet h, value

        Function = h

    End Function

    '----------------------------------------------------------------------

    Function StrHashIndex(ByVal p As StrT Ptr, ByVal capacity As Long) As Long

        'get key's one-based hash index position

        Register i As Long : Local total, temp As Long

        Function = 1

        If p Then

            For i = 0 To @p.count - 1

                temp += @p.@mem[i] + total

                Shift Left total, 8

                total += temp

            Next i

            Function = Abs(total Mod capacity) + 1

        End If

    End Function

    '----------------------------------------------------------------------

    Function StrEqual(ByVal a As StrT Ptr, ByVal b As StrT Ptr) As Long

        'true/false if two strings equal

        Register i As Long

        If a And b And @a.count = @b.count Then

            For i = 0 To @a.count - 1

                If @a.@mem[i] <> @b.@mem[i] Then Exit Function

            Next i

            Function = 1

        End If

    End Function

    '----------------------------------------------------------------------

    Function StrCompare(ByVal a As StrT Ptr, ByVal b As StrT Ptr) As Long

        'compare callback : case sensitive

        Register i As Long : Register compare As Long

        If a And b Then

            For i = 0 To Min&(@a.count, @b.count) - 1

                compare = @a.@mem[i] - @b.@mem[i]

                If compare Then

                    Function = compare : Exit Function

                End If

            Next i

            Function = @a.count - @b.count

        End If

    End Function

    '----------------------------------------------------------------------

    Function StrCompareIgnore(ByVal a As StrT Ptr, ByVal b As StrT Ptr) As Long

        'compare callback : case sensitive

        Register i As Long : Register compare As Long : Local la, lb As Long

        If a And b Then

            For i = 0 To Min&(@a.count, @b.count) - 1

                la = @a.@mem[i] : lb = @b.@mem[i]

                If la > 64 And la < 91 Then la += 32

                If lb > 64 And lb < 91 Then lb += 32

                compare = la - lb

                If compare Then

                    Function = compare : Exit Function

                End If

            Next i

            Function = @a.count - @b.count

        End If

    End Function

    '----------------------------------------------------------------------

    Function StrStoreCB(ByVal p As StrT Ptr) As String

        'store callback

        Function = ChrToUtf8$(StrGet(p))

    End Function

    '----------------------------------------------------------------------

    Function StrRestoreCB(ByRef value As String) As Long

        'restore callback

        Function = StrNewValue(Utf8ToChr$(value))

    End Function

    '----------------------------------------------------------------------

    'PRIVATE:

    '----------------------------------------------------------------------

    Sub StrNewCB(ByVal p As StrT Ptr) Private

        'PRIVATE: new callback

        If p Then @p.tag = %StrTag

    End Sub

    '----------------------------------------------------------------------

#EndIf '%Str250724

#If Not %Def(%StrList250812)

    %StrList250812 = 1

    '----------------------------------------------------------------------

    'String Doubly Linked List : Stack : Queue : Deque

    '----------------------------------------------------------------------

    Macro StrListT = PtrListT

    '----------------------------------------------------------------------

    Function StrListNew() As Long

        'allocate new instance : return container pointer : call PtrFree(p) to free pointer

        Function = PtrListNew()

    End Function

    '----------------------------------------------------------------------

    Sub StrListClear(ByVal p As StrListT Ptr)

        'empty container

        PtrListClear p

    End Sub

    '----------------------------------------------------------------------

    Function StrListCount(ByVal p As StrListT Ptr) As Long

        'get item count

        Function = PtrListCount(p)

    End Function

    '----------------------------------------------------------------------

    Sub StrListAdd(ByVal p As StrListT Ptr, ByRef value As String)

        'append value

        PtrListAdd p, StrNewValue(value)

    End Sub

    '----------------------------------------------------------------------

    Function StrListCursor(ByVal p As StrListT Ptr) As Long

        'true/false if cursor valid

        Function = PtrListCursor(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListFirst(ByVal p As StrListT Ptr) As Long

        'move cursor to first node : true/false success

        Function = PtrListFirst(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListNext(ByVal p As StrListT Ptr) As Long

        'move cursor to next node : true/false success

        Function = PtrListNext(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListLast(ByVal p As StrListT Ptr) As Long

        'move cursor to last node : true/false success

        Function = PtrListLast(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListPervious(ByVal p As StrListT Ptr) As Long

        'move cursor to previous node : true/false success

        Function = PtrListPervious(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListRember(ByVal p As StrListT Ptr) As Long

        'remember cursor position : fail if cursor null : true/false success

        Function = PtrListRember(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListReturn(ByVal p As StrListT Ptr) As Long

        'return to remembered position : fail if node deleted : true/false success

        Function = PtrListReturn(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListGet(ByVal p As StrListT Ptr) As String

        'get value at cursor position : null if cursor null

        Local h As Long

        h = PtrListGet(p)

        If h Then Function = StrGet(h)

    End Function

    '----------------------------------------------------------------------

    Function StrListSet(ByVal p As StrListT Ptr, ByRef value As String) As Long

        'set value at cursor position : fail if cursor null : true/false success

        Local h As Long

        h = PtrListGet(p)

        If h Then

            StrSet h, value

            Function = 1

        End If

    End Function

    '----------------------------------------------------------------------

    Function StrListDeleteForward(ByVal p As StrListT Ptr) As Long

        'move to next node and delete node at cursor position : fail if cursor null : true/false success

        'cursor will be null if no next node

        Function = PtrListDeleteForward(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListDeleteBackward(ByVal p As StrListT Ptr) As Long

        'move to previous node and delete node at cursor position : fail if cursor null : true/false success

        'cursor will be null if no previous node

        Function = PtrListDeleteBackward(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListIsBefore(ByVal p As StrListT Ptr) As Long

        'true/false if there is a node before cursor position

        Function = PtrListIsBefore(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListIsAfter(ByVal p As StrListT Ptr) As Long

        'true/false if there is a node after cursor position

        Function = PtrListIsAfter(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListDeleteBefore(ByVal p As StrListT Ptr) As Long

        'delete node before cursor position : fail if cursor null or no previous node : true/false success

        Function = PtrListDeleteBefore(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListDeleteAfter(ByVal p As StrListT Ptr) As Long

        'delete node after cursor position : fail if cursor null or no next node : true/false success

        Function = PtrListDeleteAfter(p)

    End Function

    '----------------------------------------------------------------------

    Function StrListPushBefore(ByVal p As StrListT Ptr, ByRef value As String) As Long

        'add value before cursor position : fail if cursor null : true/false success

        Local h As Long : h = StrNewValue(value)

        If IsFalse PtrListPushBefore(p, h) Then PtrFree(h)

    End Function

    '----------------------------------------------------------------------

    Function StrListPushAfter(ByVal p As StrListT Ptr, ByRef value As String) As Long

        'add value after cursor position : fail if cursor null : true/false success

        'add value before cursor position : fail if cursor null : true/false success

        Local h As Long : h = StrNewValue(value)

        If IsFalse PtrListPushAfter(p, h) Then PtrFree(h)

    End Function

    '----------------------------------------------------------------------

    Function StrListPeekBefore(ByVal p As StrListT Ptr) As String

        'get value before cursor position : null if cursor invalid or no previous node

        Local h As Long : h = PtrListPeekBefore(p)

        If h Then Function = StrGet(h)

    End Function

    '----------------------------------------------------------------------

    Function StrListPeekAfter(ByVal p As StrListT Ptr) As String

        'get value after cursor position : null if cursor invalid or no next node

        Local h As Long : h = PtrListPeekAfter(p)

        If h Then Function = StrGet(h)

    End Function

    '----------------------------------------------------------------------

    Function StrListPopBefore(ByVal p As StrListT Ptr) As String

        'get and remove value before cursor position : null if cursor invalid or no previous node

        Local h As Long : h = PtrListPopBefore(p)

        If h Then

            Function = StrGet(h)

            PtrFree(h)

        End If

    End Function

    '----------------------------------------------------------------------

    Function StrListPopAfter(ByVal p As StrListT Ptr) As String

        'get and remove value after cursor position : null if cursor invalid or no next node

        Local h As Long : h = PtrListPopAfter(p)

        If h Then

            Function = StrGet(h)

            PtrFree(h)

        End If

    End Function

    '----------------------------------------------------------------------

    Sub StrListPushFirst(ByVal p As StrListT Ptr, ByRef value As String)

        'insert at front

        PtrListPushFirst p, StrNewValue(value)

    End Sub

    '----------------------------------------------------------------------

    Sub StrListPushLast(ByVal p As StrListT Ptr, ByRef value As String)

        'append to end

        PtrListPushLast p, StrNewValue(value)

    End Sub

    '----------------------------------------------------------------------

    Function StrListPeekFirst(ByVal p As StrListT Ptr) As String

        'get fist value : null if list empty

        Local h As Long : h = PtrListPeekFirst(p)

        If h Then Function = StrGet(h)

    End Function

    '----------------------------------------------------------------------

    Function StrListPeekLast(ByVal p As StrListT Ptr) As String

        'get last value : null list empty

        Local h As Long : h = PtrListPeekLast(p)

        If h Then Function = StrGet(h)

    End Function

    '----------------------------------------------------------------------

    Function StrListPopFirst(ByVal p As StrListT Ptr) As String

        'get and remove fist value : null if list empty

        Local h As Long : h = PtrListPopFirst(p)

        If h Then

            Function = StrGet(h)

            PtrFree(h)

        End If

    End Function

    '----------------------------------------------------------------------

    Function StrListPopLast(ByVal p As StrListT Ptr) As String

        'get and remove last value : null if list empty

        Local h As Long : h = PtrListPopLast(p)

        If h Then

            Function = StrGet(h)

            PtrFree(h)

        End If

    End Function

    '----------------------------------------------------------------------

    Sub StrListImport(ByVal p As StrListT Ptr, a() As String)

        'import PB array

        Register i As Long

        StrListClear p

        For i = LBound(a) To UBound(a)

            StrListAdd p, a(i)

        Next i

    End Sub

    '----------------------------------------------------------------------

    Sub StrListExport(ByVal p As StrListT Ptr, a() As String)

        'export to PB array

        Register i As Long

        Local more As Long

        Erase a()

        If StrListCount(p) Then

            ReDim a(1 To StrListCount(p))

            more = StrListFirst(p)

            While more

                Incr i

                a(i) = StrListGet(p)

                more = StrListNext(p)

            Wend

        End If

    End Sub

    '----------------------------------------------------------------------

    Sub StrListSplit(ByVal p As StrListT Ptr, ByVal delimited As String, ByVal delimiter As String)

        'split array on delimited string

        Local items As Long

        Local a() As String

        StrListClear p

        If Len(delimited) Then

            items = ParseCount(delimited, delimiter)

            If items Then

                Dim a(1 To items)

                Parse delimited, a(), delimiter

                StrListImport p, a()

            End If

        End If

    End Sub

    '----------------------------------------------------------------------

    Function StrListJoin(ByVal p As StrListT Ptr, ByVal delimiter As String) As String

        'join array on delimiter

        Local a() As String

        StrListExport p, a()

        Function = Join$(a(), delimiter)

    End Function

    '----------------------------------------------------------------------

    Sub StrListToText(ByVal p As StrListT Ptr, ByVal file As WString)

        'store list as text file

        If StrListCount(p) Then

            FilePut file, RTrim$(StrListJoin(p, $CrLf))  + $CrLf

        End If

    End Sub

    '----------------------------------------------------------------------

    Sub StrListFromText(ByVal p As StrListT Ptr, ByVal file As WString)

        'load text file

        Local contents As String

        StrListClear p

        contents = FileGet(file)

        contents = Trim$(contents, $CrLf)

        If Len(contents) Then

            StrListSplit p, contents, $CrLf

        End If

    End Sub

    '----------------------------------------------------------------------

    Sub StrListFolders(ByVal p As StrListT Ptr, ByVal rootFolder As String)

        'get all folders in root folder

        Local folder, folderMask, rootPath As String

        Local DrD As DirData

        StrListClear p

        ExitS(IsFalse IsFolder(rootFolder), "invalid folder")

        rootPath = RTrim$(rootFolder, "\") + "\"

        folderMask = rootPath

        folder = Dir$(folderMask, Only %SubDir To DrD)

        While Len(folder)

            StrListAdd p, rootPath + folder

            folder = Dir$

        Wend

    End Sub

    '----------------------------------------------------------------------

    Sub StrListFiles(ByVal p As StrListT Ptr, ByVal folder As String, ByVal mask As String)

        'get all files in folder matching mask

        Local file, fileMask As String

        StrListClear p

        ExitS(IsFalse IsFolder(folder), "invalid folder")

        folder = RTrim$(folder, "\") + "\"

        fileMask = folder + mask

        file = Dir$(fileMask)

        While Len(file)

            StrListAdd p, folder + file

            file = Dir$

        Wend

    End Sub

    '----------------------------------------------------------------------

    Sub StrListAllFolders(ByVal p As StrListT Ptr, ByVal rootFolder As String)

        'get all folders in root folder and sub-folders, including root folder

        Local folderStack As Long : folderStack = StrListNew()

        Local subFolderStack As Long : subFolderStack = StrListNew()

        Local currentFolder As String

        StrListClear p

        ExitS(IsFalse IsFolder(rootFolder), "invalid folder")

        StrListPushLast folderStack, rootFolder

        While StrListCount(folderStack)

            currentFolder = StrListPopLast(folderStack)

            StrListAdd p, currentFolder

            StrListFolders subFolderStack, currentFolder

            While StrListCount(subFolderStack)

                StrListPushLast folderStack, StrListPopLast(subFolderStack)

            Wend

        Wend

        folderStack = PtrFree(folderStack)

        subFolderStack = PtrFree(subFolderStack)

    End Sub

    '----------------------------------------------------------------------

    Sub StrListAllFiles(ByVal p As StrListT Ptr, ByVal rootFolder As String, ByVal mask As String)

        'get all files in root folder, and sub-folders, matching mask

        Local allFolderStack As Long : allFolderStack = StrListNew()

        Local folderFileStack As Long : folderFileStack = StrListNew()

        StrListClear p

        ExitS(IsFalse IsFolder(rootFolder), "invalid folder")

        StrListAllFolders allFolderStack, rootFolder

        While StrListCount(allFolderStack)

            StrListFiles folderFileStack, StrListPopLast(allFolderStack), mask

            While StrListCount(folderFileStack)

                StrListAdd p, StrListPopLast(folderFileStack)

            Wend

        Wend

        allFolderStack = PtrFree(allFolderStack)

        folderFileStack = PtrFree(folderFileStack)

    End Sub

    '----------------------------------------------------------------------

    Function StrListStore(ByVal p As StrListT Ptr) As String

        'store container to String

        Function = PtrListStore(p, CodePtr(StrStoreCB))

    End Function

    '----------------------------------------------------------------------

    Sub StrListRestore(ByVal p As StrListT Ptr, ByRef stored As String)

        'restore container from String

        PtrListRestore p, stored, CodePtr(StrRestoreCB)

    End Sub

    '----------------------------------------------------------------------

    Sub StrListFileStore(ByVal p As StrListT Ptr, ByVal file As WString)

        'store container to File

        PtrListFileStore p, file, CodePtr(StrStoreCB)

    End Sub

    '----------------------------------------------------------------------

    Sub StrListFileRestore(ByVal p As StrListT Ptr, ByVal file As WString)

        'restore container from File

        PtrListFileRestore p, file, CodePtr(StrRestoreCB)

    End Sub

    '----------------------------------------------------------------------

#EndIf '%StrList250812

Very Simple Round Gauge 0-100%

Wed, 24 Sep 2025 16:01:40 +0000

I needed a very simple round gauge for one of our in-house measuring dashboards. I didn't use any double buffer or GDI+ as it is only intended to be a static needle most of the time.

This one demo's percentage, but you can modify it to whatever; volts, amps, watts, temp, cats, dogs.

  round guage.jpg (Size: 43.71 KB / Downloads: 22)

Code:
'

' Very simple round gauge, 0-100%

' Jules Marchildon, Sept. 24, 2025

'

#COMPILE EXE

#DIM ALL

#INCLUDE "WIN32API.INC"

GLOBAL gValue AS LONG

GLOBAL ghDlg AS DWORD

'--------------------------------------------------------------------------------------------------

'

'--------------------------------------------------------------------------------------------------

FUNCTION PBMAIN()

    DIALOG NEW 0, "Round Gauge: 0-100%",,, 200, 200, %WS_SYSMENU TO ghDlg

    DIALOG SHOW MODAL ghDlg CALL DlgProc

END FUNCTION

'--------------------------------------------------------------------------------------------------

'

'--------------------------------------------------------------------------------------------------

CALLBACK FUNCTION DlgProc()

    LOCAL ps AS PAINTSTRUCT

    LOCAL hDC, hMemDC, hBitmap, hOldBitmap AS DWORD

    LOCAL hGauge AS DWORD

    LOCAL rc AS RECT

    LOCAL cx AS LONG, cy AS LONG, radius AS LONG

    SELECT CASE CB.MSG

        CASE %WM_INITDIALOG

            '-simulate gauge updates with a timer

            SetTimer CB.HNDL, 1, 300, BYVAL %NULL

        CASE %WM_TIMER

            gValue = (gValue + 1) MOD 101

            InvalidateRect CB.HNDL, BYVAL %NULL, %TRUE

        CASE %WM_PAINT

            hDC = BeginPaint(CB.HNDL, ps)

                GetClientRect(CB.HNDL, rc)

                hMemDC = CreateCompatibleDC(hDC)

                hBitmap = CreateCompatibleBitmap(hDC, rc.nRight, rc.nBottom)

                hOldBitmap = SelectObject(hMemDC, hBitmap)

                FillRect hMemDC, rc, GetSysColorBrush(%COLOR_BTNFACE)

                '-calc center and radius

                cx = (rc.nRight - rc.nLeft) \ 2

                cy = (rc.nBottom - rc.nTop) \ 2

                radius = MIN(cx, cy) - 10

                DrawGauge(hMemDC, cx, cy, radius, gValue)

                BitBlt hDC, 0, 0, rc.nRight, rc.nBottom, hMemDC, 0, 0, %SRCCOPY

                SelectObject hMemDC, hOldBitmap

                DeleteObject hBitmap

                DeleteDC hMemDC

            EndPaint(CB.HNDL, ps)

        CASE %WM_DESTROY

            KillTimer CB.HNDL, 1

            PostQuitMessage 0

    END SELECT

END FUNCTION

'--------------------------------------------------------------------------------------------------

'

'--------------------------------------------------------------------------------------------------

SUB DrawGauge(hDC AS DWORD, cx AS LONG, cy AS LONG, radius AS LONG, value AS LONG)

    LOCAL angle, rad, offsetRad, aDeg, percent, needleWidth AS SINGLE

    LOCAL hPen, hOldPen, hFont, hOldFont, hBrush, hOldBrush AS DWORD

    LOCAL i, x1, y1, x2, y2, xTip, yTip, r, g, b AS LONG

    LOCAL xBase1, yBase1, xBase2, yBase2 AS LONG

    LOCAL sVal AS STRING, lsize AS SIZE, cherryPi AS EXT

    cherryPi = 4*ATN(1)

    '=== Arc background with green-yellow-red segments ===

    FOR aDeg = 225 TO -45 STEP -1

        rad = aDeg * cherryPi / 180

        x1 = cx + radius * 0.85 * COS(rad)

        y1 = cy - radius * 0.85 * SIN(rad)

        x2 = cx + radius * 0.95 * COS(rad)

        y2 = cy - radius * 0.95 * SIN(rad)

        '-calc perc% across arc 0 to 1

        percent = (225 - aDeg) / 270

        '-interpolate color

        IF percent <= 0.25 THEN

            '-green to Yellow

            r = percent / 0.25 * 255

            g = 255

            b = 0

        ELSEIF percent <= 0.75 THEN

            '-yellow to Red

            r = 255

            g = 255 - ((percent - 0.25) / 0.5 * 255)

            b = 0

        ELSE

            '-solid Red

            r = 255

            g = 0

            b = 0

        END IF

        hPen = CreatePen(%PS_SOLID, 1, RGB(r, g, b))

        hOldPen = SelectObject(hDC, hPen)

        MoveToEx hDC, x1, y1, BYVAL %NULL

        LineTo hDC, x2, y2

        SelectObject hDC, hOldPen

        DeleteObject hPen

    NEXT

    #IF 1 '=== Optional chintzy bezel ring ===

        hPen = CreatePen(%PS_SOLID, 4, RGB(190, 190, 190))

        hOldPen = SelectObject(hDC, hPen)

        LOCAL ltweak AS LONG

        ltweak = 1 '-tweak gap to your own taste

        ARC hDC, cx - radius - ltweak, cy - radius - ltweak, cx + radius + ltweak, cy + radius + ltweak, 0, 0, 0, 0

        SelectObject hDC, hOldPen

        DeleteObject hPen

    #ENDIF

    '=== tick marks and labels every 5 units ===

    FOR i = 0 TO 100 STEP 5

        angle = (225 - (i * 2.7!)) * cherryPi / 180

        '-major tick length for labels every 10 units, short for 5 units

        IF (i MOD 10) = 0 THEN

            x1 = cx + radius * 0.80 * COS(angle)

            y1 = cy - radius * 0.80 * SIN(angle)

        ELSE

            x1 = cx + radius * 0.84 * COS(angle)

            y1 = cy - radius * 0.84 * SIN(angle)

        END IF

        x2 = cx + radius * 0.92 * COS(angle)

        y2 = cy - radius * 0.92 * SIN(angle)

        MoveToEx hDC, x1, y1, BYVAL %NULL

        LineTo hDC, x2, y2

        '-label every 10 units only

        IF (i MOD 10) = 0 THEN

            LOCAL sText AS STRING

            sText = FORMAT$(i)

            SetBkMode hDC, %TRANSPARENT

            SetTextColor hDC, RGB(40, 140, 240)

            LOCAL tx AS LONG, ty AS LONG

            tx = cx + radius * 0.65 * COS(angle) - 10

            ty = cy - radius * 0.65 * SIN(angle) - 8

            TextOut hDC, tx, ty, BYVAL STRPTR(sText), LEN(sText)

        END IF

    NEXT

    '=== draw polygon needle ===

    angle = (225 - (gValue * 2.7!))  '<-map gValue (0-100) to 225 to -45

    rad = angle * cherryPi / 180

    '-tip of the needle

    xTip = cx + radius * 0.75 * COS(rad)

    yTip = cy - radius * 0.75 * SIN(rad)

    '-base width and angle offset for polygon

    needleWidth = 6.0  '<-adjust width here

    offsetRad = 90 * cherryPi / 180  '-perpendicular

    '-two base corners *perpendicular to needle angle

    xBase1 = cx + needleWidth * COS(rad + offsetRad)

    yBase1 = cy - needleWidth * SIN(rad + offsetRad)

    xBase2 = cx + needleWidth * COS(rad - offsetRad)

    yBase2 = cy - needleWidth * SIN(rad - offsetRad)

    '-define needle polygon points

    DIM pts(0 TO 2) AS POINTAPI

    pts(0).x = xTip : pts(0).y = yTip

    pts(1).x = xBase1 : pts(1).y = yBase1

    pts(2).x = xBase2 : pts(2).y = yBase2

    '-draw needle

    hBrush = CreateSolidBrush(RGB(255, 0, 0))    '-fill color

    hOldBrush = SelectObject(hDC, hBrush)

    hPen = CreatePen(%PS_SOLID, 1, RGB(0, 0, 0)) '-outline

    hOldPen = SelectObject(hDC, hPen)

    POLYGON hDC, pts(0), 3

    SelectObject hDC, hOldBrush

    DeleteObject hBrush

    SelectObject hDC, hOldPen

    DeleteObject hPen

    '-center cap

    ELLIPSE hDC, cx - 8, cy - 8, cx + 8, cy + 8

    '=== digital value display in the center ===

    sVal = FORMAT$(value) + "%"

    hFont = CreateFont(28, 0, 0, 0, %FW_BOLD, 0, 0, 0, _

                %ANSI_CHARSET, %OUT_DEFAULT_PRECIS, %CLIP_DEFAULT_PRECIS, _

                %DEFAULT_QUALITY, %DEFAULT_PITCH OR %FF_DONTCARE, "Segoe UI")

    hOldFont = SelectObject(hDC, hFont)

    SetBkMode hDC, %TRANSPARENT

    SetTextColor hDC, RGB(0, 102, 204)

    '-measure text size to center it

    GetTextExtentPoint32 hDC, BYVAL STRPTR(sVal), LEN(sVal), lsize

    TextOut hDC, cx - lsize.cx \ 2, cy - lsize.cy \ 2 +60, BYVAL STRPTR(sVal), LEN(sVal)

    SelectObject hDC, hOldFont

    DeleteObject hFont

END SUB

gbScroller - Scroll Image

Tue, 23 Sep 2025 04:04:43 +0000

gbScroller is the companion app to gbClientCapture. Both are intended to support viewing of sheet music in a horizontal format.

gbClientCapture captures multiple images from a music sheet and merges them into a single horizontal image.

gbScroller displays the merged image, scrolling it to the left.

Both are discussed in the same thread. http://pump.richheimer.de/showthread.php...562#pid562

Features:
1. Zoom the merged image
2. Scroll the merged image, with speed control
3. Display a vertical line between individual images

Files for both gbClientCapture and gbScroller are in the zip https://garybeene.com/files/gbclientcapture.zip

Code:
'Compilable Example: Jose Includes

#Compile Exe  "gbscroller.exe"

#Dim All

#Debug Error On

#Debug Display On

%Unicode = 1

#Include "WIN32API.INC"

#Include "cgdiplus.inc" '<-replace with Jose or you own GDI+ include file.

Enum Equates Singular

   IDC_Toolbar   = 500

   IDC_Graphic

   IDT_Exit

   IDT_Faster

   IDT_Slower

   IDT_View

   IDT_ShowLine

   IDT_Scroll

   IDC_StatusBar

   IDT_ResetZoom

   IDT_ResetScroll

   IDC_Up

   IDC_Down

   IDT_StopScroll

   IDT_Plus

   IDT_Minus

   ID_Timer

End Enum

#Resource Manifest, 1,      "icons\xptheme_dpiaware.xml"

#Resource Icon logo, "icons\scroll2.ico"

#Resource Icon zexit, "icons\power.ico"

#Resource Icon zview, "icons\view.ico"

#Resource Icon zleft, "icons\scrollleft.ico"

#Resource Icon zright, "icons\scrollright.ico"

#Resource Icon zstop, "icons\stop.ico"

#Resource Icon zplus, "icons\plus.ico"

#Resource Icon zminus, "icons\minus.ico"

#Resource Icon zreset, "icons\reset.ico"

$Ver = "1.1"

Global hDlg, hToolbar, hList, hFont As Dword

Global Scroll, ShowLine, TimerInterval, ImageWidth, ImageHeight,XDelta As Long

Global SBW, SBH, TBW, TBH As Long, Zoom As Single

Function PBMain() As Long

   Dialog New Pixels, 0, "gbScroller v" + $Ver,,,100,100, %WS_OverlappedWindow To hDlg

   Dialog Set Icon hDlg, "logo"

   Font New "Tahoma",10, 0 To hFont

   CreateImageList

   CreateToolbar

   CreateStatusBar

   Dialog Show Modal hDlg, Call DlgMain

End Function

CallBack Function DlgMain()

   Local iReturn As Long

   Select Case As Long Cb.Msg

      Case %WM_InitDialog

         BuildAcceleratorTable

         settings_ini "get"

         GetImageSize

         CreateGraphic

         Statusbar Set Text hDlg, %IDC_StatusBar, 1, 0, "gbScroller v" + $Ver + "       Zoom = " + Str$(Zoom) + "       Timer Interval = " + Str$(TimerInterval)

      Case %WM_Size : ResizeDialog

      Case %WM_Timer : ScrollImage : SetStatusBar

      Case %WM_Help

      Case %WM_Command

         Select Case Cb.Ctl

            Case %IdCancel        : sBeep : Dialog End hDlg

            Case %IDT_Exit        : sBeep : Dialog End hDlg

            Case %IDT_Scroll      : sBeep : ManageScroll : CreateToolbar

            Case %IDT_StopScroll  : sBeep : ManageScroll : CreateToolbar

            Case %IDT_Faster      : sBeep : ChangeSpeed(-1) : CreateToolbar

            Case %IDT_Slower      : sBeep : ChangeSpeed(+1) : CreateToolbar

            Case %IDT_Plus        : sBeep : Magnify(+1)

            Case %IDT_Minus       : sBeep : Magnify(-1)

            Case %IDT_ResetZoom   : sBeep : Magnify(0)

            Case %IDT_ResetScroll : sBeep : ResetScroll

            Case %IDT_ShowLine    : sBeep : ShowLine Xor=1 : DrawLines(IIf(ShowLine,%Red,-2)) : Graphic ReDraw

            Case %IDT_View        : sBeep : iReturn = ShellExecute(hDlg, "Open", "merge.bmp", $Nul, $Nul, %SW_ShowNormal)

         End Select

      Case %WM_Destroy

         settings_ini "save"

   End Select

End Function

Sub CreateStatusBar

   Control Add Statusbar, hDlg, %IDC_StatusBar, "Welcome to gbScroller v" + $Ver, 0,0,0,0, %CCS_Bottom Or %SBars_SizeGrip

   Control Get Size hDlg, %IDC_StatusBar To SBW, SBH

   Control Set Font hDlg, %IDC_StatusBar, hFont

End Sub

Sub CreateGraphic

   Local w,h As Long

   Dialog Get Client hDlg To w,h

   Control Add Graphic, hDlg, %IDC_Graphic, "", 10, TBH, w-20,h, %WS_Border

   Graphic Attach hDlg, %IDC_Graphic, ReDraw

   Graphic Set Virtual ImageWidth, ImageHeight

   Graphic Color %Black, %White

   Graphic Clear

End Sub

Sub CreateImageList

   ImageList New Icon 48,48,32,20 To hList

   ImageList Add Icon hList, "zexit"   '1

   ImageList Add Icon hList, "zleft"   '2

   ImageList Add Icon hList, "zright"  '3

   ImageList Add Icon hList, "zstop"  '4

   ImageList Add Icon hList, "zplus"  '5

   ImageList Add Icon hList, "zminus"  '6

   ImageList Add Icon hList, "zreset"  '7

   ImageList Add Icon hList, "zview"  '8

End Sub

Sub CreateToolbar

   Control Kill hDlg, %IDC_Toolbar

   Control Add Toolbar, hDlg, %IDC_Toolbar, "", 0,0,0,0 , %TbStyle_Flat Or %CCS_NoDivider

   Control Handle hDlg, %IDC_Toolbar To hToolbar

   Toolbar Set ImageList hDlg, %IDC_Toolbar, hList, 0

   Toolbar Add Button hDlg, %IDC_Toolbar, 1, %IDT_Exit, %TbStyle_Button, " Exit "

   Toolbar Add Separator hDlg, %IDC_Toolbar, 50

   Toolbar Add Button hDlg, %IDC_Toolbar, 5, %IDT_Plus, %TbStyle_Button, " ZoomIn "

   Toolbar Add Button hDlg, %IDC_Toolbar, 6, %IDT_Minus, %TbStyle_Button, " ZoomOut "

   Toolbar Add Button hDlg, %IDC_Toolbar, 7, %IDT_ResetZoom, %TbStyle_Button, " Reset "

   Toolbar Add Separator hDlg, %IDC_Toolbar, 50

   If Scroll = 0 Then Toolbar Add Button hDlg, %IDC_Toolbar, 8, %IDT_Scroll, %TbStyle_Button, " Scroll "

   If Scroll = 1 Then Toolbar Add Button hDlg, %IDC_Toolbar, 4, %IDT_StopScroll, %TbStyle_Button, " Stop "

   Toolbar Add Button hDlg, %IDC_Toolbar, 2, %IDT_Slower, %TbStyle_Button, " Slower "

   Toolbar Add Button hDlg, %IDC_Toolbar, 3, %IDT_Faster, %TbStyle_Button, " Faster "

   Toolbar Add Button hDlg, %IDC_Toolbar, 7, %IDT_ResetScroll, %TbStyle_Button, " Reset "

   Control Set Font hDlg, %IDC_StatusBar, hToolbar

   Control Get Size hDlg, %IDC_Toolbar To TBW, TBH

End Sub

Sub Settings_INI(Task$)

   Local x,y,w,h, tempz, INIFileName As WStringZ * %Max_Path, WinPla As WindowPlacement

   'set ini filename

   INIFileName = Exe.Path$ + Exe.Name$ + ".ini"    'get INI file name

   Select Case Task$

      Case "get"

         'get dialog width/height from INI file and use to set Dialog size

         GetPrivateProfileString "All", "Width", "1200", w, %Max_Path, INIFileName

         GetPrivateProfileString "All", "Height", "300", h, %Max_Path, INIFileName

         Dialog Set Size hDlg,Val(w), Val(h)   'width/height

         'get dialog top/left from INI file and use to set Dialog location

         Getprivateprofilestring "All", "Left", "0", x, %Max_Path, INIFileName

         Getprivateprofilestring "All", "Top", "0",  y,  %Max_Path, INIFileName

         If IsFile(INIFileName) Then Dialog Set Loc hDlg, Val(x), Val(y)   'left/top but only once INIFileName exists

         'get value for string variables

'         GetPrivateProfileString "All", "FontName", "Arial Black", FontName, %Max_Path, INIFileName

         'get value for numeric variables

         Getprivateprofilestring "All", "ImageWidth", "",        tempz, %Max_Path, INIFileName   : ImageWidth = Val(tempz)

         Getprivateprofilestring "All", "ImageHeight", "",       tempz, %Max_Path, INIFileName   : ImageHeight = Val(tempz)

         Getprivateprofilestring "All", "TimerIntereval", "50", tempz, %Max_Path, INIFileName   : TimerInterval = Val(tempz)

         Getprivateprofilestring "All", "Zoom", "1",             tempz, %Max_Path, INIFileName   : Zoom = Val(tempz)

         Getprivateprofilestring "All", "XDelta", "2",           tempz, %Max_Path, INIFileName   : XDelta = Val(tempz)

         Getprivateprofilestring "All", "ShowLine", "1",         tempz, %Max_Path, INIFileName   : ShowLine = Val(tempz)

      Case "save"

         If IsFile(INIFileName) Then Kill INIFileName    'clear the INI file Name to remove residual entries before saving

         WinPla.Length = SizeOf(WinPla)

         GetWindowPlacement hDlg, WinPla

         WritePrivateProfileString "All", "Left",   Str$(WinPla.rcNormalPosition.nLeft), INIFileName

         WritePrivateProfileString "All", "Top",    Str$(WinPla.rcNormalPosition.nTop), INIFileName

         WritePrivateProfileString "All", "Width",  Str$(WinPla.rcNormalPosition.nRight - WinPla.rcNormalPosition.nLeft), INIFileName

         WritePrivateProfileString "All", "Height", Str$(WinPla.rcNormalPosition.nBottom - WinPla.rcNormalPosition.nTop), INIFileName

         'save string variables

'         WritePrivateProfileString "All", "FontName",   FontName, INIFileName

         'save numeric variables

         WritePrivateProfileString "All", "ImageHeight",    Str$(ImageHeight), INIFileName

         WritePrivateProfileString "All", "ImageWidth",     Str$(ImageWidth), INIFileName

         WritePrivateProfileString "All", "TimerInterval",  Str$(TimerInterval), INIFileName

         WritePrivateProfileString "All", "Zoom",           Str$(Zoom), INIFileName

         WritePrivateProfileString "All", "XDelta",         Str$(XDelta), INIFileName

         WritePrivateProfileString "All", "ShowLine",       Str$(ShowLine), INIFileName

   End Select

End Sub

Sub sBeep : WinBeep(275,150) : End Sub

Sub BuildAcceleratorTable

   Local ac() As ACCELAPI, hAccelerator As Dword, c As Long  ' for keyboard accelator table values

   Dim ac(2)

   ac(c).fvirt = %FVIRTKEY : ac(c).key   = %VK_V  : ac(c).cmd = %IDT_View        : Incr c

   ac(c).fvirt = %FVIRTKEY : ac(c).key   = %VK_L  : ac(c).cmd = %IDT_ShowLine    : Incr c

   ac(c).fvirt = %FVIRTKEY : ac(c).key   = %VK_S  : ac(c).cmd = %IDT_Scroll      : Incr c

   Accel Attach hDlg, AC() To hAccelerator

End Sub

Sub ResizeDialog

   Local w,h, x1,y1 As Long

   Dialog Get Client hDlg To w,h

   Control Set Size hDlg, %IDC_Graphic, w-20, h-TBH-SBH-10

   Control Get Client hDlg, %IDC_Graphic To w,h

   x1 = 0

   y1 = (h-Zoom*ImageHeight)/2

   Graphic Color %Black, %White

   Graphic Width 2

   Graphic Clear

   Graphic Set StretchMode %HalfTone

   Graphic Render Bitmap "merge.bmp", (x1,y1)-(x1+Zoom*ImageWidth,y1+Zoom*ImageHeight)

   If ShowLine Then DrawLines (%Red)

   Graphic ReDraw

   SetStatusBar

End Sub

Sub DrawLines (LineColor As Long)

   Local w,h,i, SingleImageX As Long

   Graphic Get Canvas To w,h

   SingleImageX = w / ImageCount

   Graphic Color LineColor, %White

   For i = 1 To ImageCount-1

      Graphic Line (i*SingleImageX-5,0)-(i*SingleImageX-5,h)

   Next i

End Sub

Sub SetStatusBar

   Statusbar Set Text hDlg, %IDC_StatusBar, 1, 0, "gbScroller v" + $Ver + "       Zoom = " + Str$(Zoom) + "       Timer Interval = " + Str$(TimerInterval) + "      " + Time$

End Sub

Function ImageCount As Long

   Local iCount As Long, temp$

   temp$ = Dir$("images\*.*")

   While Len(temp$)

      Incr iCount

      temp$ = Dir$(Next)

   Wend

   Function = iCount

End Function

Sub GetImageSize 'get image size for bmp$

   Local hBMP As Dword

   Graphic Bitmap Load "merge.bmp", 0, 0 To hBMP

   Graphic Attach hBMP, 0

   Graphic Get Canvas To ImageWidth, ImageHeight

   Graphic Bitmap End

End Sub

Sub ChangeSpeed(iDelta As Long)

   Select Case iDelta

      Case 0   : TimerInterval  = 0  : Scroll = 0 'stopped

      Case 1   : TimerInterval += 10 : Scroll = 1 'slower

      Case -1  : TimerInterval -= 10 : Scroll = 1 'faster

   End Select

   If TimerInterval < 10 Then TimerInterval = 10 : sBeep

   KillTimer hDlg, %ID_Timer

   SetTimer hDlg, %ID_Timer, TimerInterval, %Null

   SetStatusBar

End Sub

Sub Magnify(iDelta As Long)

   Select Case iDelta

      Case 0  : Zoom = 1

      Case 1  : Zoom += 0.25

      Case -1 : Zoom -= 0.25

   End Select

   If Zoom < 1 Then Zoom = 1

   ResizeDialog

End Sub

Sub ManageScroll

   Scroll Xor=1

   If Scroll Then

      SetTimer hDlg, %ID_Timer, TimerInterval, %Null

   Else

      KillTimer hDlg, %ID_Timer

   End If

End Sub

Sub ResetScroll

   Local w,h As Long

   Graphic Get View To w,h

   Graphic Set View 0, h

End Sub

Sub ScrollImage

   Local w,h,ww,hh,www,hhh As Long

   Graphic Get View To w,h

   Graphic Set View w+XDelta, h

   Control Get Client hDlg, %IDC_Graphic To www,hhh

   Graphic Get Canvas To ww,hh

   'Dialog Set Text hDlg, Str$(w+XDelta) + Str$(ImageWidth)

   If w+XDelta >= (ImageWidth-www) Then

      sBeep : sBeep

      ManageScroll : CreateToolbar

   End If

End Sub

gbClientCapture

Sat, 20 Sep 2025 17:38:06 +0000

This app displays a transparent dialog, with a Toolbar and a Statusbar. Images under the open dialog client area are captured and merged into a horizontal image. This will be used by my next app to scroll the horizontal image - corresponding to my post about breaking vertical sheet music into scrollable horizontal music.

Discussion is here.

Toolbar buttons:

1. Exit - close gbClientCapture

2. Copy - captures the desktop below the transparent dialog client and saves it as a BMP. each capture is merged with previous captures to form a horizontal image (first captured image on the left, last captured image on the right)

3. New - deletes all images, including the merged image

4. View - opens the current merged image in the default image viewer

The Statusbar keeps track of how many images there are in the image folder.

Here's a picture of the app, with some desktop showing through the client area.

Code and images are here: https://www.garybeene.com/files/gbclientcapture.zip

Code:
'Compilable Example:  (Jose Includes)

#Compile Exe  "gbclientcapture.exe"

#Dim All

#Debug Error On

#Debug Display On

%Unicode=1

#Include "Win32API.inc"

%IDC_Toolbar   = 500

%IDT_Exit      = 501

%IDT_Copy      = 502

%IDT_New       = 503

%IDT_View      = 504

%IDC_StatusBar = 505

#Resource Manifest, 1,      "icons\xptheme_dpiaware.xml"

#Resource VersionInfo

#Resource StringInfo "0409", "04B0"

#Resource Version$ "CompanyName", "New Vision Concepts"

#Resource Version$ "ProductName", "gbClientCapture"

#Resource Version$ "ProductVersion", "1.0"

#Resource Version$ "FileDescription",  "gbClientCapture - Capture Desktop Behind Client"

#Resource Version$ "LegalCopyright",   "Copyright 2025 New Vision Concepts"

#Resource Icon logo, "icons\alogo.ico"

#Resource Icon zexit, "icons\power.ico"

#Resource Icon zcopy, "icons\copy.ico"

#Resource Icon znew, "icons\new.ico"

#Resource Icon zmerge, "icons\view.ico"

$Ver = "1.0"

Global hDlg, hToolbar, hList, hBrush, hFont As Dword

Global ImageCount, ImageWidth, ImageHeight As Long

Global SBW, SBH, TBW, TBH As Long

Function PBMain() As Long

   Dialog New Pixels, 0, "gbClientCapture  v" + $Ver,300,50,200,100, %WS_OverlappedWindow, %WS_Ex_Layered To hDlg

   Dialog Set Icon hDlg, "logo"

   Dialog Set Color hDlg, %Black, %White

   CreateToolbar

   Control Add Statusbar, hDlg, %IDC_StatusBar, "", 0,0,0,0, %CCS_Bottom Or %SBars_SizeGrip

   Control Get Size hDlg, %IDC_StatusBar To SBW, SBH

   Control Set Color hDlg, %IDC_StatusBar, %Black, %Gray

   Font New "Tahoma",10, 1 To hFont

   Control Set Font hDlg, %IDC_Toolbar, hFont

   Control Set Font hDlg, %IDC_StatusBar, hFont

   Dialog Show Modal hDlg Call DlgProc

End Function

CallBack Function DlgProc() As Long

   Select Case Cb.Msg

      Case %WM_InitDialog

         hBrush = CreateSolidBrush(RGB(243,243,243))

         SetWindowPos hDlg, %HWND_TOPMOST, 0, 0, 0, 0, %SWP_NOMOVE Or %SWP_NOSIZE

         If IsFalse IsFolder("images") Then MkDir "images"

         Settings_INI "get"

         Statusbar Set Text hDlg, %IDC_StatusBar, 1, 0, "ImageCount = " + Format$(ImageCount)

         SetLayeredWindowAttributes(hDlg, %White, 255, %LWA_ALPHA Or %LWA_Colorkey)

      Case %WM_ContextMenu

         sBeep : Dialog End hDlg

      Case %WM_Command

         Select Case Cb.Ctl

            Case %IDT_Exit  : sBeep : Dialog End hDlg

            Case %IDT_Copy  : sBeep : SaveDialogToClipboard : MergeImages

            Case %IDT_New   : sBeep : NewProject

            Case %IDT_View : sBeep : ViewMerge

         End Select

      Case %WM_Notify

         Select Case Cb.NmId

            Case %IDC_Toolbar

               Local pTbCustDraw As NmTbCustomDraw Pointer

               pTbCustDraw  = Cb.LParam

               Select Case @pTbCustDraw.nmcd.dwDrawStage

                  Case %CDDS_PREPAINT  ' paint entire toolbar

                     FillRect(@pTbCustDraw.nmcd.hdc, @pTbCustDraw.nmcd.rc, hBrush)

                     Function = %CDRF_NOTIFYITEMDRAW

               End Select

         End Select

      Case %WM_Destroy

         DeleteObject hBrush

         Settings_INI "save"

   End Select

End Function

Sub CreateToolbar

   ImageList New Icon 32,32,32,20 To hList

   ImageList Add Icon hList, "zexit"   '1

   ImageList Add Icon hList, "zcopy"   '2

   ImageList Add Icon hList, "znew"    '3

   ImageList Add Icon hList, "zmerge"  '4

   Control Add Toolbar, hDlg, %IDC_Toolbar, "", 0,0,0,0 ', %TbStyle_Flat

   Control Handle hDlg, %IDC_Toolbar To hToolbar

   Toolbar Set ImageList hDlg, %IDC_Toolbar, hList, 0

   Toolbar Add Button hDlg, %IDC_Toolbar, 1, %IDT_Exit, %TbStyle_Button, " Exit "

   Toolbar Add Button hDlg, %IDC_Toolbar, 2, %IDT_Copy, %TbStyle_Button, " Copy "

   Toolbar Add Button hDlg, %IDC_Toolbar, 3, %IDT_New, %TbStyle_Button, " New "

   Toolbar Add Button hDlg, %IDC_Toolbar, 4, %IDT_View, %TbStyle_Button, " View "

   Control Get Size hDlg, %IDC_Toolbar To TBW, TBH

End Sub

Sub Settings_INI(Task$)

   Local x,y,w,h, tempz, INIFileName As WStringZ * %Max_Path, WinPla As WindowPlacement

   'set ini filename

   INIFileName = Exe.Path$ + Exe.Name$ + ".ini"    'get INI file name

   Select Case Task$

      Case "get"

         'get dialog width/height from INI file and use to set Dialog size

         GetPrivateProfileString "All", "Width", "1200", w, %Max_Path, INIFileName

         GetPrivateProfileString "All", "Height", "300", h, %Max_Path, INIFileName

         Dialog Set Size hDlg,Val(w), Val(h)   'width/height

         'get dialog top/left from INI file and use to set Dialog location

         Getprivateprofilestring "All", "Left", "0", x, %Max_Path, INIFileName

         Getprivateprofilestring "All", "Top", "0",  y,  %Max_Path, INIFileName

         If IsFile(INIFileName) Then Dialog Set Loc hDlg, Val(x), Val(y)   'left/top but only once INIFileName exists

         'get value for string variables

'         GetPrivateProfileString "All", "FontName", "Arial Black", FontName, %Max_Path, INIFileName

         'get value for numeric variables

         Getprivateprofilestring "All", "ImageWidth", "",     tempz, %Max_Path, INIFileName   : ImageHeight = Val(tempz)

         Getprivateprofilestring "All", "ImageHeight", "",    tempz, %Max_Path, INIFileName   : ImageWidth = Val(tempz)

         Getprivateprofilestring "All", "ImageCount", "0",    tempz, %Max_Path, INIFileName   : ImageCount = Val(tempz)

      Case "save"

         If IsFile(INIFileName) Then Kill INIFileName    'clear the INI file Name to remove residual entries before saving

         WinPla.Length = SizeOf(WinPla)

         GetWindowPlacement hDlg, WinPla

         WritePrivateProfileString "All", "Left",   Str$(WinPla.rcNormalPosition.nLeft), INIFileName

         WritePrivateProfileString "All", "Top",    Str$(WinPla.rcNormalPosition.nTop), INIFileName

         WritePrivateProfileString "All", "Width",  Str$(WinPla.rcNormalPosition.nRight - WinPla.rcNormalPosition.nLeft), INIFileName

         WritePrivateProfileString "All", "Height", Str$(WinPla.rcNormalPosition.nBottom - WinPla.rcNormalPosition.nTop), INIFileName

         'save string variables

'         WritePrivateProfileString "All", "FontName",   FontName, INIFileName

         'save numeric variables

         WritePrivateProfileString "All", "ImageHeight",    Str$(ImageHeight), INIFileName

         WritePrivateProfileString "All", "ImageWidth",     Str$(ImageWidth), INIFileName

         WritePrivateProfileString "All", "ImageCount",     Str$(ImageCount), INIFileName

   End Select

End Sub

Sub sBeep : WinBeep(275,150) : End Sub

Sub NewProject  'remove all \images\*.bmp

   Local temp$

   Clipboard Reset

   ImageCount = 0

   temp$ = Dir$("images\*.bmp")

   If Len(temp$) Then Kill "images\*.bmp"

   Statusbar Set Text hDlg, %IDC_StatusBar, 1, 0, "ImageCount = " + Format$(ImageCount)

End Sub

Sub SaveDialogToClipboard

   Local x,y As Long, hBMP, hBMPDC, hDC As Dword       '         abcdegfg

   'create memory bitmap the size of the dialog client (less Toolbar and less StatusBar)

   Dialog Get Client hDlg To ImageWidth, ImageHeight

   ImageWidth = ImageWidth - 1

   ImageHeight = ImageHeight - SBH - TBH - 2

   Graphic Bitmap New ImageWidth, ImageHeight To hBMP

   Graphic Attach hBMP,0

   Graphic Get DC To hBMPDC

   'bitblt dialog rectangle from the screen to the me                            mory bitmap

   Dialog Get Loc hDlg To x,y

   x = x + 9

   y = y + TBH + CaptionHeight - 7

   hDC = GetDC(%Null)

   BitBlt hBMPDC, 0,0,ImageWidth,ImageHeight, hDC, x,y, %SRCCopy 'copy desktop image to

   ReleaseDC(%Null,hDC)

   'save to file

   Incr ImageCount

   Graphic Save "images\" + Format$(ImageCount) + ".bmp"

   'send to clipboard

   Clipboard Reset

   Clipboard Set Bitmap hBMP

   'get rid of the bitmap

   Graphic Bitmap End

   'count images

   Statusbar Set Text hDlg, %IDC_StatusBar, 1, 0, "ImageCount = " + Format$(ImageCount)

End Sub

Function captionHeight As Long

   Local cw,ch,ddw,ddh As Long

   Dialog Get Size hDlg To ddw,ddh

   Dialog Get Client hDlg To cw,ch

   Function = ddh-ch

End Function

Sub MergeImages

   Local i, x1, y1, x2, y2 As Long

   Local hBMP, hBMPDC As Dword, ImageName$

   If IsFile("merge.bmp") Then Kill "merge.bmp"

   Graphic Bitmap New ImageCount*ImageWidth,ImageHeight To hBMP

   Graphic Attach hBMP,0

   Graphic Get DC To hBMPDC

   For i = 1 To ImageCount

      ImageName$ = "images\" + Format$(i) + ".bmp"

      x1 = (i-1) * ImageWidth

      x2 = x1 + ImageWidth

      y1 = 0

      y2 = ImageHeight

      Graphic Render Bitmap ImageName$, (x1,y1)-(x2,y2)

   Next i

   Graphic Save "merge.bmp"

   Graphic Bitmap End

End Sub

Sub ViewMerge

   Local iReturn As Long, hBMP As Dword

   Graphic Bitmap Load "merge.bmp", 0,0 To hBMP

   Graphic Attach hBMP,0

   Clipboard Reset

   Clipboard Set Bitmap hBMP

   Graphic Bitmap End

   iReturn = ShellExecute(hDlg, "Open", "merge.bmp", $Nul, $Nul, %SW_ShowNormal)

End Sub

Very Fast WString /Object Hash Table

Fri, 05 Sep 2025 00:29:00 +0000

find 100,000 random keys = 0.004 seconds
find 1,000,000 random keys = 0.112 seconds
find 5,000,000 random keys = 0.900 seconds

A unique key, WString, is used to store and retrieve a payload value, Object.
Key is case sensitive.
Property Set Capacity(ByVal value As Long), about number of expected items.

Can Store/Restore To/From File. To use that you need to provide callbacks. One to pack the object into a String and another to restore the object from a String.
Declare Function ObjectStoreCallback(o As IUnknown) As String
Declare Function ObjectRestoreCallback(ByRef stored As String) As IUnknown
When you implement the callbacks, use the actual “Interface” instead of “IUnknown.”

INC has no dependencies.

Code:
'ObjectHash.inc

'Public domain, use at own risk. SDurham

#If Not %Def(%OHash250808)

    %OHash250808 = 1

    Declare Function ObjectStoreCallback(o As IUnknown) As String

        'store object's data in a String and return the String

        'when you implement the callback, replace IUnknown with the actual interface

    Declare Function ObjectRestoreCallback(ByRef stored As String) As IUnknown

        'restore object's data and return new instance

        'when you implement the callback, replace IUnknown with the actual interface

    Type WStrT

        mem As Word Ptr

        count As Long

    End Type

    Type OHashNodeT

        key As WStrT

        value As Long

        next As OHashNodeT Ptr

    End Type

    Type StrBuildT

        mem As Long

        count As Long

        max As Long

    End Type

    Class OHashC

        'Key/Value WString/Object Hash Table

        'value stored and retrieved using unique key

        'key case sensitive

        Instance mCapacity As Long

        Instance mCount As Long

        Instance mArr() As Long

        Instance mIndex As Long

        Instance mNode As OHashNodeT Ptr

        Instance mStore As Long

        Instance mRestore As Long

        Class Method Create()

            mCapacity = 30 'default capacity

            ReDim mArr(0 To mCapacity - 1)

        End Method

        Class Method Destroy()

            Me.ClearMe()

            Erase mArr()

        End Method

        Interface OHashI : Inherit IUnknown

            Property Set Capacity(ByVal value As Long)

                'about number of expected items : hash table must be empty

                If mCount = 0 And value > 0 Then

                    mCapacity = value

                    ReDim mArr(0 To mCapacity - 1)

                End If

            End Property

            Method Storage(ByVal storeCB As Long, ByVal restoreCB As Long)

                'store and restore callbacks must be set to call Stor/Restore methods

                If storeCB And restoreCB Then

                    mStore = storeCB : mRestore = restoreCB

                End If

            End Method

            Method Clear()

                'empty container

                Me.ClearMe()

            End Method

            Property Get Count() As Long

                'get item count

                Property = mCount

            End Property

            Method Set(ByRef key As WString, value As IUnknown)

                'add key and associated value : key added if not in hash table

                Local index, keymem, keylen As Long

                Local node As OHashNodeT Ptr

                If IsObject(value) Then

                    keymem = StrPtr(key)

                    keylen = Len(key)

                    index = WStrHashIndex(keymem, keylen, mCapacity)

                    node = mArr(index)

                    While node

                        If WStrEqual(keymem, keylen, @node.key.mem, @node.key.count) Then

                            @node.value = Me.FreeObj(@node.value)

                            @node.value = Me.LongFromObj(value)

                            Exit Method

                        End If

                        node = @node.next

                    Wend

                    'key not in hash table

                    node = MemAlloc(SizeOf(@node))

                    If node Then

                        WStrSet @node.key, key

                        @node.value = Me.LongFromObj(value)

                        @node.next = mArr(index)

                        mArr(index) = node

                        Incr mCount

                    End If

                End If

            End Method

            Method Get(ByRef key As WString) As IUnknown

                'get key's associated value : null if key not in hash table

                Local o As IUnknown

                Local node As OHashNodeT Ptr

                node = Me.Contains(key)

                If node Then

                    o = Me.ObjFromLong(@node.value)

                    Method = o

                End If

            End Method

            Method Contains(ByRef key As WString) As Long

                'true/false if key in hash table

                Local keymem, keylen As Long

                Local node As OHashNodeT Ptr

                If mCount Then

                    keymem = StrPtr(key)

                    keylen = Len(key)

                    node = mArr(WStrHashIndex(keymem, keylen, mCapacity))

                    While node

                        If WStrEqual(keymem, keylen, @node.key.mem, @node.key.count) Then

                            Method = node : Exit Method

                        End If

                        node = @node.next

                    Wend

                End If

            End Method

            Method Delete(ByRef key As WString)

                'delete key and associated value

                Local index, keymem, keylen As Long

                Local node, prev As OHashNodeT Ptr

                If mCount Then

                    keymem = StrPtr(key)

                    keylen = Len(key)

                    index = WStrHashIndex(keymem, keylen, mCapacity)

                    node = mArr(index)

                    While node

                        If WStrEqual(keymem, keylen, @node.key.mem, @node.key.count) Then

                            If prev Then

                                @prev.next = @node.next

                            Else

                                mArr(index) = @node.next

                            End If

                            node = Me.FreeNode(node)

                            Decr MCount

                            Exit Method

                        End If

                        node = @node.next

                    Wend

                End If

            End Method

            Method Start()

                'reset cursor to start

                mIndex = -1 : mNode = 0

            End Method

            Method Each() As Long

                'move cursor to next key in hash table : true/false success

                Register i As Long

                If mCount Then

                    If mNode And @mNode.next Then

                        mNode = @mNode.next

                        Method = 1 : Exit Method

                    Else

                        mNode = 0

                        For i = mIndex + 1 To mCapacity - 1

                            If mArr(i) Then

                                mIndex = i

                                mNode = mArr(i)

                                Method = 1 : Exit Method

                            End If

                        Next i

                    End If

                End If

                mIndex = -1 : mNode = 0

            End Method

            Method Key() As WString

                'get key at cursor position : null if cursor invalid

                If mNode Then Method = WStrGet(@mNode.key)

            End Method

            Method Value() As IUnknown

                'get value at cursor position : null if cursor invalid

                If mNode Then Method = Me.ObjFromLong(@mNode.value)

            End Method

            Method Store() As String

                'store container as String

                Local key, s As String

                Local value As IUnknown

                Local sb As StrBuildT

                If mCount And mStore Then

                    StrBuildPush sb, Mkl$(mCount)

                    Me.Start()

                    While Me.Each()

                        key = ChrToUtf8$(Me.Key())

                        value = Me.Value()

                        If IsObject(value) Then

                            Call Dword mStore Using ObjectStoreCallback(value) To s

                            StrBuildPush sb, Mkl$(Len(key))

                            StrBuildPush sb, key

                            StrBuildPush sb, Mkl$(Len(s))

                            StrBuildPush sb, s

                        End If

                    Wend

                    Method = StrBuildPop(sb)

                End If

            End Method

            Method Restore(ByRef stored As String)

                'restore container from String

                Register i As Long

                Local items, bytes As Long

                Local key, s As String

                Local o As IUnknown

                Local p As Long Ptr

                Me.ClearMe()

                If mRestore And Len(stored) Then

                    p = StrPtr(stored)

                    items = @p : Incr p

                    For i = 1 To items

                        bytes = @p : Incr p

                        key = Peek$(p, bytes) : p += bytes

                        bytes = @p : Incr p

                        s = Peek$(p, bytes) : p += bytes

                        Call Dword mRestore Using ObjectRestoreCallback(s) To o

                        Me.Set(Utf8ToChr$(key), o)

                    Next i

                End If

            End Method

            Method FileStore(ByVal file As WString)

                'store container to File

                If Len(file) And mStore Then Me.FilePut(file, Me.Store())

            End Method

            Method FileRestore(ByVal file As WString)

                'restore container from File

                If IsFile(file) And mRestore Then Me.Restore(Me.FileGet(file))

            End Method

        End Interface

        Class Method ClearMe()

            Register i As Long

            Local node As OHashNodeT Ptr

            For i = 0 To mCapacity - 1

                While mArr(i)

                    node = mArr(i)

                    mArr(i) = @node.next

                    Me.FreeNode(node)

                Wend

            Next i

            mCount = 0

        End Method

        Class Method FreeNode(ByVal node As OHashNodeT Ptr) As Long

            If node Then

                WStrFinal @node.key

                @node.value = Me.FreeObj(@node.value)

                MemFree(node)

            End If

        End Method

        Class Method LongFromObj(o As IUnknown) As Long

            If IsObject(o) Then

                o.AddRef()

                Method = Peek(Long, VarPtr(o))

            End If

        End Method

        Class Method ObjFromLong(ByVal h As Long) As IUnknown

            Local o As IUnknown

            If h Then

                Poke Long, VarPtr(o), h

                o.AddRef()

                Method = o

            End If

        End Method

        Class Method FreeObj(ByVal h As Long) As Long

            Local o As IUnknown

            If h Then

                Poke Long, VarPtr(o), h

                o = Nothing

            End If

        End Method

        Class Method FilePut(ByVal file As WString, ByRef value As String)

            Local f As Long

            If Len(file) = 0 Then Exit Method

            f = FreeFile

            Open file For Binary As f

            SetEof f

            Put$ f, value

            Close f

        End Method

        Class Method FileGet(ByVal file As WString) As String

            Local f As Long, value As String

            If IsFalse IsFile(file) Then Exit Method

            f = FreeFile

            Open file For Binary As f

            Get$ f, Lof(f), value

            Close f

            Method = value

        End Method

    End Class

#EndIf '%OHash250808

#If Not %Def(%WStr250808)

    %WStr250808 = 1

    '----------------------------------------------------------------------

    'WString Container = Word Array

    'Public domain, use at own risk. SDurham

    '----------------------------------------------------------------------

    %WrdSize = 2

    Type WStrT

        mem As Word Ptr

        count As Long

    End Type

    '----------------------------------------------------------------------

    Sub WStrFinal(t As WStrT)

        'call before variable gores out of scope to free memory

        WStrClear t

    End Sub

    '----------------------------------------------------------------------

    Sub WStrClear(t As WStrT)

        'empty container

        t.mem = MemFree(t.mem)

        t.count = 0

    End Sub

    '----------------------------------------------------------------------

    Function WStrCount(t As WStrT) As Long

        'get character count

        Function = t.count

    End Function

    '----------------------------------------------------------------------

    Function WStrGet(t As WStrT) As WString

        'get value

        If t.mem Then Function = Peek$$(t.mem, t.count)

    End Function

    '----------------------------------------------------------------------

    Macro WStrGetM(t) = Peek$$(t.mem, t.count)

    '----------------------------------------------------------------------

    Sub WStrSet(t As WStrT, ByRef value As WString)

        'set value

        Local characters As Long

        t.mem = MemFree(t.mem)

        t.count = 0

        characters = Len(value)

        If characters Then

            t.mem = MemAlloc(characters * %WrdSize)

            If t.mem Then

                Memory Copy StrPtr(value), t.mem, characters * %WrdSize

                t.count = characters

            End If

        End If

    End Sub

    '----------------------------------------------------------------------

#EndIf '%WStr250808

#If Not %Def(%WStrHash250808)

    %WStrHash250808 = 1

    '----------------------------------------------------------------------

    'WString Hash Index

    'Public domain, use at own risk. SDurham

    '----------------------------------------------------------------------

    Function WStrHashIndex(ByVal keymem As Word Ptr, ByVal keylen As Long, ByVal capacity As Long) As Long

        'get key's hash index position

        Register i As Long

        Register total As Long

        Local temp As Long

        If keymem Then

            For i = 0 To keylen - 1

                temp += @keymem[i] + total

                Shift Left total, 8

                total += temp

            Next i

            Function = Abs(total Mod capacity)

        End If

    End Function

    '----------------------------------------------------------------------

#EndIf '%WStrHash250808

#If Not %Def(%WStrEqual250808)

    %WStrEqual250808 = 1

    '----------------------------------------------------------------------

    Function WStrEqual(ByVal memA As Word Ptr, ByVal lenA As Long, ByVal memB As Word Ptr, ByVal lenB As Long) As Long

        'true/false if two strings equal

        Register i As Long

        If memA And memB And lenA = lenB Then

            For i = 0 To lenA - 1

                If @memA[i] <> @memB[i] Then Exit Function

            Next i

            Function = 1

        End If

    End Function

    '----------------------------------------------------------------------

#EndIf '%WStrEqual250808

#If Not %Def(%StrBuild250811)

    %StrBuild250811 = 1

    '----------------------------------------------------------------------

    'String Builder

    'Public domain, use at own risk. SDurham

    '----------------------------------------------------------------------

    %BytSize = 1

    %StrBuildBufferMax = 5000000

    '----------------------------------------------------------------------

    Type StrBuildT

        mem As Long

        count As Long

        max As Long

    End Type

    '----------------------------------------------------------------------

    Sub StrBuildPush(t As StrBuildT, ByVal value As String)

        'append value

        Local strlen, currentcount, buffer, newmax As Long

        strlen = Len(value)

        If strlen Then

            If strlen > t.max - t.count Then

                currentcount = t.count : t.count = 0 : t.max = 0

                buffer = Max&(1, 2 * currentcount)

                buffer = Min&(buffer, %StrBuildBufferMax)

                newmax = currentcount + buffer + strlen

                t.mem = MemReAlloc(t.mem, newmax * %BytSize)

                If t.mem = 0 Then Exit Sub

                t.count = currentcount : t.max = newmax

            End If

            Memory Copy StrPtr(value), t.mem + (t.count * %BytSize), strlen * %BytSize

            t.count += strlen

        End If

    End Sub

    '----------------------------------------------------------------------

    Function StrBuildPop(t As StrBuildT) As String

        'get whole string : free memory

        If t.mem And t.count Then Function = Peek$(t.mem, t.count)

        t.mem = MemFree(t.mem)

        t.count = 0

        t.max = 0

    End Function

    '----------------------------------------------------------------------

#EndIf '%StrBuild250811

#If Not %Def(%Memory230925)

    %Memory230925 = 1

    '----------------------------------------------------------------------

    'Memory Allocation

    'Public domain, use at own risk. SDurham

    '----------------------------------------------------------------------

    Declare Function GlobalAlloc Lib "Kernel32.dll" Alias "GlobalAlloc" (ByVal uFlags As Dword, ByVal dwBytes As Dword) As Dword

    Declare Function GlobalReAlloc Lib "Kernel32.dll" Alias "GlobalReAlloc" (ByVal hMem As Dword, ByVal dwBytes As Dword, ByVal uFlags As Dword) As Dword

    Declare Function GlobalFree Lib "Kernel32.dll" Alias "GlobalFree" (ByVal hMem As Dword) As Dword

    %MEMFIXED = &H0000 : %MEMMOVEABLE = &H0002 : %MEMZEROINIT = &H0040 : %MEMGPTR = (%MEMZEROINIT Or %MEMFIXED)

    '----------------------------------------------------------------------

    Function MemAlloc(ByVal bytes As Long) As Long

        'allocate memory

        If bytes Then Function = GlobalAlloc(ByVal %MEMGPTR, ByVal bytes)

    End Function

    '----------------------------------------------------------------------

    Function MemReAlloc(ByVal hMem As Long, ByVal bytes As Long) As Long

        'reallocate new size

        If hMem And bytes Then

            Function = GlobalReAlloc(ByVal hMem, ByVal bytes, ByVal %MEMMOVEABLE Or %MEMZEROINIT)

        ElseIf bytes Then

            Function = GlobalAlloc(ByVal %MEMGPTR, ByVal bytes)

        ElseIf hMem Then

            Function = GlobalFree(ByVal hMem)

        End If

    End Function

    '----------------------------------------------------------------------

    Function MemFree(ByVal hMem As Long) As Long

        'free memory

        If hMem Then GlobalFree(ByVal hMem)

    End Function

    '----------------------------------------------------------------------

#EndIf '%Memory230925

Code:
'ObjectHash.bas

#Option LargeMem32

#Dim All

#Compile Exe

#Include Once "WIN32API.INC"

#Include Once "..\ObjectHash.inc"

%TextBox = 101

%BtnID = 102

Global gDlg As Long

Global gBuild As IStringBuilderW

Sub SS(ByVal value As WString)

    gBuild.Add(value + $CrLf)

End Sub

Class TestC

    Instance mX As Long

    Interface TestI : Inherit IUnknown

        Property Get X() As Long

            Property = mX

        End Property

        Property Set X(ByVal value As Long)

            mX = value

        End Property

        Property Get Str() As WString

            Property = Format$(mX)

        End Property

    End Interface

End Class

Function TestStore(o As TestI) As String

    'store callback

    'store object's data in a String and return the String

    'when you implement the callback, replace IUnknown with the actual interface

    If IsObject(o) Then Function = Mkl$(o.X)

End Function

Function TestRestore(ByRef stored As String) As TestI

    'restore callback

    'restore object's data and return new instance

    'when you implement the callback, replace IUnknown with the actual interface

    Local o As TestI : o = Class "TestC"

    o.X = Cvl(stored)

    Function = o

End Function

Sub SampleCode()

    Register i As Long

    Local hash As OHashI : hash = Class "OHashC"

    Local o As TestI : o = Class "TestC"

    Local stored As String

    Local a() As WString

    Local d As Double

    Local testcount As Long : testcount = 100000 'can change

    Randomize

    MousePtr 11

    Control Set Text gDlg, %TextBox, ""

    SS ""

    SS "Property Set Capacity(ByVal value As Long)"

    hash.capacity = testcount

    SS ""

    SS "Method Storage(ByVal storeCB As Long, ByVal restoreCB As Long)"

    hash.Storage(CodePtr(TestStore), CodePtr(TestRestore))

    SS ""

    SS "Method Add(ByRef key As WString, value As IUnknown) As Long"

    SS "add key/value items"

    For i = 65 To 69

        o = Class "TestC" : o.X = i

        hash.Set(Chr$$(i), o)

    Next i

    hash.Start()

    While hash.Each()

        o = hash.Value()

        If IsObject(o) Then SS "key = " + $Dq + hash.Key() + $Dq + " | value = " + o.Str

    Wend

    SS ""

    SS "change value for key C"

    o = Class "TestC" : o.X = 4444

    hash.Set("C", o)

    hash.Start()

    While hash.Each()

        o = hash.Value()

        If IsObject(o) Then SS "key = " + $Dq + hash.Key() + $Dq + " | value = " + o.Str

    Wend

    SS ""

    SS "Method Get(ByRef key As WString) As IUnknown"

    SS "get object to change value for key C"

    o = hash.Get("C") : If IsObject(o) Then o.X = 999999999

    hash.Start()

    While hash.Each()

        o = hash.Value()

        If IsObject(o) Then SS "key = " + $Dq + hash.Key() + $Dq + " | value = " + o.Str

    Wend

    SS ""

    SS "Method Contains(ByRef key As WString)"

    SS "hash table contains key B = " + Format$(hash.Contains("B"))

    SS "hash table contains key E = " + Format$(hash.Contains("E"))

    SS "hash table contains key ZZZ = " + Format$(hash.Contains("ZZZ"))

    SS ""

    SS "Method Delete(ByRef key As WString)"

    SS "delete key C"

    hash.Delete("C")

    hash.Start()

    While hash.Each()

        o = hash.Value()

        If IsObject(o) Then SS "key = " + $Dq + hash.Key() + $Dq + " | value = " + o.Str

    Wend

    SS ""

    SS "Method Store() As String"

    stored = hash.Store()

    SS "Method Restore(ByRef stored As String)"

    hash.Restore(stored)

    SS "Method FileStore(ByVal file As String)"

    hash.FileStore("Stored.hash")

    SS "Method FileRestore(ByVal file As String)"

    hash.FileRestore("Stored.hash")

    Kill "Stored.hash"

    hash.Start()

    While hash.Each()

        o = hash.Value()

        If IsObject(o) Then SS "key = " + $Dq + hash.Key() + $Dq + " | value = " + o.Str

    Wend

    ReDim a(1 To testcount)

    For i = 1 To testcount

        a(i) = RandomString()

    Next i

    SS ""

    SS "add "+Format$(testcount,"#,")+" random key/value items"

    hash.Clear()

    d = Timer

    For i = 1 To testcount

        o = Class "TestC" : o.X = i

        hash.Set(a(i), o)

    Next i

    SS "Time = " + Format$(Timer - d, "000.000")

    SS "Count = " + Format$(hash.Count, "#,") + " duplicate keys not allowed"

    SS ""

    SS "find "+Format$(testcount,"#,")+" random keys"

    d = Timer

    For i = 1 To testcount

        If hash.Contains(a(i)) = 0 Then

            ? "hash table fail" : Exit For

        End If

    Next i

    SS "Time = " + Format$(Timer - d, "000.000")

    SS ""

    SS ""

    Control Set Text gDlg, %TextBox, gBuild.String

    gBuild.Clear

    MousePtr 1

End Sub

Function RandomString() As String

    Register i As Long

    Local s As String

    For i = 1 To Rnd(5, 8)

        Select Case As Const Rnd(1, 2)

            Case 1 : s += Chr$(Rnd(65, 90))

            Case 2 : s += Chr$(Rnd(97, 122))

        End Select

    Next i

    Function = s

End Function

Function PBMain()

    gBuild = Class "StringBuilderW"

    Dialog Default Font "courier new", 12, 0, 0

    Dialog New 0, "Sample Code", 0, 0, 0, 0, %WS_Caption Or %WS_ClipSiblings Or %WS_MinimizeBox Or %WS_SysMenu Or %WS_ThickFrame, %WS_Ex_AppWindow To gDlg

    Control Add TextBox, gDlg, %TextBox, "", 0, 0, 0, 0, %ES_AutoHScroll Or %ES_AutoVScroll Or %ES_MultiLine Or %ES_NoHideSel Or %ES_WantReturn Or %WS_HScroll Or %WS_VScroll Or %WS_Border, 0

    Control Add Button,  gDlg, %BtnID, "Run", 275, 220, 60, 15, %BS_Flat, 0

    SendMessageW(GetDlgItem(gDlg, %TextBox), %EM_SETLIMITTEXT, 4000000, 0)

    Dialog Show Modeless gDlg, Call DlgCB

    While IsWin(gDlg)

        Dialog DoEvents

    Wend

End Function

CallBack Function DlgCB()

    Select Case As Long Cb.Msg

        Case %WM_InitDialog

            WM_InitDialog()

        Case %WM_Size

            WM_Size()

        Case %WM_Command

            Select Case As Long Cb.Ctl

                Case %BtnID : If Cb.CtlMsg = %BN_Clicked Then SampleCode()

            End Select

    End Select

End Function

Sub WM_InitDialog()

    Local clientW, clientH As Long

    Desktop Get Client To clientW, clientH

    clientW /= 7

    clientH /= 4

    Dialog Set Loc gDlg, clientW / 2, clientH / 7

    Dialog Set Size gDlg, clientW, clientH

End Sub

Sub WM_Size()

    Local clientW, clientH As Long

    Local marg As Long

    Local buttonW, buttonH As Long

    Local txtWidth, txtHeight As Long

    Local fromLeft, fromBottom As Long

    Dialog Get Client gDlg To clientW, clientH

    marg = 1 : buttonW = 30 : buttonH = 10

    fromLeft = clientW - marg - marg - buttonW

    fromBottom = clientH - marg - marg - buttonH

    Control Set Size gDlg, %BtnID, buttonW, buttonH

    Control Set Loc gDlg, %BtnID, fromLeft, fromBottom

    txtWidth = clientW - marg - marg

    txtHeight = clientH - marg - buttonH - marg - marg

    Control Set Size gDlg, %TextBox, txtWidth, txtHeight

    Control Set Loc gDlg, %TextBox, marg, marg

End Sub

comments
Very Fast WString /Object Hash Table (Comments)

gbNotes

Wed, 03 Sep 2025 19:54:29 +0000

A while back I asked about CRM app recommendations. Not having found something as simple as I wanted, I wrote my own and have been using it the last couple of months.

I still have a list of changes I want to make to it, but since I've been using for a while now, I guess it's worth offering up to anyone who wants it.

Discussion:
Source Code: https://garybeene.com/files/gbnotes.zip

Code:
'Compilable Example:  Requires JOSE includes.

#Compile Exe  "gbnotes.exe"

#Dim All

#Debug Error On

#Debug Display On

%Unicode = 1

#Include "Win32API.inc"

$Ver = "1.0"

$Delim = "++++"

#Resource Icon xlogo, "icons\n.ico"

#Resource Icon xsave, "icons\save.ico"

#Resource Icon xnew, "icons\new.ico"

#Resource Icon xdelete, "icons\delete.ico"

#Resource Icon xsearch, "icons\search.ico"

#Resource Icon xall, "icons\all.ico"

#Resource Icon xsaveall, "icons\saveall.ico"

#Resource Icon xplus, "icons\listplus.ico"

#Resource Icon xup, "icons\searchup.ico"

#Resource Icon xdown, "icons\searchdown.ico"

#Resource Icon xexit, "icons\exit.ico"

%MultiLineREStyle_Wrap    = %WS_Child Or %WS_ClipSiblings Or %WS_Visible Or %ES_MultiLine Or %WS_VScroll Or _

                            %ES_AutoVScroll Or %ES_WantReturn Or %ES_NoHideSel Or %WS_TabStop Or %ES_SaveSel

Enum Equates Singular

   IDC_ComboBox = 500

   IDC_ListView

   IDC_RichEdit

   IDC_Toolbar

   IDC_StatusBar

   IDT_SaveCFN

   IDT_New

   IDT_Delete

   IDT_Search

   IDT_InsertDelimiter

   IDT_ShowAll

   IDT_AllContacts

   IDT_SaveAll

'   IDT_Sort

   IDT_Exit

   IDT_Mute

   IDT_InsertDate

   IDT_SetFocusRE

   IDT_SearchUP

   IDT_SearchDown

   IDT_NextREDown

   IDT_PrevREUp

   IDC_InputTextBox

   IDC_InputOk

   IDC_InputCancel

End Enum

Global hDlg, hRichEdit, hListView, hComboBox, hList, hDlgI As Dword

Global D() As String, REText$, SearchTerm$, SearchTerms$

Global RESearchTerm As WStringZ * 100

Global SearchDirection, BackupNumber, CFN, iSkip, Maximized, Minimized, Mute As Long

Function PBMain() As Long

   Dialog Default Font "Arial Black", 16,1

   Dialog New Pixels, 0, "gbNotes " + $Ver,,,800,800, %WS_OverlappedWindow To hDlg

   Dialog Set Icon hDlg, "xlogo"

   Control Add ComboBox, hDlg, %IDC_ComboBox,, 10,10,400,200, %CBS_Simple Or %CBS_NoIntegralHeight Or %WS_VScroll Or %WS_TabStop, %WS_Ex_ClientEdge

   Control Handle hDlg, %IDC_ComboBox To hComboBox

   Control Add ListView, hDlg, %IDC_ListView, "",10,40,400,400, %WS_TabStop Or %LVS_Report Or %LVS_ShowSelAlways Or %LVS_SingleSel, %WS_Ex_ClientEdge

   ListView Insert Column hDlg, %IDC_ListView, 1,"All Contacts",400,0

   ListView Insert Column hDlg, %IDC_ListView, 2,"Position",150,0

   Control Handle hDlg, %IDC_ListView To hListView

   LoadLibrary("msftedit.dll")

   Control Add "RichEdit50W", hDlg, %IDC_RichEdit, "", 410,10,400,400, %MultiLineREStyle_Wrap, %WS_Ex_ClientEdge

   Control Handle hDlg, %IDC_RichEdit To hRichEdit

   SendMessage hDlg, %EM_SetEventMask, 0, %ENM_SelChange

   SendMessage hRichEdit, %EM_SetEventMask, 0, %ENM_SelChange Or %ENM_Link

   SendMessage hRichEdit, %EM_AUTOURLDETECT, %True, 0

   Control Add Toolbar, hDlg, %IDC_Toolbar, "", 0,0,0,0,%CCS_NoMoveY

   ImageList New Icon 32,32,32,10 To hList

   ImageList Add Icon hList, "xsearch"  '1

   ImageList Add Icon hList, "xsave"    '2

   ImageList Add Icon hList, "xnew"     '3

   ImageList Add Icon hList, "xdelete"  '4

   ImageList Add Icon hList, "xall"     '5

   ImageList Add Icon hList, "xsaveall" '6

   ImageList Add Icon hList, "xplus"    '7

   ImageList Add Icon hList, "xexit"    '8

   ImageList Add Icon hList, "xup"      '9

   ImageList Add Icon hList, "xdown"    '10

   Toolbar Set ImageList hDlg, %IDC_Toolbar, hList, 0

   Toolbar Add Button hDlg, %IDC_Toolbar, 8, %IDT_Exit, %TbStyle_Button, "Exit"

   Toolbar Add Button hDlg, %IDC_Toolbar, 5, %IDT_AllContacts, %TbStyle_Button, "All"

   Toolbar Add Button hDlg, %IDC_Toolbar, 2, %IDT_SaveCFN, %TbStyle_Button, "Save"

   Toolbar Add Button hDlg, %IDC_Toolbar, 3, %IDT_New, %TbStyle_Button, "New"

   Toolbar Add Button hDlg, %IDC_Toolbar, 4, %IDT_Delete, %TbStyle_Button, "Delete"

   Toolbar Add Separator hDlg, %IDC_Toolbar, 50

   Toolbar Add Button hDlg, %IDC_Toolbar, 5, %IDT_ShowAll, %TbStyle_Button, "Show All"

   Toolbar Add Separator hDlg, %IDC_Toolbar, 10

   Toolbar Add Button hDlg, %IDC_Toolbar, 6, %IDT_SaveAll, %TbStyle_Button, "Save All"

   Toolbar Add Button hDlg, %IDC_Toolbar, 10, %IDT_SearchUp, %TbStyle_Button, "Up"

   Toolbar Add Button hDlg, %IDC_Toolbar, 9, %IDT_SearchDown, %TbStyle_Button, "Down"

   Control Add Statusbar, hDlg, %IDC_StatusBar, "Welcome to gbNotes!", 0,0,0,90

   Dialog Show Modal hDlg Call DlgProc

End Function

CallBack Function DlgProc() As Long

   Local pNMLV As NMListView Ptr, iRow As Long, temp$

   Select Case Cb.Msg

      Case %WM_InitDialog

         If IsFalse IsFolder("backup") Then MkDir "backup"

         Settings_INI "get"

         BuildAcceleratorTable

         LoadCRMFile       'create D() from CRM.txt

         DisplayCRMArray   'put D() into LV

         LoadComboBox

         Control Set Text hDlg, %IDC_ComboBox, SearchTerm$

         If Maximized Then Dialog Show State hDlg, %SW_Maximize  'restore Maximized state if necessary

         If Minimized Then Dialog Show State hDlg, %SW_Minimize       'restore Maximized state if necessary

         Control Set Text hDlg, %IDC_RichEdit, D(CFN)

         ListView Select hDlg, %IDC_ListView, CFN

         ListView_SetItemState hListView, CFN-1, %LVIS_Focused, %LVIS_Focused  '<--- keyboard synchronizing code

         ListView Visible hDlg, %IDC_ListView, CFN

      Case %WM_Size : Resize

      Case %WM_Command

         Select Case Cb.Ctl

'            Case %IdCancel : Dialog End hDlg

            Case %IdOk 'Enter Key

               If GetParent(GetFocus) = hComboBox Then

                  sBeep

                  Control Get Text hDlg, %IDC_ComboBox To SearchTerm$

                  Search

                  AddSearchTerm

               End If

            Case %IDC_ComboBox

               Select Case Cb.CtlMsg

                  Case %CBN_SelChange

                     'get post-selection text

                     Control Send hDlg, %IDC_ComboBox, %CB_GetCurSel, 0, 0 To iRow

                     ComboBox Get Text hDlg, %IDC_ComboBox, iRow+1 To SearchTerm$

                     Dialog Set Text hDlg, "SearchTerm = " + SearchTerm$  + "   " + Time$

                     Search

               End Select

            Case %IDT_Exit       : sBeep : Dialog End hDlg

            Case %IDT_SaveCFN    : sBeep : SaveCFN          : ST Trim$(Parse$(D(CFN),$CrLf,1)) + " saved"

            Case %IDT_New        : NewCFN                   : ST "New Contact"

            Case %IDT_Delete     : sBeep : DeleteCFN        : ST ""

            Case %IDT_Search     : sBeep : Control Get Text hDlg, %IDC_ComboBox To SearchTerm$ : Search  'ST

            Case %IDT_InsertDate : sBeep : InsertDate       : ST ""

            Case %IDT_InsertDelimiter : sBeep : InsertDelimiter : ST ""

            Case %IDT_ShowAll    : sBeep : ShowAll          : ST "All CRM.txt Loaded in Editor"

            Case %IDT_SaveAll    : sBeep : SaveAll          : ST "Editor Content saved to crm.txt"

'            Case %IDT_Sort       : sBeep : SortData

            Case %IDT_Mute       : WinBeep(275,150) : Mute Xor=1 : ST "Mute is " + IIf$(Mute,"ON","OFF")

            Case %IDT_SetFocusRE : SetFocus hRichEdit

            Case %IDT_SearchDown     : SearchDirection = 1 : FindRE : ST ""

            Case %IDT_SearchUp       : SearchDirection = 0 : FindRE

            Case %IDT_NextREDown     : sBeep : SearchDirection = 1 :    SearchText RESearchTerm, %FR_Down

            Case %IDT_AllContacts    : DisplayCRMArray

         End Select

      Case %WM_Notify

         Select Case Cb.NmId

            Case %IDC_RichEdit

               Select Case Cb.NmCode

                  Case %EN_Link : OpenLink(Cb.LParam)

               End Select

            Case %IDC_ListView

               Select Case Cb.NmCode

                  Case %LVN_ItemChanged  '%NM_Click

                     pNMLV = Cb.LParam

                     If (@pNMLV.uChanged And %LVIF_STATE) = %LVIF_STATE Then  ' if state has changed

                         If (@pNMLV.unewstate And %LVIS_SELECTED) = %LVIS_SELECTED Then

                            ListView Get Select hDlg, %IDC_ListView To iRow

                            ListView Get Text hDlg, %IDC_Listview, iRow, 2 To temp$

                            CFN = Val(temp$)

                            Control Set Text hDlg, %IDC_RichEdit, D(CFN)

                            sBeep

                         End If

                     End If

               End Select

         End Select

      Case %WM_Destroy

         SaveBackup

         Settings_INI "save"

   End Select

End Function

Sub Resize

   Local x,y,w,h,wc,hc,wt,ht As Long

   Control Get Size hDlg, %IDC_Toolbar To wt,ht

   Dialog Get Client hDlg To w,h

   Control Set Loc hDlg, %IDC_ComboBox, 10,ht+10

   Control Get Size hDlg, %IDC_ComboBox To wc,hc

   Control Set Loc hDlg, %IDC_ListView, 10,ht+hc+20

   Control Set Size hDlg, %IDC_ListView, 400, h-ht-hc-30-40

   Control Set Loc hDlg, %IDC_RichEdit, wc+15,ht+10

   Control Set Size hDlg, %IDC_RichEdit, w-wc-25,h-ht-30-30

End Sub

Function OpenLink(ByVal lpLink As Dword) As Long

   Local enlinkPtr As ENLINK Ptr, linkText As String, iReturn As Long

   Control Get Text hDlg, %IDC_RichEdit To REText$

   enlinkPtr  = lpLink

   If @enLinkPtr.Msg = %WM_LButtonUp Then

      LinkText = Mid$(REText$,@enLinkPtr.chrg.cpMin+1 To @enLinkPtr.chrg.cpMax)

      LinkText = Remove$(LinkText, Any $Cr+$Lf+$Spc)

      iReturn  = ShellExecute(hDlg, "Open", (LinkText), $Nul, $Nul, %SW_ShowNormal)

   End If

End Function

Sub LoadComboBox

   Local temp$, i As Long

   Open "searchterms.txt" For Binary As #1 : Get$ #1, Lof(1), SearchTerms$ : Close #1

   If Len(SearchTerms$) = 0 Then SearchTerms$ = "Texas" + $CrLf + "Papua New Guinea"

   SearchTerms$ = Trim$(SearchTerms$, Any $CrLf + $Spc)

   SearchTerm$ = Parse$(SearchTerms$,$CrLf,1)

   ComboBox Reset hDlg, %IDC_ComboBox

   Control Set Text hDlg, %IDC_ComboBox, SearchTerm$

   For i = 1 To Min(5,ParseCount(searchterms$,$CrLf))

      ComboBox Insert hDlg, %IDC_ComboBox, i, Parse$(SearchTerms$,$CrLf,i)

   Next i

End Sub

Sub LoadCRMFile

   Local tmp$, temp$, i,iCount As Long

   Open "crm.txt" For Binary As #1 : Get$ #1, Lof(1), temp$ : Close #1

   If Len(Trim$(temp$)) = 0 Then

      temp$ = "Gary Beene" + $CrLf + "Dallas, Texas" + $CrLf + $Delim + $CrLf + "Stuart McLachlan" + $CrLf + "Papua New Guinea"

      Open "crm.txt" For Output As #1 : Print #1, temp$; : Close #1

   End If

   iCount = ParseCount(temp$, $Delim)

   ReDim D(1 To iCount)

   Parse temp$, D(), $Delim

   For i = 1 To iCount

      D(i) = Trim$(D(i), Any $CrLf + $Spc)

      tmp$ = Parse$(D(i),$CrLf,1)

      If Trim$(tmp$) = "" Then ? "Data Issue:" + $CrLf + D(i-1)

   Next i

   ST "Records: " + Format$(iCount,"##,###")

End Sub

Sub DisplayCRMArray

   Local temp$, i As Long

   ListView Reset hDlg, %IDC_ListView

   For i = 1 To UBound(D)

      D(i) = Trim$(D(i))

      ListView Insert Item hDlg, %IDC_ListView, i,0,Parse$(D(i),$CrLf,1)

      ListView Set Text hDlg, %IDC_ListView, i,2,Format$(i)

   Next i

End Sub

Sub Search

   Local temp$, i,iCount As Long

   ListView Reset hDlg, %IDC_ListView

   For i = 1 To UBound(D)

      If InStr(LCase$(D(i)), LCase$(SearchTerm$)) Then

         Incr iCount

         ListView Insert Item hDlg, %IDC_ListView, iCount, 0, Parse$(D(i),$CrLf,1)

         ListView Set Text hDlg, %IDC_ListView, iCount, 2, Format$(i)

      End If

   Next i

   ListView Select hDlg, %IDC_ListView, 1

   ListView_SetItemState hListView, 0, %LVIS_Focused, %LVIS_Focused  '<--- keyboard synchronizing code

   ListView Set Header hDlg, %IDC_ListView, 1, "Matches: " + Format$(iCount) + "   " + $Dq + SearchTerm$ + $Dq

End Sub

Sub Settings_INI(Task$)

   Local x,y,w,h, tempz, INIFileName As WStringZ * %Max_Path, WinPla As WindowPlacement

   'set ini filename

   INIFileName = Exe.Path$ + Exe.Name$ + ".ini"    'get INI file name

   Select Case Task$

      Case "get"

         'get dialog width/height from INI file and use to set Dialog size

         GetPrivateProfileString "All", "Width", "800", w, %Max_Path, INIFileName

         GetPrivateProfileString "All", "Height", "800", h, %Max_Path, INIFileName

         Dialog Set Size hDlg,Val(w), Val(h)   'width/height

         'get dialog top/left from INI file and use to set Dialog location

         Getprivateprofilestring "All", "Left", "0", x, %Max_Path, INIFileName

         Getprivateprofilestring "All", "Top", "0",  y,  %Max_Path, INIFileName

         If IsFile(INIFileName) Then Dialog Set Loc hDlg, Val(x), Val(y)   'left/top but only once INIFileName exists

         'get value for string variables

         GetPrivateProfileString "All", "RESearchTerm", "TWC", RESearchTerm, %Max_Path, INIFileName

         'get value for numeric variables

         Getprivateprofilestring "All", "Minimized", "0", tempz, %Max_Path, INIFileName   : Minimized = Val(tempz)

         Getprivateprofilestring "All", "Maximized", "0", tempz, %Max_Path, INIFileName   : Maximized = Val(tempz)

         Getprivateprofilestring "All", "CFN", "1",       tempz, %Max_Path, INIFileName   : CFN = Val(tempz)

         Getprivateprofilestring "All", "Mute", "0",      tempz, %Max_Path, INIFileName   : Mute = Val(tempz)

         Getprivateprofilestring "All", "BackupNumber", "0",      tempz, %Max_Path, INIFileName   : BackupNumber = Val(tempz)

      Case "save"

         If IsFile(INIFileName) Then Kill INIFileName    'clear the INI file Name to remove residual entries before saving

         WinPla.Length = SizeOf(WinPla)

         GetWindowPlacement hDlg, WinPla

         WritePrivateProfileString "All", "Left", Str$(WinPla.rcNormalPosition.nLeft), INIFileName

         WritePrivateProfileString "All", "Top", Str$(WinPla.rcNormalPosition.nTop), INIFileName

         WritePrivateProfileString "All", "Width", Str$(WinPla.rcNormalPosition.nRight - WinPla.rcNormalPosition.nLeft), INIFileName

         WritePrivateProfileString "All", "Height", Str$(WinPla.rcNormalPosition.nBottom - WinPla.rcNormalPosition.nTop), INIFileName

         'save string variables

         WritePrivateProfileString "All", "RESearchTerm", RESearchTerm, INIFileName

         'save numeric variables

         Minimized = IsIconic(hDlg)

         Maximized = IsZoomed(hDlg)

         WritePrivateProfileString "All", "Minimized", Str$(Minimized), INIFileName

         WritePrivateProfileString "All", "Maximized", Str$(Maximized), INIFileName

         WritePrivateProfileString "All", "CFN", Str$(CFN), INIFileName

         WritePrivateProfileString "All", "Mute", Str$(Mute), INIFileName

         WritePrivateProfileString "All", "BackupNumber", Str$(BackupNumber), INIFileName

   End Select

End Sub

Sub SaveCFN

   Local temp$

   Control Get Text hDlg, %IDC_RichEdit To temp$

   If InStr(temp$, $Delim) Then ? "Cannot Save!" : Exit Sub

   D(CFN) = temp$

   Open "crm.txt" For Output As #1 : Print #1, Join$(D(), $CrLf + $Delim + $CrLf); : Close #1

   ListView Set Text hDlg, %IDC_ListView, CFN, 1, Parse$(D(CFN),$CrLf,1)

   SetFocus hRichEdit

End Sub

Sub ShowAll

   Control Set Text hDlg, %IDC_RichEdit, Join$(D(),$CrLf + $Delim + $CrLf)

   SendMessage hRichEdit, %EM_SetSel, 0, 0

   SetFocus hRichEdit

End Sub

Sub SaveAll

   Local temp$

   If MsgBox("Update All CRM Data?", %MB_YesNo Or %MB_IconQuestion Or %MB_TaskModal, "Update CRM") = %IdYes Then

      Control Get Text hDlg, %IDC_RichEdit To temp$

      temp$ = Trim$(temp$, Any $CrLf + " +")

      Open "crm.txt" For Output As #1

      Print #1, temp$;

      Close #1

      LoadCRMFile       'create D() from CRM.txt

      DisplayCRMArray   'put D() into LV

   End If

End Sub

Sub sBeep

   If Mute Then Exit Sub

   WinBeep(275,150)

End Sub

Sub BuildAcceleratorTable

   Local ac() As ACCELAPI, hAccelerator As Dword, c As Long  ' for keyboard accelator table values

   Dim ac(10)

   ac(c).fvirt = %FVIRTKEY Or %FCONTROL : ac(c).key   = %VK_Delete : ac(c).cmd = %IDT_Delete          : Incr c

   ac(c).fvirt = %FVIRTKEY Or %FCONTROL : ac(c).key   = %VK_D : ac(c).cmd = %IDT_InsertDate        : Incr c

   ac(c).fvirt = %FVIRTKEY Or %FCONTROL : ac(c).key   = %VK_E : ac(c).cmd = %IDT_ShowAll           : Incr c

   ac(c).fvirt = %FVIRTKEY Or %FCONTROL : ac(c).key   = %VK_F : ac(c).cmd = %IDT_SearchDown        : Incr c

   ac(c).fvirt = %FVIRTKEY Or %FCONTROL : ac(c).key   = %VK_I : ac(c).cmd = %IDT_InsertDelimiter   : Incr c

   ac(c).fvirt = %FVIRTKEY Or %FCONTROL : ac(c).key   = %VK_R : ac(c).cmd = %IDT_SetFocusRE        : Incr c

   ac(c).fvirt = %FVIRTKEY Or %FCONTROL : ac(c).key   = %VK_M : ac(c).cmd = %IDT_Mute              : Incr c

   ac(c).fvirt = %FVIRTKEY Or %FCONTROL : ac(c).key   = %VK_N : ac(c).cmd = %IDT_NextREDown        : Incr c

   ac(c).fvirt = %FVIRTKEY Or %FCONTROL : ac(c).key   = %VK_S : ac(c).cmd = %IDT_SaveCFN           : Incr c

   ac(c).fvirt = %FVIRTKEY Or %FCONTROL Or %FSHIFT : ac(c).key = %VK_F : ac(c).cmd = %IDT_SearchUp : Incr c

   ac(c).fvirt = %FVIRTKEY Or %FCONTROL Or %FSHIFT : ac(c).key = %VK_S : ac(c).cmd = %IDT_SaveAll  : Incr c

   Accel Attach hDlg, AC() To hAccelerator

End Sub

Sub InsertDelimiter

   Clipboard Reset

   Clipboard Set Text $CrLf + $Delim + $CrLf + $CrLf

   SendMessage hRichEdit, %WM_Paste, 0, 0

End Sub

Sub InsertDate

   Clipboard Reset

   Clipboard Set Text $CrLf + "Discussion: " + Date$ + "  " + Time$ + "  ---------" + $CrLf + $CrLf

   SendMessage hRichEdit, %WM_Paste, 0, 0

End Sub

'Sub SortData

'   Array Sort D(1)

'   Open "crm.txt" For Output As #1 : Print #1, Join$(D(), $CrLf + $Delim + $CrLf); : Close #1

'   LoadCRMFile       'create D() from CRM.txt

'   DisplayCRMArray   'put D() into LV

'End Sub

Sub AddSearchTerm

   Local i As Long

   'If SearchTerm alread in use, do nothing

   For i = 1 To Min(5,ParseCount(SearchTerms$,$CrLf))

      If LCase$(Parse$(SearchTerms$,$CrLf,i)) = LCase$(SearchTerm$) Then Exit Sub

   Next i

   'If new search term, add it top of the list of SearchTerms$

   SearchTerms$ = SearchTerm$ + $CrLf + SearchTerms$

   SearchTerms$ = Trim$(SearchTerms$, Any $CrLf + $Spc)

   Open "searchterms.txt" For Output As #1 : Print #1, SearchTerms$; : Close #1

   LoadComboBox

End Sub

Sub SaveBackup

   Local temp$

   temp$ = Time$

   Replace  ":" With "." In temp$

   Incr BackupNumber

   Open "backup\crm_" + Format$(BackupNumber) + "_" + Date$ + "_" + temp$ + ".txt" For Output As #1

   Print #1, Join$(D(), $CrLf + $Delim + $CrLf); : Close #1

End Sub

Sub FindRE

   GetRESearchTerm

   SearchText RESearchTerm, %FR_Down

End Sub

Function SearchText(ByVal sTextToSearchFor As WString, SearchDirection As Long) As Long

 Local  FindTextText         As FINDTEXTEX

 Local  NextMatch, SelStart, SelEnd As Long

 SendMessage(hRichEdit, %EM_GETSEL, VarPtr(SelStart), VarPtr(SelEnd))

 FindTextText.lpStrText = StrPtr(sTextToSearchFor)

 If SearchDirection = 1 Then

   FindTextText.chrg.cpMin = SelEnd + 1 'Search from current position

   FindTextText.chrg.cpMax = -1         '- till the end

 Else '%FR_UP

   FindTextText.chrg.cpMin = SelStart   'Search from current position

   FindTextText.chrg.cpMax = 0          '- up to the start

 End If

 NextMatch = SendMessage(hRichEdit, %EM_FINDTEXTEX, SearchDirection, VarPtr(FindTextText)) 'Return next match or -1 for no more

 If NextMatch = -1 Then WinBeep(250,300) :Exit Function

 SendMessage(hRichEdit, %EM_SETSEL, FindTextText.chrgText.cpMin, FindTextText.chrgText.cpMax)

End Function

Sub GetRESearchTerm

   Dialog New Pixels, 0, "Search RE",,,200,80, %WS_SysMenu To hDlgI

   Dialog Set Icon hDlgI, "xsearch"

   Control Add TextBox, hDlgI, %IDC_InputTextBox,RESearchTerm, 20,10,160,30

   Control Add Button, hDlgI, %IDC_InputOk, "Ok", 20,50,50,25

   Control Add Button, hDlgI, %IDC_InputCancel, "Cancel", 90,50,90,25

   RESearchTerm = ""

   Dialog Show Modal hdlgI Call hDlgIProc

End Sub

CallBack Function hDlgIProc() As Long

   Select Case Cb.Msg

      Case %WM_Command

         Select Case Cb.Ctl

            Case %IdOk    , %IDC_InputOk     : Control Get Text hDlgI, %IDC_InputTextBox To RESearchTerm : Dialog End hDlgI

            Case %IdCancel, %IDC_InputCancel : Dialog End hDlgI

         End Select

   End Select

End Function

Sub NewCFN

   ReDim Preserve D(1 To UBound(D)+1)

   D(UBound(D)) = "New Entry"

   CFN = UBound(D)

   ListView Insert Item hDlg, %IDC_ListView, CFN, 0, "New Entry " + $CrLf + "Date: " + Date$

   ListView Set Text hDlg, %IDC_ListView, CFN, 2, Format$(CFN)

   ListView Select hDlg, %IDC_ListView, CFN

   ListView_SetItemState hListView, CFN-1, %LVIS_Focused, %LVIS_Focused  '<--- keyboard synchronizing code

   ListView Visible hDlg, %IDC_ListView, CFN

   Control Set Text hDlg, %IDC_RichEdit, D(CFN)

   SetFocus hRichEdit

End Sub

Sub DeleteCFN

   If GetFocus = hListView Then

      'list of all item

      If UBound(D) = 1 Then D(1) = "New Entry" : Exit Sub

      ListView Delete Item hDlg, %IDC_ListView, CFN

      Array Delete D(CFN)

      ReDim Preserve D(UBound(D)-1)

      If CFN > UBound(D) Then CFN = CFN - 1

      Open "crm.txt" For Output As #1 : Print #1, Join$(D(), $CrLf + $Delim + $CrLf); : Close #1

      LoadCRMFile       'create D() from CRM.txt

      DisplayCRMArray   'put D() into LV

   Else

      ? "Delete Allowed Only on Main List"

   End If

End Sub

Sub ST(temp$)

   Statusbar Set Text hDlg, %IDC_StatusBar, 1, 0, temp$

End Sub

gbnotes.png (Size: 63.61 KB / Downloads: 7)

gbLocator

Wed, 03 Sep 2025 05:28:13 +0000

Howdy!

I've continued working on gbLocator, which provides a user interface to Everything for blind and low vision users. I'm up to v4.2.

Web Site: https://newvisionconcepts.com/gblocator/gblocator.htm
Installation File: https://garybeene.com/files/gblocator_setup.exe
Source Code File: https://garybeene.com/files/gblocator.zip

You'll recall that I spoke with David (Everything author) and he encouraged me to post something on his forum. I've just done that and hope to get some feedback from folks on his forum.

Here are gbLocator images - one with the toolbar showing (low vision users) and one with the toolbar hidden (blind users).

startup.png (Size: 58.63 KB / Downloads: 12)

... does this forum allow inline images or just thumbnails that are links to the full size image?

High resolution replacement for Sleep

Mon, 01 Sep 2025 21:33:03 +0000

SleepX()

SleepX() is a high resolution replacement for Sleep.

The principle used has an analogy with HiFi were a class B amplifier is used to get us within a neighbourhood of a desired voltage and then uses a class A amplifier to fine tune. The cost of this approach is much less than using only a class A amplifier, which are expensive.

The class B amplifier analogy uses Sleep and the class A amplifier analogy uses the Performance Counter, which has a resolution of 100ns with Windows 10 and later.

The following code has the SleepX() code and a usage example.

This is a typical output.

Code:
Quarter of a millisecond: .2503 ms

2 seconds: 2.0000003 s

Silly: 1234.0003 ms

1  1.0001 ms

2  2.0001 ms

3  3.0002 ms

4  4.0001 ms

5  5.0002 ms

6  6.0002 ms

7  7.0002 ms

8  8.0001 ms

9  9.0001 ms

10  10 ms

11  11.0002 ms

12  12.0002 ms

13  13.0001 ms

14  14.0001 ms

15  15.0001 ms

16  16.0002 ms

17  17.0002 ms

18  18.0002 ms

19  19.0002 ms

20  20.0001 ms

21  21.0003 ms

22  22.0002 ms

23  23.0001 ms

24  24.0001 ms

25  25 ms

26  26.0002 ms

27  27.0002 ms

28  28.0002 ms

29  29.0002 ms

30  30.0002 ms

The first example looks at a delay of a quarter of a millisecond. I doubt that anyone will have a use for that. The second example looks at a delay of two seconds. The third example looks at a 'silly' delay of 1234ms, The following looks at delays from 1ms to 30ms in steps of 1ms.

All the results have a sub micro accuracy inline with the Performance Counter on Windows 10 and later.

SleepX() has two parts: The first part is used for delays <= to 3ms and only polls the Performance Counter. This is expensive but is a short-lived expense and should not impact on the system performance. The second part uses the construct 'Sleep ( n-3 )' to get us within a neighbourhood of the target delay, and then we poll the Performance Counter to fine tune. 'Sleep ( n-3 )' needs a resolution of 1ms and why we use SetHiRes.

'Sleep ( n-3 )' does not use any CPU load. The CPU load only kicks in when we enter the 'class A' mode, so is an absolute value and should not impact on the system performance.

Why was 'n <= 3'. It is reasonable to expect a 1ms resolution to give a delay of between n ms and n+1 ms. In practice, we can exceed n+1 ms and about one third of delays do just that. It is very rare, but values approaching n+1.5 ms have been seen. To mitigate that issue, 'n <= 3' was chosen.

That is it: A very simple idea to give a high resolution replacement for Sleep with a negligible CPU load.

It is worth noting that

Code:
SetHiRes

RevokeHiRes

is acceptable, but it should not be used within a loop; for example a graphics application with 60, or so, fps. That will upset the system clock. It is better to use SetHiRes at the beginning of an application and RevokeHiRes when the higher resolution is no longer needed. If you forget to use RevokeHiRes SetHiRes will be cancelled when the process terminates. Microsoft neglects to mention that.



Code:
#COMPILE EXE

#DIM ALL

#INCLUDE "win32api.inc"



' SOURCE CODE:



Macro QPC = QueryPerformanceCounter qTimeNow



Macro SetHiRes

  MacroTemp Time

  Dim Time As TIMECAPS

  TimeGetDevCaps( Time, SizeOf(Time) )

  TimeBeginPeriod(Time.wPeriodMin)

  'Sleep 16 ' Pre Windows 10 - high resolution does not 'byte' until next clock tick.

End Macro



Macro RevokeHiRes

  MacroTemp Time

  Dim Time As TIMECAPS

  TimeGetDevCaps( Time, SizeOf(Time) )

  TimeEndPeriod(Time.wPeriodMin)

End Macro



Global qFreq As Quad



Sub SleepX( ByVal n As Double )

  Local qTarget, qTimeNow As Quad

  QPC

  qTarget = qTimeNow + n*qFreq*0.001

  If n <= 3 then

    Do : QPC : Loop Until qTimeNow >= qTarget ' Class A amplifier analogy

  Else

    ' Class B amplifier analogy followed by Classs A amplifier analogy

    Sleep ( n-3 ) : Do : QPC : Loop Until qTimeNow >= qTarget

  End If

End Sub



' ====================



' EXAMPLE USAGE:



Function Pbmain () As Long

Local i as Long

Local qStart, qStop As Quad



  QueryPerformanceFrequency qFreq



  SetHiRes



  QueryPerformanceCounter qStart

    SleepX(0.25)

  QueryPerformanceCounter qStop

  Print "Quarter of a millisecond:";(qStop - qStart)*1000/qFreq;"ms"

  Print



  QueryPerformanceCounter qStart

    SleepX(2000)

  QueryPerformanceCounter qStop

  Print "2 seconds:";(qStop - qStart)/qFreq;"s"

  Print



  QueryPerformanceCounter qStart

    SleepX(1234)

  QueryPerformanceCounter qStop

  Print "Silly:";(qStop - qStart)*1000/qFreq;"ms"

  Print



  For i = 1 to 30

    QueryPerformanceCounter qStart

      SleepX(i)

    QueryPerformanceCounter qStop

    Print i;" ";(qStop - qStart)*1000/qFreq;"ms"

  Next



  RevokeHiRes



  WaitKey$



End Function



PB 3.5 8-to-7 Bit Text Compression
Thu, 03 Apr 2025 21:55:44 +0000
Hello everyone, 

I developed a method to compress short texts by reducing 8-bit characters to 7-bit. While the compression ratio is low for large files, it efficiently reduces small strings.  



Key Steps:  

Normalization: The input text is restricted to 7-bit ASCII (32–127).


Offset Adjustment: Each character is decremented by 32 to fit within 0–95. 


Compression: 

For every 8 bytes, extract bits 0–6 (discarding bit 7).Pack these 7-bit segments into 7 bytes, using all 8 bits per byte. 


Remaining Bytes: If the text length isn’t a multiple of 8, the last 1–7 bytes are copied uncompressed.


Decompression: 

Reverse the process: Expand 7-bit segments to 8 bits, then increment by 32. 





Here is the code, including some testing:



Code:
$Compile exe

$Dim All

$Lib All Off

$Error All Off

$String 2

$Com 0

$Float Procedure

$Optimize Size'Speed

$Cpu 80386

$Sound 1

$Stack 1536





'----------------------------------------------------------------------------

' Packe limitierten Text von 8 auf 7 Bit.

' Nutze dafür Zeiger zum Erhöhen der Geschwindigkeit

Declare _

FUNCTION PackTxt87 (sQuelle AS STRING) AS STRING

FUNCTION PackTxt87 (sQuelle AS STRING) AS STRING

  ' lokale Variablen

  DIM iQlen  AS LOCAL INTEGER          ' Länge von sQuelle

  DIM Q_ptr  AS LOCAL BYTE PTR         ' Zeichen-Pointer auf sQuelle

  Dim sZiel  As Local String           ' Komprimiertes sZiel

  DIM iZlen  AS LOCAL INTEGER          ' Länge von sZiel

  DIM Z_ptr  AS LOCAL BYTE PTR         ' Zeichen-Pointer auf sZiel

  DIM iZPos  AS LOCAL INTEGER          ' Position in sZiel

  DIM iQPos  AS LOCAL INTEGER          ' Position in sQuelle

  DIM iQLoop AS LOCAL INTEGER          ' Anzahl KompressionsSchleifen

  DIM iKompS AS LOCAL INTEGER          ' Anzahl komprimierbarer Zeichen

  Dim iRest  As Local Integer          ' Anzahl unkomprimierbarer Zeichen

  Dim bWert  As Local Byte             ' ASCII-32-Wert eines Zeichens.

  Dim iBitQ  As Local Integer          ' Aktuelle Bitbosition in sQuelle

  Dim iBitZ  As Local Integer          ' Aktuelle Bitbosition in sZiel

  Dim sTemp  As Local String



                                       '

  iQlen = LEN(sQuelle)                 ' Hole Länge der Quelle



  '--------------------------------------------------------------------------

  ' Fehler 1 abfangen

  If iQlen < 8 Then _                  ' String zu kurz?

    Function = sQuelle: _              ' Gib Original zurück

    Exit Function                      ' und raus



  iQLoop  = Fix(iQlen/8)               ' Hole Anzahl KompressionsSchleifen

  iRest  = iQlen Mod 8                 ' Hole Anzahl unkomprimierbarer Zeichen

  iKompS = iQLoop * 8                  ' Hole Anzahl komprimierbarer Zeichen

  iZlen  = iQLoop * 7 + iRest          ' Hole Länge komprimierten Strings

                                       '

  DECR iQlen                           ' Null-basiert für Pointer

  Q_ptr = STRPTR32( sQuelle )          ' Setze Pointer auf sQuelle



  '--------------------------------------------------------------------------

  ' Fehler 2 abfangen

  For iQPos = 0 To iQlen               ' Überprüfe auf ungültige Zeichen

    IF @Q_ptr[iQPos] < 32 _

      Or @Q_ptr[iQPos] > 159 _

      THEN

      sZiel = sZiel _                  ' sammle diese 

            + Chr$(@Q_ptr[iQPos])

    End If

  Next iQPos



  If Len(sZiel) Then _

    Function = "Falsche Quelle: "+sZiel : _

    Exit Function                      ' und gib sie zurück



  sZiel = Repeat$(iZlen,Chr$(0))       ' Platz für Kompression in sZiel



  Z_ptr = STRPTR32( sZiel  )           ' Setze Pointer auf sZiel

  iZPos = 0                            ' Position im Pointer = 0

  iBitQ = 0                            ' Bitbosition in sQuelle auf 0

  iBitZ = 0                            ' Bitbosition in sZiel  auf 0



  DECR iKompS                          ' Null-basiert für Pointer



  '--------------------------------------------------------------------------

  ' Kompression:

  For iQPos = 0 To iKompS              ' Für komprimierbare Zeichen in sQuelle:

                                       ' 1. Schritt:

    bWert = @Q_ptr[iQPos] - 32         ' ASCII-Wert um 32 vermindern, dass

                                       ' ASCII zwischen 0-159 ist

    For iBitQ = 0 To 6                 ' Lies aus sQuelle Bit 0-6



      If Bit(bWert,iBitQ) = 1 Then     ' Schreibe Ziel-Bits 0-7

        Bit Set @Z_ptr[iZPos], iBitZ   '

      Else                             '

        Bit ReSet @Z_ptr[iZPos], iBitZ '

      End If



      If iBitZ < 7 Then                ' Solange in Ziel zwischen Bit 0 und 7

        Incr iBitZ                     ' Nächstes Bit

      Else                             ' sonst

        iBitZ = 0                      ' Bit 0 in

        Incr iZPos                     ' nächstem Zeichen

      End If

    Next iBitQ

  Next iQPos



  iZPos = iZlen-iRest                  ' Setze Zeiger auf erstes unpackbares

                                       ' Zeichen

  For iQPos = iQlen-iRest+1 To iQlen   ' Für unpackbare Zeichen in sQuelle

    @Z_ptr[iZPos] = @Q_ptr[iQPos]      ' Schreibe unpackbare Zeichen

    Incr iZPos

  Next iQPos





  Function = sZiel



END FUNCTION





'----------------------------------------------------------------------------

' EntPacke limitierten Text von 8 auf 7 Bit.

' Nutze dafür Zeiger zum Erhöhen der Geschwindigkeit

Declare _

FUNCTION DePackTxt87 (sQuelle AS STRING) AS STRING

FUNCTION DePackTxt87 (sQuelle AS STRING) AS STRING

  ' lokale Variablen

  DIM iQlen  AS LOCAL INTEGER          ' Länge von sQuelle

  DIM Q_ptr  AS LOCAL BYTE PTR         ' Zeichen-Pointer auf sQuelle

  Dim sZiel  As Local String           ' Komprimiertes sZiel

  DIM iZlen  AS LOCAL INTEGER          ' Länge von sZiel

  DIM Z_ptr  AS LOCAL BYTE PTR         ' Zeichen-Pointer auf sZiel

  DIM iZPos  AS LOCAL INTEGER          ' Position in sZiel

  DIM iQPos  AS LOCAL INTEGER          ' Position in sQuelle

  DIM iQLoop AS LOCAL INTEGER          ' Anzahl KompressionsSchleifen

  DIM iKompS AS LOCAL INTEGER          ' Anzahl komprimierbarer Zeichen

  Dim iRest  As Local Integer          ' Anzahl unkomprimierbarer Zeichen

  Dim bWert  As Local Byte             ' ASCII-32-Wert eines Zeichens.

  Dim iBitQ  As Local Integer          ' Aktuelle Bitbosition in sQuelle

  Dim iBitZ  As Local Integer          ' Aktuelle Bitbosition in sZiel

  Dim sTemp  As Local String

  Dim bPack  As Local Byte             ' Gepackte Bytes an sQuelleEnde



  iQlen = LEN(sQuelle)                 ' Hole Länge der Quelle



  '--------------------------------------------------------------------------

  ' Fehler 1 abfangen

  If iQlen < 7 Then _                  ' String zu kurz?

    Function = sQuelle: _              ' Gib Original zurück

    Exit Function                      ' und raus



  Q_ptr = STRPTR32( sQuelle )          ' Setze Pointer auf sQuelle



  iQLoop  = Fix(iQlen/7)               ' Hole Anzahl EntPacksSchleifen

  iRest  = iQlen Mod 7                 ' Anzahl ungepackte Zeichen?



  '--------------------------------------------------------------------------

  ' Fehler 2 abfangen



If iRest = 0 Then                      ' Scheint alles gepackt zu sein, dann

  bPack = 0                            ' GePacktes = 0

  For iQPos = iQlen - 7 To iQlen-1     ' Überprfe letzte 7 Zeichen auf

    IF @Q_ptr[iQPos] < 32 _            ' komprimierte Zeichen

      Or @Q_ptr[iQPos] > 127 _         ' Wenn welche da, dann

      THEN Incr bPack                  ' Erhöhe Gepacktes (bPack)

  Next iQPos

End If





  If bPack = 0? _                      ' Wenn keine gepackten Zeichen (bPack)

    And iRest = 0 _                    ' und keine ungepackten Zeichen (iRest)

    Then                               ' dann

    iRest = 7                          ' ungepackte Zeichen (iRest) = 7

    iKompS = iQlen - iRest             ' Setze Anzahl entpackbarer Zeichen

  Else                                 ' sonst

    iKompS = iQLoop * 7                ' Setze Anzahl entpackbarer Zeichen

  End If





  If IsFalse(bPack) _                  ' Sind die iRest-lichen Zeichen

    And iRest = 7 _                    ' ungepackt, dann reduziere

    Then Decr iQLoop                   ' die Anzahl der Entpackaufrufe





  iZlen  = iQLoop * 8 + iRest          ' Hole Länge komprimierten Strings

                                       '

  DECR iQlen                           ' Null-basiert für Pointer



  sZiel = Repeat$(iZlen,Chr$(0))       ' Platz für Kompression in sZiel



  Z_ptr = STRPTR32( sZiel  )           ' Setze Pointer auf sZiel

  iZPos = 0                            ' Position im Pointer = 0

  iBitQ = 0                            ' Bitbosition in sQuelle auf 0

  iBitZ = 0                            ' Bitbosition in sZiel  auf 0



  '--------------------------------------------------------------------------

  ' DeKompression: Rechne Zeichen in sQuelle auf ASCII 32-159 um

  For iQPos = 0 To iKompS              ' Fr entkomprimierbare Zeichen in sQuelle:

                                       ' 1. Schritt:

    For iBitQ = 0 To 7                 ' Lies aus sQuelle Bit 0-7



      If Bit(@Q_ptr[iQPos],iBitQ) = 1 Then ' Schreibe Ziel-Bits 0-7

        Bit Set @Z_ptr[iZPos], iBitZ   '

      Else                             '

        Bit ReSet @Z_ptr[iZPos], iBitZ '

      End If



      If iBitZ < 6 Then                ' Solange in Ziel zwischen Bit 0 und 6

        Incr iBitZ                     ' Nächstes Bit

      Else                             ' sonst

        iBitZ = 0                      ' Bit 0

        Incr @Z_ptr[iZPos], 32         ' Erstelle das richtige ZielZeichen

        Incr iZPos                     ' und nächstes ZielZeichen

      End If



    Next iBitQ



  Next iQPos



  iZPos = iZlen-iRest                  ' Setze Zeiger auf erstes unpackbares

                                       ' Zeichen

  For iQPos = iQlen-iRest+1 To iQlen   ' Für ungepackte Zeichen in sQuelle

    @Z_ptr[iZPos] = @Q_ptr[iQPos]      ' Schreibe ungepackte Zeichen

    Incr iZPos

  Next iQPos





  Function = sZiel



END FUNCTION





' Test-Code'



DIM originalText AS STRING, _

    compressedText AS STRING, _

    decompressedText AS STRING, _

    iIndex As Integer, _

    iLOrg  As Integer, _

    iLPck  As Integer, _

    iLEpk  As Integer



For iIndex = 07 To 19

  '?

  originalText = Left$("PowerBASIC 3.5 is a wonderful tool for writing fast and usefull programs.",iIndex)



  iLOrg = Len(originalText)

  compressedText = PackTxt87(originalText)

  iLPck = Len(compressedText)

  If Instr(compressedText, "Falsche Quelle: ") = 1 Then ?compressedText:end

  decompressedText = DePackTxt87(compressedText)

  iLEpk = Len(decompressedText)

  'PRINT "Original:      ";

  PRINT "Original: ";

  Print originalText;

  $If 0

  Print " ist =";iLOrg;" Byte lang"

  PRINT "Komprimiert:  ";

  Print compressedText;

  Print " ist =";iLPck;" Byte lang"

  PRINT "Dekomprimiert: ";

  Print decompressedText;

  Print " ist =";iLEpk;" Byte lang"

  $EndIf

  ? " --> Test verlief: [erfolg";

  If originalText = decompressedText Then

    Print "reich] :-)  :";iLOrg;iLPck;iLEpk

  Else

  Print "los] ;-(";iLOrg;iLPck;iLEpk

  ?"Original und wieder Entpacktes unterscheiden sich an folgenden Stellen:"

  For iIndex = 1 To iLOrg

    If ASCII(originalText,iIndex) <> ASCII(decompressedText,iIndex) Then

        ?"Position";iIndex;" - Zeichen Original: ";Chr$(ASCII(originalText,iIndex)); _

        " - Zeichen Entpackt: ";Chr$(ASCII(decompressedText,iIndex))

      End If

    Next iIndex

  End If



Next iIndex



Sleep



originalText = "PowerBASIC 3.5 is a wonderful tool for writing fast, small and usefull programs under DOS."

iLOrg = Len(originalText)

compressedText = PackTxt87(originalText)

iLPck = Len(compressedText)

If Instr(compressedText, "Falsche Quelle: ") = 1 Then ?compressedText:end

decompressedText = DePackTxt87(compressedText)

iLEpk = Len(decompressedText)

  

  PRINT "Original:"

  Print originalText;

  ? " --> Test verlief: [erfolg";

  If originalText = decompressedText Then

    Print "reich] :-)  :";iLOrg;iLPck;iLEpk

  Else

  Print "los] ;-(";iLOrg;iLPck;iLEpk

  ?"Original und wieder Entpacktes unterscheiden sich an folgenden Stellen:"

  For iIndex = 1 To iLOrg

    If ASCII(originalText,iIndex) <> ASCII(decompressedText,iIndex) Then

        ?"Position";iIndex;" - Zeichen Original: ";Chr$(ASCII(originalText,iIndex)); _

        " - Zeichen Entpackt: ";Chr$(ASCII(decompressedText,iIndex))

      End If

    Next iIndex

  End If

  

  PRINT "Komprimiert:"

  Print compressedText

  Print "ist =";iLPck;" Byte lang"

  PRINT "Dekomprimiert:"

  Print decompressedText

  Print "ist =";iLEpk;" Byte lang"







originalText = "PowerBASIC 3.5 ist ein wundervolles Werkzeug fr schnelle, kleine bis groáe und vor allen ¯ntzliche® Programme unter DOS."

?originalText

iLOrg = Len(originalText)

compressedText = PackTxt87(originalText)

iLPck = Len(compressedText)

If Instr(compressedText, "Falsche Quelle: ") = 1 Then ?compressedText:end

decompressedText = DePackTxt87(compressedText)

iLEpk = Len(decompressedText)

  

  PRINT "Original:"

  Print originalText;

  ? " --> Test verlief: [erfolg";

  If originalText = decompressedText Then

    Print "reich] :-)  :";iLOrg;iLPck;iLEpk

  Else

  Print "los] ;-(";iLOrg;iLPck;iLEpk

  ?"Original und wieder Entpacktes unterscheiden sich an folgenden Stellen:"

  For iIndex = 1 To iLOrg

    If ASCII(originalText,iIndex) <> ASCII(decompressedText,iIndex) Then

        ?"Position";iIndex;" - Zeichen Original: ";Chr$(ASCII(originalText,iIndex)); _

        " - Zeichen Entpackt: ";Chr$(ASCII(decompressedText,iIndex))

      End If

    Next iIndex

  End If

  

  PRINT "Komprimiert:"

  Print compressedText

  Print "ist =";iLPck;" Byte lang"

  PRINT "Dekomprimiert:"

  Print decompressedText

  Print "ist =";iLEpk;" Byte lang"




This is the DOS-output:

Code:
Original: PowerBA --> Test verlief: [erfolgreich] :-)  : 7  7  7

Original: PowerBAS --> Test verlief: [erfolgreich] :-)  : 8  7  8

Original: PowerBASI --> Test verlief: [erfolgreich] :-)  : 9  8  9

Original: PowerBASIC --> Test verlief: [erfolgreich] :-)  : 10  9  10

Original: PowerBASIC  --> Test verlief: [erfolgreich] :-)  : 11  10  11

Original: PowerBASIC 3 --> Test verlief: [erfolgreich] :-)  : 12  11  12

Original: PowerBASIC 3. --> Test verlief: [erfolgreich] :-)  : 13  12  13

Original: PowerBASIC 3.5 --> Test verlief: [erfolgreich] :-)  : 14  13  14

Original: PowerBASIC 3.5  --> Test verlief: [erfolgreich] :-)  : 15  14  15

Original: PowerBASIC 3.5 i --> Test verlief: [erfolgreich] :-)  : 16  14  16

Original: PowerBASIC 3.5 is --> Test verlief: [erfolgreich] :-)  : 17  15  17

Original: PowerBASIC 3.5 is  --> Test verlief: [erfolgreich] :-)  : 18  16  18

Original: PowerBASIC 3.5 is a --> Test verlief: [erfolgreich] :-)  : 19  17  19



Original:PowerBASIC 3.5 is a wonderful tool for writing fast, small and usefull

programs under DOS. --> Test verlief: [erfolgreich] :-)  : 90  79  90

Komprimiert:

░τ╡(§àf⌐◄`Γ¿ ÆS@►p}:ëE⌐▒╩♦PƒO&└°ö☻«╥$5Θ<☻î┴)ò☺ÿ6âL& Φ$☻¬╙ó▒╩d☻á╥τQ→lN☺U'▒(♣É^S.

ist = 79  Byte lang

Dekomprimiert:

PowerBASIC 3.5 is a wonderful tool for writing fast, small and usefull programs

under DOS.

ist = 90  Byte lang

PowerBASIC 3.5 ist ein wundervolles Werkzeug für schnelle, kleine bis große und

vor allen »nützliche« Programme unter DOS. 

Falsche Quelle: ß»« 
 

Perhaps the code will also be of use to others...


Leap days (or not) in February for PBDOS
Sat, 08 Mar 2025 07:48:07 +0000
'DECLARE not needed if FUNCTION source is before the CALL

'here the CALL is in PBMAIN

'I call it bottom up because PBMAIN is last and flow goes up

'

'Pretty sure PUSHes and POPs not needed in FUNCTION

'They will be needed to use "inside" code in-line with BASIC

'

'Used PBCC v6 to test. I no longer have PBDOS available.

function Tage_im_Februar(byval iJahr as integer) as integer

  local FebruarTage as integer

  ! push ax

  ! mov FebruarTage, 28&  'not a leap year, pre-set to 28

  ! mov ax, 1582%

  ! cmp ax, iJahr

  ! jge Julian

  ! mov ax, 3%

  ! and ax, iJahr    'conditionally equivalent MOD 4

  ! jz MOD100        '0 is possible leap year

  ! jmp Done

  MOD100:

  ! push bx          'for divisor

  ! push dx          'for high part of dividend, remainder (MOD)

  ! xor dx, dx

  ! mov ax, iJahr

  ! mov bx, 100%

  ! div bx

  ! cmp dx, 0%    'does MOD 100 = 0 ?

  ! pop dx

  ! pop bx

  ! jz MOD400        '0 is possibly not a leap year

  ! jmp Is29Days      'non 0 is a leap year

  MOD400:

  ! and ax, 3%    'EAX has Year\100, so conditionally equivalent MOD 400

  ! jnz Done

  Julian:

  ! mov ax, 3%

  ! and ax, iJahr

  ! jnz Done

  Is29Days:

  ! mov FebruarTage, 29%

  Done:

  ! pop ax

  function = FebruarTage

end function

function pbmain () as long 'put only to demonstrate Tage_im_Februar

  local iJahr as integer

  iJahr = 2000

  print Tage_im_Februar(iJahr); " 2000, divisible by 400, is leap"

  iJahr = 2100

  print Tage_im_Februar(iJahr); " 2100, divisible by 100 not 400, not leap"

  iJahr = 2104

  print Tage_im_Februar(iJahr); " 2104, divisible by 4 not 100, is leap"

  iJahr = 2103

  print Tage_im_Februar(iJahr); " 2103, not divide 4, not leap

  print "julian, did not check rule for prior to Gregorian myself"

  iJahr = 1204

  print Tage_im_Februar(iJahr); " 1204, divisible by 4, is leap

  iJahr = 1201

  print Tage_im_Februar(iJahr)  " 1201, not divisible by 4, not leap

  waitkey$

end function


Detect QEMU Virtual Machine
Wed, 29 Jan 2025 20:39:50 +0000
This program will detect if it is being run in a QEMU  Virtual Machine VM.

Note that hackers will place your programs to run in a VM so that they can

pirate or hack your programs.  



This is to detect whether the user is using a QEMU  VM and to do the 

necessary counter action.   



Please let me know if you encounter issue with this program.



Code:
  ' Detect QEMU.bas





 '   This program uses multiple detection methods for QEMU VM to increase accuracy.

 '   However, no single method is foolproof, as virtualization environments

 '   can be customized or masked by hackers.



    #COMPILE EXE

    #DIM ALL

    #INCLUDE "Win32Api.inc"



     %KEY_QUERY_VALUE     = &H0001

     %ERROR_SUCCESS       = 0









 '============================

  FUNCTION PBMAIN () AS LONG

    IF IsQEMU() THEN

        ? "Running inside a QEMU virtual machine."

    ELSE

        ? "Not running inside a QEMU virtual machine."

    END IF

 END FUNCTION











'===============================

'   Detects QEMU VM using several methods

FUNCTION IsQEMU() AS LONG

    LOCAL hqeKey  AS DWORD

    LOCAL dwType  AS DWORD

    LOCAL dwData  AS DWORD

    LOCAL cbData  AS DWORD

    LOCAL qresult AS LONG



  ' Indicator for various QEMU types

    LOCAL tmpQe   AS LONG

    tmpQe = 0



    ' Check for QEMU-specific registry key (System Manufacturer)

    ' HARDWARE\DESCRIPTION\System\BIOS

    qresult = RegOpenKeyEx(%HKEY_LOCAL_MACHINE, hwBios, 0, %KEY_QUERY_VALUE, hqeKey)

    IF qresult = %ERROR_SUCCESS THEN

        cbData = 256

      ' SystemManufacturer

        qresult = RegQueryValueEx(hqeKey, SysManf , 0, dwType, BYVAL VARPTR(dwData), cbData)

         IF qresult = %ERROR_SUCCESS THEN

            'QEMU

            IF INSTR(UCASE$(PEEK$(VARPTR(dwData), cbData)), StQE) > 0 THEN

                tmpQe = 1

            END IF

        END IF

        RegCloseKey hqeKey

    END IF



    IF tmpQe > 0 THEN

       IsQEMU = 1

       EXIT FUNCTION

    END IF





    ' Check for QEMU-specific driver (qxl.sys or virtio drivers)

    ' such as QXL video adapter or VirtIO devices

    ' C:\Windows\System32\drivers\qxl.sys       and

    ' C:\Windows\System32\drivers\vioinput.sys

    IF ISFILE(qxlS ) OR ISFILE(vioinp) THEN

        tmpQe = 2

    END IF



    IF tmpQe > 0 THEN

       IsQEMU = 1

       EXIT FUNCTION

    END IF



    ' Check for QEMU-specific hardware (QXL video or VirtIO devices)

    ' C:\Windows\System32\drivers\qxl.dll    and

    ' C:\Windows\System32\drivers\viostor.sys

    IF ISFILE(stQxl) OR ISFILE(stVio) THEN

        tmpQe = 3

    END IF



    IF tmpQe > 0 THEN

       IsQEMU = 1

       EXIT FUNCTION

    END IF



  ' Not running inside QEMU

    IsQEMU = 0

END FUNCTION











 ' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤

 '    C:\Windows\System32\drivers\vioinput.sys

FUNCTION vioinp() AS STRING



  ' Text is 40 bytes excluding the terminating zero



    #REGISTER NONE



    LOCAL src  AS DWORD

    LOCAL dst  AS DWORD

    LOCAL outpt$



    src = CODEPTR(datalabel)



    outpt$ = NUL$(40)

    dst = STRPTR(outpt$)



  ' -------------------

  ' copy data to string

  ' -------------------

    ! mov esi, src

    ! mov edi, dst

    ! mov ecx, 40

    ! rep movsb



    src = CODEPTR(paddlabel)



  ' -----------------------------

  ' xor string data to unique pad

  ' -----------------------------

    ! mov esi, dst

    ! mov ebx, 40

    ! mov edi, src

    ! add esi, ebx

    ! add edi, ebx

    ! neg ebx



  lbl0:

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jz lbl1

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jz lbl1

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jz lbl1

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jnz lbl0



  lbl1:

    FUNCTION = outpt$

    EXIT FUNCTION



  #ALIGN 4

  datalabel:

    ! db 137,244,134,19,90,252,4,157,27,48,199,3,14,247,228,3

    ! db 175,250,190,186,216,209,84,46,134,104,244,174,243,136,210,100

    ! db 103,146,120,43,36,182,157,78,0



  #ALIGN 4

  paddlabel:

    ! db 202,206,218,68,51,146,96,242,108,67,155,80,119,132,144,102

    ! db 194,201,140,230,188,163,61,88,227,26,135,242,133,225,189,13

    ! db 9,226,13,95,10,197,228,61,0



END FUNCTION



' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤







' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤

   '  C:\Windows\System32\drivers\qxl.sys

FUNCTION qxlS() AS STRING



  ' Text is 35 bytes excluding the terminating zero



    #REGISTER NONE



    LOCAL src  AS DWORD

    LOCAL dst  AS DWORD

    LOCAL outpt$



    src = CODEPTR(datalabel)



    outpt$ = NUL$(35)

    dst = STRPTR(outpt$)



  ' -------------------

  ' copy data to string

  ' -------------------

    ! mov esi, src

    ! mov edi, dst

    ! mov ecx, 35

    ! rep movsb



    src = CODEPTR(paddlabel)



  ' -----------------------------

  ' xor string data to unique pad

  ' -----------------------------

    ! mov esi, dst

    ! mov ebx, 35

    ! mov edi, src

    ! add esi, ebx

    ! add edi, ebx

    ! neg ebx



  lbl0:

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jz lbl1

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jz lbl1

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jz lbl1

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jnz lbl0



  lbl1:

    FUNCTION = outpt$

    EXIT FUNCTION



  #ALIGN 4

  datalabel:

    ! db 39,193,199,194,34,252,156,45,109,153,235,30,232,30,74,199

    ! db 100,250,27,119,124,175,212,177,7,207,147,66,236,149,73,81

    ! db 143,69,39,0



  #ALIGN 4

  paddlabel:

    ! db 100,251,155,149,75,146,248,66,26,234,183,77,145,109,62,162

    ! db 9,201,41,43,24,221,189,199,98,189,224,30,157,237,37,127

    ! db 252,60,84,0



END FUNCTION



' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤











' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤

 'C:\Windows\System32\drivers\qxl.dll

FUNCTION stQxl() AS STRING



  ' Text is 35 bytes excluding the terminating zero



    #REGISTER NONE



    LOCAL src  AS DWORD

    LOCAL dst  AS DWORD

    LOCAL outpt$



    src = CODEPTR(datalabel)



    outpt$ = NUL$(35)

    dst = STRPTR(outpt$)



  ' -------------------

  ' copy data to string

  ' -------------------

    ! mov esi, src

    ! mov edi, dst

    ! mov ecx, 35

    ! rep movsb



    src = CODEPTR(paddlabel)



  ' -----------------------------

  ' xor string data to unique pad

  ' -----------------------------

    ! mov esi, dst

    ! mov ebx, 35

    ! mov edi, src

    ! add esi, ebx

    ! add edi, ebx

    ! neg ebx



  lbl0:

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jz lbl1

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jz lbl1

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jz lbl1

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jnz lbl0



  lbl1:

    FUNCTION = outpt$

    EXIT FUNCTION



  #ALIGN 4

  datalabel:

    ! db 107,242,156,222,105,186,235,71,251,111,207,178,223,54,223,160

    ! db 48,66,192,5,85,78,114,228,105,10,125,30,253,8,13,29

    ! db 29,250,74,0



  #ALIGN 4

  paddlabel:

    ! db 40,200,192,137,0,212,143,40,140,28,147,225,166,69,171,197

    ! db 93,113,242,89,49,60,27,146,12,120,14,66,140,112,97,51

    ! db 121,150,38,0



END FUNCTION



' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤





' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤

   '   C:\Windows\System32\drivers\viostor.sys

FUNCTION stVio() AS STRING



  ' Text is 39 bytes excluding the terminating zero



    #REGISTER NONE



    LOCAL src  AS DWORD

    LOCAL dst  AS DWORD

    LOCAL outpt$



    src = CODEPTR(datalabel)



    outpt$ = NUL$(39)

    dst = STRPTR(outpt$)



  ' -------------------

  ' copy data to string

  ' -------------------

    ! mov esi, src

    ! mov edi, dst

    ! mov ecx, 39

    ! rep movsb



    src = CODEPTR(paddlabel)



  ' -----------------------------

  ' xor string data to unique pad

  ' -----------------------------

    ! mov esi, dst

    ! mov ebx, 39

    ! mov edi, src

    ! add esi, ebx

    ! add edi, ebx

    ! neg ebx



  lbl0:

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jz lbl1

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jz lbl1

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jz lbl1

    ! movzx eax, BYTE PTR [edi+ebx]

    ! xor [esi+ebx], al

    ! add ebx, 1

    ! jnz lbl0



  lbl1:

    FUNCTION = outpt$

    EXIT FUNCTION



  #ALIGN 4

  datalabel:

    ! db 249,253,198,251,223,113,140,156,245,139,234,192,79,79,251,90

    ! db 10,141,82,54,82,155,166,16,138,158,122,123,208,158,228,122

    ! db 211,170,16,201,173,76,240,0



  #ALIGN 4

  paddlabel:

    ! db 186,199,154,172,182,31,232,243,130,248,182,147,54,60,143,63

    ! db 103,190,96,106,54,233,207,102,239,236,9,39,166,247,139,9

    ! db 167,197,98,231,222,53,131,0



END FUNCTION



' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤









 ' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤

     '  QEMU

FUNCTION StQE() AS STRING



    #REGISTER NONE



    LOCAL pstr AS DWORD

    LOCAL a$



    a$ = NUL$(4)

    pstr = STRPTR(a$)



    ! mov esi, pstr



    ! mov BYTE PTR [esi+0], 81

    ! mov BYTE PTR [esi+2], 77

    ! mov BYTE PTR [esi+1], 69

    ! mov BYTE PTR [esi+3], 85



    FUNCTION = a$



END FUNCTION



' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤











' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤

  ' SystemManufacturer

FUNCTION SysManf() AS STRING



    #REGISTER NONE



    LOCAL pstr AS DWORD

    LOCAL a$



    a$ = NUL$(18)

    pstr = STRPTR(a$)



    ! mov esi, pstr



    ! mov BYTE PTR [esi+14], 117

    ! mov BYTE PTR [esi+5], 109

    ! mov BYTE PTR [esi+9], 117

    ! mov BYTE PTR [esi+16], 101

    ! mov BYTE PTR [esi+15], 114

    ! mov BYTE PTR [esi+17], 114

    ! mov BYTE PTR [esi+11], 97

    ! mov BYTE PTR [esi+8], 110

    ! mov BYTE PTR [esi+13], 116

    ! mov BYTE PTR [esi+3], 116

    ! mov BYTE PTR [esi+4], 101

    ! mov BYTE PTR [esi+2], 115

    ! mov BYTE PTR [esi+0], 83

    ! mov BYTE PTR [esi+1], 121

    ! mov BYTE PTR [esi+7], 97

    ! mov BYTE PTR [esi+12], 99

    ! mov BYTE PTR [esi+6], 77

    ! mov BYTE PTR [esi+10], 102



    FUNCTION = a$



END FUNCTION



' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤









' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤

   ' HARDWARE\DESCRIPTION\System\BIOS

FUNCTION hwBios() AS STRING



    #REGISTER NONE



    LOCAL pstr AS DWORD

    LOCAL a$



    a$ = NUL$(32)

    pstr = STRPTR(a$)



    ! mov esi, pstr



    ! mov BYTE PTR [esi+28], 66

    ! mov BYTE PTR [esi+29], 73

    ! mov BYTE PTR [esi+27], 92

    ! mov BYTE PTR [esi+17], 73

    ! mov BYTE PTR [esi+4], 87

    ! mov BYTE PTR [esi+30], 79

    ! mov BYTE PTR [esi+20], 92

    ! mov BYTE PTR [esi+16], 84

    ! mov BYTE PTR [esi+21], 83

    ! mov BYTE PTR [esi+25], 101

    ! mov BYTE PTR [esi+31], 83

    ! mov BYTE PTR [esi+12], 67

    ! mov BYTE PTR [esi+15], 80

    ! mov BYTE PTR [esi+22], 121

    ! mov BYTE PTR [esi+9], 68

    ! mov BYTE PTR [esi+1], 65

    ! mov BYTE PTR [esi+3], 68

    ! mov BYTE PTR [esi+6], 82

    ! mov BYTE PTR [esi+0], 72

    ! mov BYTE PTR [esi+18], 79

    ! mov BYTE PTR [esi+23], 115

    ! mov BYTE PTR [esi+11], 83

    ! mov BYTE PTR [esi+7], 69

    ! mov BYTE PTR [esi+19], 78

    ! mov BYTE PTR [esi+26], 109

    ! mov BYTE PTR [esi+8], 92

    ! mov BYTE PTR [esi+2], 82

    ! mov BYTE PTR [esi+5], 65

    ! mov BYTE PTR [esi+10], 69

    ! mov BYTE PTR [esi+13], 82

    ! mov BYTE PTR [esi+14], 73

    ! mov BYTE PTR [esi+24], 116



    FUNCTION = a$



END FUNCTION



' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤