'+--------------------------------------------------------------------------+
'|                                                                          |
'|                                 DVBTREE                                  |
'|                                                                          |
'|                         ***  ASCIIZ VERSION ***                          |
'|                                                                          |
'|                                Multi-user                         |
'|                                                                          |
'|   Subroutines written for the PowerBASIC 32-bit compilers PB/CC, PBDLL.  |
'|                                                                          |
'+--------------------------------------------------------------------------+
'|                                                                          |
'|                         Author Patrice TERRIER                           |
'|            8 Domaine de Rochagnon. 38800 Champagnier  FRANCE             |
'|                                                                          |
'|                   copyright (c) 2002 Patrice TERRIER                     |
'|                                                                          |
'|                    E-mail: pterrier@zapsolution.com                      |
'|                                                                          |
'+--------------------------------------------------------------------------+
'|                           ZAP Image solution                             |
'|                        http://www.zapsolution.com                         |
'+--------------------------------------------------------------------------+
'|                                                                          |
'|                      Version 2.06 from 06-22-2002                        |
'|                                                                          |
'+--------------------------------------------------------------------------+
'
#COMPILE DLL "DVBTREE.DLL"
'-----------------------------------------------------------------
' Equates:  24
'-----------------------------------------------------------------
%WINAPI                                         = 1
%FALSE                                          = 0
%NULL                                           = 0
%GENERIC_READ                                   = &H80000000&
%GENERIC_WRITE                                  = &H40000000&
%FILE_SHARE_READ                                = &H00000001
%FILE_SHARE_WRITE                               = &H00000002
%FILE_ATTRIBUTE_READONLY                        = &H00000001
%FILE_ATTRIBUTE_HIDDEN                          = &H00000002
%FILE_ATTRIBUTE_SYSTEM                          = &H00000004
%FILE_ATTRIBUTE_NORMAL                          = &H00000080
%INVALID_HANDLE_VALUE                           = -1        ' Patrice the above causes many BUGS in existing code
%FILE_BEGIN                                     = 0
%FILE_CURRENT                                   = 1
%FILE_FLAG_WRITE_THROUGH                        = &H80000000
%CREATE_ALWAYS                                  = 2
%OPEN_ALWAYS                                    = 4
%DLL_PROCESS_ATTACH                             = 1
%FILE_TYPE_DISK                                 = &H1
%LOCALE_USER_DEFAULT                            = &H0000
%LOCALE_SENGLANGUAGE                            = &H1001    ' English name of language
%MAX_PATH                                       = 260       ' max. length of full pathname
%MB_ICONEXCLAMATION                             = &H00000030&
%MB_SYSTEMMODAL                                 = &H00001000&
'
'-----------------------------------------------------------------
' TYPE and UNION structures:  4
'-----------------------------------------------------------------
TYPE OVERLAPPED
  Internal AS DWORD
  InternalHigh AS DWORD
  offset AS DWORD
  OffsetHigh AS DWORD
  hEvent AS DWORD
END TYPE
'
TYPE SECURITY_ATTRIBUTES
  nLength AS DWORD
  lpSecurityDescriptor AS LONG
  bInheritHandle AS LONG
END TYPE
'
TYPE FILETIME
  dwLowDateTime AS DWORD
  dwHighDateTime AS DWORD
END TYPE
'
TYPE WIN32_FIND_DATA
  dwFileAttributes AS DWORD
  ftCreationTime AS FILETIME
  ftLastAccessTime AS FILETIME
  ftLastWriteTime AS FILETIME
  nFileSizeHigh AS DWORD
  nFileSizeLow AS DWORD
  dwReserved0 AS DWORD
  dwReserved1 AS DWORD
  cFileName AS ASCIIZ * %MAX_PATH
  cAlternateFileName AS ASCIIZ * 14
END TYPE
'
'-----------------------------------------------------------------
' Declared Functions:  18
'-----------------------------------------------------------------
DECLARE FUNCTION CloseHandle LIB "KERNEL32.DLL" ALIAS "CloseHandle" (BYVAL hObject AS DWORD) AS LONG
DECLARE FUNCTION CreateFile LIB "KERNEL32.DLL" ALIAS "CreateFileA" (lpFileName AS ASCIIZ, BYVAL dwDesiredAccess AS DWORD, BYVAL dwShareMode AS DWORD, lpSecurityAttributes AS SECURITY_ATTRIBUTES, BYVAL dwCreationDisposition AS DWORD, _
                 BYVAL dwFlagsAndAttributes AS DWORD, BYVAL hTemplateFile AS DWORD) AS DWORD
DECLARE FUNCTION DeleteFile LIB "KERNEL32.DLL" ALIAS "DeleteFileA" (lpFileName AS ASCIIZ) AS LONG
DECLARE FUNCTION FindClose LIB "KERNEL32.DLL" ALIAS "FindClose" (BYVAL hFindFile AS DWORD) AS LONG
DECLARE FUNCTION FindFirstFile LIB "KERNEL32.DLL" ALIAS "FindFirstFileA" (lpFileName AS ASCIIZ, lpFindFileData AS WIN32_FIND_DATA) AS LONG
DECLARE FUNCTION FlushFileBuffers LIB "KERNEL32.DLL" ALIAS "FlushFileBuffers" (BYVAL hFile AS DWORD) AS LONG
DECLARE FUNCTION GetCurrentDirectory LIB "KERNEL32.DLL" ALIAS "GetCurrentDirectoryA" (BYVAL nBufferLength AS LONG, lpBuffer AS ASCIIZ) AS LONG
DECLARE FUNCTION GetFileSize LIB "KERNEL32.DLL" ALIAS "GetFileSize" (BYVAL hFile AS DWORD, lpFileSizeHigh AS LONG) AS LONG
DECLARE FUNCTION GetFileType LIB "KERNEL32.DLL" ALIAS "GetFileType" (BYVAL hFile AS DWORD) AS LONG
DECLARE FUNCTION GetLastError LIB "KERNEL32.DLL" ALIAS "GetLastError" () AS LONG
DECLARE FUNCTION GetLocaleInfo LIB "KERNEL32.DLL" ALIAS "GetLocaleInfoA" (BYVAL Locale AS LONG, BYVAL LCType AS LONG, lpLCData AS ASCIIZ, BYVAL cchData AS LONG) AS LONG
DECLARE FUNCTION GetWindowsDirectory LIB "KERNEL32.DLL" ALIAS "GetWindowsDirectoryA" (lpBuffer AS ASCIIZ, BYVAL nSize AS DWORD) AS DWORD
DECLARE FUNCTION LockFile LIB "KERNEL32.DLL" ALIAS "LockFile" (BYVAL hFile AS DWORD, BYVAL dwFileOffsetLow AS DWORD, BYVAL dwFileOffsetHigh AS DWORD, BYVAL nNumberOfBytesToLockLow AS LONG, BYVAL nNumberOfBytesToLockHigh AS LONG) AS LONG
DECLARE FUNCTION ReadFile LIB "KERNEL32.DLL" ALIAS "ReadFile" (BYVAL hFile AS DWORD, lpBuffer AS ANY, BYVAL nNumberOfBytesToRead AS LONG, lpNumberOfBytesRead AS LONG, lpOverlapped AS OVERLAPPED) AS LONG
DECLARE FUNCTION SetEndOfFile LIB "KERNEL32.DLL" ALIAS "SetEndOfFile" (BYVAL hFile AS DWORD) AS LONG
DECLARE FUNCTION SetFilePointer LIB "KERNEL32.DLL" ALIAS "SetFilePointer" (BYVAL hFile AS DWORD, BYVAL lDistanceToMove AS LONG, lpDistanceToMoveHigh AS LONG, BYVAL dwMoveMethod AS DWORD) AS LONG
DECLARE FUNCTION UnlockFile LIB "KERNEL32.DLL" ALIAS "UnlockFile" (BYVAL hFile AS DWORD, BYVAL dwFileOffsetLow AS DWORD, BYVAL dwFileOffsetHigh AS DWORD, BYVAL nNumberOfBytesToUnlockLow AS LONG, BYVAL nNumberOfBytesToUnlockHigh AS LONG) AS LONG
DECLARE FUNCTION WriteFile LIB "KERNEL32.DLL" ALIAS "WriteFile" (BYVAL hFile AS DWORD, lpBuffer AS ANY, BYVAL nNumberOfBytesToWrite AS LONG, lpNumberOfBytesWritten AS LONG, lpOverlapped AS OVERLAPPED) AS LONG
'
#INCLUDE "DVBTREE.INC"
'
DEFLNG A-Z
'
GLOBAL Btr() AS BTRECORD, RecBuf$(), ItmPtr&(), CurRec&(), CurLvl&()
GLOBAL BtBuffer&()
GLOBAL zTmp AS ASCIIZ * %MAX_PATH
GLOBAL LockIsOn&
'
FUNCTION dvMinu$ ALIAS "dvMinu"
    FUNCTION = "…ƒ‚Šˆ‰Œ‹”“–—‡„†Ž‘•˜™š ¡¢£¤"
END FUNCTION
'
FUNCTION dvMaju$ ALIAS "dvMaju"
    FUNCTION = "AAEEEEIIOOUUUCAAIAAE’OYOUAIOU¥"
END FUNCTION
'
SUB dvBtLockOn ALIAS "dvBtLockOn" () EXPORT
    LockIsOn& = -1
END SUB
'
SUB dvBtLockOff ALIAS "dvBtLockOff" () EXPORT
    LockIsOn& = 0
END SUB
'
FUNCTION dvExist& ALIAS "dvExist" (zFileSpec AS ASCIIZ) EXPORT
'
    LOCAL fd AS WIN32_FIND_DATA
'
    IF LEN(zFileSpec) THEN
       hFind& = FindFirstFile(zFileSpec, fd)
       IF hFind& <> %INVALID_HANDLE_VALUE THEN
          CALL FindClose(hFind&)
          FUNCTION = -1
       END IF
    END IF
'
END FUNCTION
'
FUNCTION dvFOpen& ALIAS "dvFOpen" (zFilName AS ASCIIZ, BYVAL AccessMode&, BYVAL ShareMode&, hFile&) EXPORT
'
    AccessMode& = MIN(MAX(AccessMode&, 0), 2) ' Coherce between 0-2
    IF AccessMode& = 0 THEN                   ' 0 Open for read only.
       AccessIs& = %GENERIC_READ
    ELSEIF AccessMode& = 1 THEN               ' 1 Open for write only.
       AccessIs& = %GENERIC_WRITE
    ELSE                                      ' 2 Open for read and write.
       AccessIs& = %GENERIC_READ OR %GENERIC_WRITE
    END IF
'
    ShareMode& = MIN(MAX(ShareMode&, 1), 4)   ' Coherce between 1-4
    IF ShareMode& = 1 THEN                    ' 1 Deny read/write access.
       ShareIs& = 0
    ELSEIF ShareMode& = 2 THEN                ' 2 Deny write access.
       ShareIs& =  %FILE_SHARE_READ
    ELSEIF ShareMode& = 3 THEN                ' 3 Deny read access.
       ShareIs& =  %FILE_SHARE_WRITE
    ELSE                                      ' 4 Deny none (full share mode).
       ShareIs& =  %FILE_SHARE_READ OR %FILE_SHARE_WRITE
    END IF

    IF hFile& = -1 THEN
       FlagAndAttribute& = %FILE_ATTRIBUTE_NORMAL OR %FILE_FLAG_WRITE_THROUGH
    ELSE
       FlagAndAttribute& = %FILE_ATTRIBUTE_NORMAL
    END IF
'
    hFile& = CreateFile(zFilName, AccessIs&, ShareIs&, BYVAL %NULL, %OPEN_ALWAYS, FlagAndAttribute&, BYVAL %NULL)
'
    IF hFile& = %INVALID_HANDLE_VALUE THEN ' -1 Fail to create the file
       FUNCTION = GetLastError             ' Set the error code
       hFile& = 0                          ' Reset handle number
    END IF
'
END FUNCTION
'
SUB dvFClose ALIAS "dvFClose" (hFile&) EXPORT
    IF hFile& THEN CALL CloseHandle(hFile&)
    hFile& = 0
END SUB
'
FUNCTION dvFPut& ALIAS "dvFPut" (BYVAL hFile&, zBuf AS ASCIIZ) EXPORT
    IF hFile& THEN
       LenBuf& = LEN(zBuf)
       IF LenBuf& THEN
          IF WriteFile&(hFile&, zBuf, LenBuf&, ByttesWritten&, BYVAL %NULL) = 0 THEN
             FUNCTION = GetLastError
          END IF
       END IF
    END IF
END FUNCTION
'
FUNCTION dvFSeek& ALIAS "dvFSeek" (hFile&, BYVAL PosByte&) EXPORT
    IF SetFilePointer(hFile&, PosByte&, BYVAL %NULL, %FILE_BEGIN) < 0 THEN
       FUNCTION = GetLastError
    END IF
END FUNCTION
'
FUNCTION dvFLoc& ALIAS "dvFLoc" (hFile&) EXPORT
  ' Warning this function returns &hFFFFFFFF (-1) in case of error
    FUNCTION = SetFilePointer(hFile&, 0&, BYVAL %NULL, %FILE_CURRENT)
END FUNCTION
'
FUNCTION dvFPutAt& ALIAS "dvFPutAt" (BYVAL hFile&, BYVAL PosByte&, zBuf AS ASCIIZ) EXPORT
    ErrCode& = dvFSeek&(hFile&, PosByte&)
    IF ErrCode& = 0 THEN ErrCode& = dvFPut&(hFile&, zBuf)
    FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION dvFPutR& ALIAS "dvFPutR" (BYVAL hFile&, zBuf AS ASCIIZ, BYVAL Record&) EXPORT
    LenBuf& = LEN(zBuf)
    Record& = Record& * LenBuf& - LenBuf&
    ErrCode& = dvFSeek&(hFile&, Record&)
    IF ErrCode& = 0 THEN ErrCode& = dvFPut& (hFile&, zBuf)
    FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION FPut& (BYVAL hFile&, Buf$)
    IF hFile& THEN
       LenBuf& = LEN(Buf$)
       IF LenBuf& THEN
          IF WriteFile&(hFile&, BYVAL STRPTR(Buf$), LenBuf&, ByttesWritten&, BYVAL %NULL) = 0 THEN
             FUNCTION = GetLastError
          END IF
       END IF
    END IF
END FUNCTION
'
FUNCTION FPutR& (BYVAL hFile&, Buf$, BYVAL Record&)
    LenBuf& = LEN(Buf$)
    Record& = Record& * LenBuf& - LenBuf&
    ErrCode& = dvFSeek&(hFile&, Record&)
    IF ErrCode& = 0 THEN ErrCode& = FPut& (hFile&, Buf$)
    FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION dvFGet& ALIAS "dvFGet" (BYVAL hFile&, zBuf AS ASCIIZ) EXPORT
    IF hFile& THEN
       LenBuf& = LEN(zBuf)
       IF LenBuf& THEN
          IF ReadFile&(hFile&, zBuf, LenBuf&, ByttesReaded&, BYVAL %NULL) = 0 THEN
             FUNCTION = GetLastError
          END IF
       END IF
    END IF
END FUNCTION
'
FUNCTION dvFGetR& ALIAS "dvFGetR" (BYVAL hFile&, zBuf AS ASCIIZ, BYVAL Record&) EXPORT
    LenBuf& = LEN(Buf$)
    Record& = Record& * LenBuf& - LenBuf&
    ErrCode& = dvFSeek&(hFile&, Record&)
    IF ErrCode& = 0 THEN ErrCode& = dvFGet& (hFile&, zBuf)
    FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION FGet& (BYVAL hFile&, Buf$)
    IF hFile& THEN
       LenBuf& = LEN(Buf$)
       IF LenBuf& THEN
          IF ReadFile&(hFile&, BYVAL STRPTR(Buf$), LenBuf&, ByttesReaded&, BYVAL %NULL) = 0 THEN
             FUNCTION = GetLastError
          END IF
       END IF
    END IF
END FUNCTION
'
FUNCTION FGetR& (BYVAL hFile&, Buf$, BYVAL Record&)
    LenBuf& = LEN(Buf$)
    Record& = Record& * LenBuf& - LenBuf&
    ErrCode& = dvFSeek&(hFile&, Record&)
    IF ErrCode& = 0 THEN ErrCode& = FGet& (hFile&, Buf$)
    FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION dvFGetAt& ALIAS "dvFGetAt" (BYVAL hFile&, BYVAL PosByte&, zBuf AS ASCIIZ) EXPORT
    ErrCode& = dvFSeek&(hFile&, PosByte&)
    IF ErrCode& = 0 THEN ErrCode& = dvFGet&(hFile&, zBuf)
    FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION dvFlush& ALIAS "dvFlush" (BYVAL hFile&) EXPORT
    IF hFile& THEN
       IF FlushFileBuffers(hFile&) = 0 THEN FUNCTION = GetLastError
    END IF
END FUNCTION
'
FUNCTION dvFlof& ALIAS "dvFlof" (BYVAL hFile&) EXPORT
    IF GetFileType(hFile&) = %FILE_TYPE_DISK THEN
       fSize& = GetFileSize(hFile&, BYVAL %NULL)
       IF fSize& > -1& THEN FUNCTION = fSize&
    END IF
END FUNCTION
'
FUNCTION dvKillFile& ALIAS "dvKillFile" (zFullName AS ASCIIZ) EXPORT
    LOCAL zPathName AS ASCIIZ * %MAX_PATH
    LOCAL zFilterName AS ASCIIZ * %MAX_PATH
    CALL dvSplitN (zFullName, zPathName, zFilterName)
    ToKill$ = DIR$(zFullName)
    DO WHILE LEN(ToKill$)
       zTmp = zPathName + ToKill$
       IF DeleteFile(zTmp) = 0 THEN FUNCTION = GetLastError: EXIT DO
       ToKill$ = DIR$
    LOOP
END FUNCTION
'
FUNCTION dvInstrB& ALIAS "dvInstrB" (BYVAL FromPos&, zItem AS ASCIIZ, zSearch AS ASCIIZ) EXPORT

    Item$ = zItem: Search$ = zSearch

'   Uses FromPos < 1 TO start search from end of Item$
    DIM P1 AS BYTE PTR, P2 AS BYTE PTR
    Length& = LEN(Item$)
  ' Don't search out of the string limit
    IF FromPos& < 1 OR FromPos& > Length& THEN FromPos& = Length&
    P1 = STRPTR(Item$): P2 = P1 + Length& - 1
  ' Reverse Item$ string
    FOR P& = 1 TO Length& \ 2: SWAP @P1, @P2: INCR P1: DECR P2: NEXT
  ' Reverse Search$ string
    LenS& = LEN(Search$)
    P1 = STRPTR(Search$): P2 = P1 + LenS& - 1
    FOR P& = 1 TO LenS& \ 2: SWAP @P1, @P2: INCR P1: DECR P2: NEXT
    So& = INSTR(Length& - FromPos& + 1, Item$, Search$)
    IF So& THEN FUNCTION = Length& - So& + 2 - LenS&

END FUNCTION
'
SUB dvSplitN ALIAS "dvSplitN" (zFullName AS ASCIIZ, zPathName AS ASCIIZ, zFilName AS ASCIIZ) EXPORT
' Split a full path name, and return the current disk and directory
' if fullname$ contents only FilName$
' works with "..\" too

    LOCAL zDsk AS ASCIIZ * 3
    LOCAL zThisPath AS ASCIIZ * %MAX_PATH

    Length& = LEN(zFullName)
    IF Length& THEN
       So& = INSTR(zFullName, "..\"): IF So& = 1 THEN So& = 4 ELSE So& = 1
       L& = Length& - So& + 1
       S2& = INSTR(zFullName, " ")
       IF S2& THEN L& = LEN(LEFT$(zFullName, S2& - 1)) - So& + 1
       CALL dvDskPath(zDsk, zThisPath): zFilName = zFullName
       So& = dvInstrB(Length&, zFullName, "\")
       IF So& THEN
          zPathName = LEFT$(zFullName, So&)
       ELSE
          So& = INSTR(zFullName, ":")
       END IF
       IF zPathName = zDsk OR LEN(zPathName) = 0 THEN
          zPathName = zDsk + zThisPath
       END IF
       IF So& THEN zFilName = MID$(zFullName, So& + 1, Length& - So&)
    END IF
'
END SUB
'
FUNCTION dvUcase$ ALIAS "dvUcase" (zStringToConvert AS ASCIIZ) EXPORT
    StringToConvert$ = zStringToConvert
    REPLACE ANY dvMinu$ WITH dvMaju$ IN StringToConvert$
    FUNCTION = UCASE$(StringToConvert$)
END FUNCTION
'
SUB dvDskPath ALIAS "dvDskPath" (zDsk AS ASCIIZ, zPath AS ASCIIZ) EXPORT
'   Dsk$ and Path$ are ready to be concatened with a filename
'   Dsk$ and Paths correspond to the current directory
    IF GetCurrentDirectory(BYVAL SIZEOF(zTmp), zTmp) THEN
       zDsk = LEFT$(zTmp, 2)
       zPath = RTRIM$(MID$(zTmp, 3), ANY CHR$(0,92)) + "\"
    END IF
END SUB
'
FUNCTION dvSetEof& ALIAS "dvSetEof" (BYVAL hFile&) EXPORT
    IF SetEndOfFile(hFile&) = 0 THEN FUNCTION = GetLastError
END FUNCTION
'
FUNCTION dvSetEofAt& ALIAS "dvSetEofAt" (BYVAL hFile&, BYVAL PosByte&) EXPORT
    ErrCode& = dvFSeek&(hFile&, PosByte&)
    IF ErrCode& = 0 THEN ErrCode& = dvSetEof&(hFile&)
    FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION dvFSetSize& ALIAS "dvFSetSize" (zFilName AS ASCIIZ, BYVAL PosByte&) EXPORT
'
    ErrCode& = dvFOpen(zFilName, 1, 1, hFile&)
    IF ErrCode& = 0 THEN ErrCode& = dvSetEofAt& (hFile&, PosByte&)
    CALL dvFClose(hFile&)
    FUNCTION = ErrCode&
    FilName$ = ""
'
END FUNCTION
'
FUNCTION dvFLock& ALIAS "dvFLock" (BYVAL hFile&, BYVAL OffSet&, BYVAL Length&) EXPORT
    IF LockFile(hFile&, OffSet&, BYVAL 0&, Length&, BYVAL 0&) = 0 THEN
       FUNCTION = GetLastError
    END IF
END FUNCTION
'
FUNCTION dvFUnLock& ALIAS "dvFUnLock" (BYVAL hFile&, BYVAL OffSet&, BYVAL Length&) EXPORT
    IF UnLockFile(hFile&, OffSet&, BYVAL 0&, Length&, BYVAL 0&) = 0 THEN
       FUNCTION = GetLastError
    END IF
END FUNCTION
'
FUNCTION LibMain& (BYVAL DllInstance&, BYVAL Reason&, BYVAL Reserved&) EXPORT

    REDIM Btr(0) AS BTRECORD, RecBuf$(0), ItmPtr&(0), CurRec&(0), CurLvl&(0)
    REDIM BtBuffer&(0)

    LockIsOn& = -1 ' Turn it On

    FUNCTION = 1
END FUNCTION
'
FUNCTION BtTestBuffer& (BYVAL hFile&)
'
    IF LBOUND(BtBuffer&) = 0 THEN bOne& = -1
    ARRAY SCAN BtBuffer&(), = hFile&, TO I&
    FUNCTION = I& + bOne&
'
END FUNCTION
'
FUNCTION BtGetKeyPl$ (BYVAL Position&, BYVAL uBT&)
    FUNCTION = MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Position& - 1), Btr(uBT&).Keylen)
END FUNCTION
'
FUNCTION BtGetRec& (BYVAL Position&, BYVAL uBT&)
    FUNCTION = CVL(MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Position& - 1) + Btr(uBT&).Klen, 4))
END FUNCTION
'
FUNCTION BtGetRecPtr& (BYVAL Position&, BYVAL uBT&)
    IF Position& = 0 THEN
       Offset& = 2
    ELSE
       Offset& = 6 + Btr(uBT&).ItmLen * (Position& - 1) + Btr(uBT&).KeyLen
    END IF
    FUNCTION = CVL(MID$(RecBuf$(uBT&), Offset&, 4))
END FUNCTION
'
SUB BtSetRecPtr (BYVAL Position&, BYVAL Dt&, BYVAL uBT&)
    IF Position& = 0 THEN
       Offset& = 2
    ELSE
       Offset& = 6 + Btr(uBT&).ItmLen * (Position& - 1) + Btr(uBT&).KeyLen
    END IF
    MID$(RecBuf$(uBT&), Offset&, 4) = MKL$(Dt&)
END SUB
'
FUNCTION BtGetItm$ (BYVAL Position&, BYVAL uBT&)
    FUNCTION = MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Position& - 1), Btr(uBT&).ItmLen)
END FUNCTION
'
SUB BtSetItm (BYVAL Position&, BYVAL Dt$, BYVAL uBT&)
    MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Position& - 1), Btr(uBT&).ItmLen) = Dt$
END SUB
'
FUNCTION Bt& (BYVAL hBtFile&, BYVAL UsrAct&, zRKey AS ASCIIZ, Record&, BtErr&)
'
    uBT& = BtTestBuffer&(hBtFile&)
    IF uBT& < 1 THEN ' No Btree handle available
       Bterr& = 9: EXIT FUNCTION
    END IF
'
    DIM Stk&(53, 0 TO 1)
'
    DtaIn& = Record&: Record& = 0
'
    Ky$ = SPACE$(Btr(uBT&).Klen)
    WasKey$ = dvUcase(zRKey): LenWasKey& = LEN(WasKey$)
    LSET Ky$ = WasKey$: zRKey = ""
'
    BtErr& = 0
BtStart:
    IF BtErr& = 0 THEN
'
       IF LockIsOn& THEN ' Check if the lock flag is turned On or Off
          Strt& = TIMER: BtErr& = 3
          DO
             ErrCode& = dvFLock&(hBtFile&, 0&, 1024&)
             IF ErrCode& = 0& THEN BtErr& = 0: EXIT DO
          LOOP UNTIL ABS(TIMER - Strt&) > 5
       END IF
'
       IF BtErr& = 0 THEN
          SELECT CASE UsrAct&
          CASE 70                               ' "F" Get First Key
            CurLvl&(uBT&) = 0: GOSUB BtGetNext
          CASE 76                               ' "L" Get Last Key
            CurLvl&(uBT&) = 0: GOSUB BtGetPrev
          CASE 71, 83                           ' "G" Get exact match
            KeyFull$ = Ky$ + MKL$(DtaIn&)       ' "S" Search for key
            GOSUB BtSearch
            IF BtErr& = 1 AND BtGetRec&(ItmPtr&(uBT&), uBT&) > 0 THEN
               IF ItmPtr&(uBT&) THEN
                  FullKey$ = BtGetKeyPl$(ItmPtr&(uBT&), uBT&)
                  IF UsrAct& = 83 AND LenWasKey& THEN
                     IF LEFT$(FullKey$, LenWasKey&) = WasKey$ THEN BtErr& = 0
                  ELSEIF LEFT$(KeyFull$, Btr(uBT&).Klen) = LEFT$(FullKey$, Btr(uBT&).Klen) THEN
                     BtErr& = 0
                  END IF
               END IF
               IF BtErr& = 1 THEN ItmPtr&(uBT&) = 0
            END IF
          CASE 85                               ' "U" Add a unique key
            KeyFull$ = Ky$ + MKL$(DtaIn&)
            ' Alias BtAddUnique
            Temp& = 1: GOSUB BtNonUniq
            IF BtErr& = 0 THEN
               BtErr& = 2 ' Means duplicated key
            ELSE
               GOSUB BtAddAtCur
            END IF
          CASE 68                               ' "D" Delete the key/data given
            KeyFull$ = Ky$ + MKL$(DtaIn&)
            GOSUB BtSearch
            DO UNTIL BtErr& = 1
               IF ItmPtr&(uBT&) = 0 THEN BtErr& = 1: EXIT DO
               IF KeyFull$ <> BtGetKeyPl$(ItmPtr&(uBT&), uBT&) THEN
                  BtErr& = 1: EXIT DO
               END IF
               IF DtaIn& = BtGetRec&(ItmPtr&(uBT&), uBT&) THEN
                  GOSUB BtDelCur: BtErr& = 0
                  EXIT DO
               ELSE
                  GOSUB BtGetNext
               END IF
            LOOP
'
          CASE 78, 69                           ' "N" Get Next Key ; "E" End
            KeyFull$ = Ky$ + MKL$(DtaIn&)
            GOSUB BtSearch
            GOSUB BtGetNext
'
          ' This line was added with Pascal on 05-23-1999
            IF ItmPtr&(uBT&) = 0 AND Bterr& = 0 THEN Bterr& = 1
'
          CASE 80, 66                           ' "P" Get Previous Key - "B" begin
            KeyFull$ = Ky$ + MKL$(DtaIn&)
            GOSUB BtSearch
            GOSUB BtGetPrev
          CASE ELSE                             ' Error in Action code
            zRKey = "": BtErr& = 8
          END SELECT
'
          IF LockIsOn& THEN ErrCode& = dvFUnlock&(hBtFile&, 0&, 1024&)

          IF ErrCode& THEN BtErr& = 4
       END IF
    END IF
    IF BtErr& < 2 THEN ' IF Lock was effectiv
       IF BtErr& = 0 AND INSTR("AUD", CHR$(UsrAct&)) > 0 THEN
          LSET RecBuf$(uBT&) = Btr(uBT&)
          ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), 1&) ' FLUSH (hBtFile&)
       END IF
'
       IF ItmPtr&(uBT&) THEN
          IF UsrAct& = 85 THEN ' Insert
             zRKey = WasKey$
             Record& = DtaIn&
          ELSE
             FullKey$ = BtGetKeyPl$(ItmPtr&(uBT&), uBT&)
             zRKey = LEFT$(FullKey$, Btr(uBT&).Klen)
             Record& = CVL(RIGHT$(FullKey$, 4))
          END IF
       ELSE
          zRKey = WasKey$
          Record& = 0
       END IF
'
'      Version 2.02 Search before or after the specified key 03-29-2000
       IF INSTR("BE", CHR$(UsrAct&)) THEN
          LSET Ky$ = zRKey
          DtaIn& = Record&
          UsrAct& = 83 ' "S"
          GOTO BtStart
       END IF
'
    ELSE
       zRKey = "": Record& = 0
    END IF
'
    FUNCTION = ErrCode&
'
EXIT FUNCTION
'
BtPop:
    CurLvl&(uBT&) = CurLvl&(uBT&) - 1
'
BtGetStackNode:
    CurRec&(uBT&) = Stk&(CurLvl&(uBT&), 0)
    ItmPtr&(uBT&) = Stk&(CurLvl&(uBT&), 1)
'
BtGetCur:
    RecBuf$(uBT&) = STRING$(1024, 0)
    IF CurRec&(uBT&) * 1024 > dvFLof&(hBtFile&) THEN
       ErrCode& = FPutR(hBtFile&, (RecBuf$(uBT&)), CurRec&(uBT&))
    END IF
    ErrCode& = FGetR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    RETURN
'
BtPush:
    Stk&(CurLvl&(uBT&), 0) = CurRec&(uBT&)
    Stk&(CurLvl&(uBT&), 1) = ItmPtr&(uBT&)
    RETURN
'
BtSearch: '*** SEARCH FOR FIRST OCCURANCE OF KEY ***
    Temp& = 0
BtNonUniq:
    BtErr& = 1
    CurLvl&(uBT&) = 1
    CurRec&(uBT&) = Btr(uBT&).RootNode
BtScanNode:
    GOSUB BtGetCur
    ItmPtr&(uBT&) = 1
    Cnt& = ASC(RecBuf$(uBT&))
BtScanNodeLoop:
    WrkHlf& = INT((ItmPtr&(uBT&) + Cnt&) / 2)
    IF WrkHlf& = 0 THEN
       ItmPtr&(uBT&) = WrkHlf& + 1
    ELSE
       BGKP$ = BtGetKeyPl$(WrkHlf&, uBT&)
       IF KeyFull$ > BGKP$ OR (Temp& < 0 AND KeyFull$ = BGKP$) THEN
          ItmPtr&(uBT&) = WrkHlf& + 1
       ELSE
          Cnt& = WrkHlf& - 1
       END IF
    END IF
'
    IF Cnt& >= ItmPtr&(uBT&) THEN
       GOTO BtScanNodeLoop
    ELSE
       GOSUB BtPush
       IF ItmPtr&(uBT&) <= ASC(RecBuf$(uBT&)) THEN
          IF KeyFull$ = BtGetKeyPl$(ItmPtr&(uBT&), uBT&) THEN
             BtErr& = 0
             IF BtGetRecPtr(ItmPtr&(uBT&) - 1, uBT&) = 0 THEN RETURN
          END IF
       END IF
    END IF
'
    RecPtr& = BtGetRecPtr(ItmPtr&(uBT&) - 1, uBT&)
    IF RecPtr& > 0 THEN
       CurRec&(uBT&) = RecPtr&
       CurLvl&(uBT&) = CurLvl&(uBT&) + 1
       GOTO BtScanNode
    END IF
    IF BtErr& = 0 THEN GOTO BtGetNextLeftSon
    IF Temp& = 0 THEN GOSUB BtGetNextOk: BtErr& = 1
    RETURN
'
BtAddAtCur: '*** ADD KEY AT CURRENT NODE LOCATION ***
    TmpAdd$ = KeyFull$ + MKL$(0)
    Temp& = 0
BtCheckFull:
    IF ASC(RecBuf$(uBT&)) < Btr(uBT&).HlfNode * 2 THEN
       Cnt& = ASC(RecBuf$(uBT&)) + 1
       ASC(RecBuf$(uBT&), 1) = Cnt&
       GOSUB BtInsInNode
       CALL BtSetRecPtr(ItmPtr&(uBT&) - 1, Temp&, uBT&)
       ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))

       ASC(RecBuf$(uBT&), 1) = ASC(RecBuf$(uBT&)) + 1

       INCR Btr(uBT&).Numkeys
       TmpAdd$ = "": Temp$ = "": Emerg$ = ""
       BtErr& = 0
       RETURN
    END IF
    IF ItmPtr&(uBT&) > Btr(uBT&).HlfNode + 1 THEN
       GOTO BtAddRight
    ELSEIF ItmPtr&(uBT&) = Btr(uBT&).HlfNode + 1 THEN
       Emerg$ = TmpAdd$
    ELSE
       Emerg$ = BtGetItm$(Btr(uBT&).HlfNode, uBT&)
       Cnt& = Btr(uBT&).HlfNode
       GOSUB BtInsInNode
    END IF
    CALL BtSetRecPtr(ItmPtr&(uBT&) - 1, Temp&, uBT&)
    ASC(RecBuf$(uBT&), 1) = Btr(uBT&).HlfNode
    Tmp2$ = MID$(RecBuf$(uBT&), 6 + Btr(uBT&).HlfNode * (Btr(uBT&).ItmLen), Btr(uBT&).HlfNode * Btr(uBT&).ItmLen)
    Temp$ = Tmp2$
    ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    Temp& = CurRec&(uBT&)
    GOSUB BtGetAvailableNode
    GOSUB BtSetCopy
    GOSUB BtSetRightSon
    GOTO BtWriteNode
'
BtAddRight:
    Tmp2$ = MID$(RecBuf$(uBT&), 2, 4 + Btr(uBT&).HlfNode * (Btr(uBT&).ItmLen))
    Temp$ = Tmp2$
    ItmPtr&(uBT&) = ItmPtr&(uBT&) - Btr(uBT&).HlfNode
    Emerg$ = BtGetItm$(Btr(uBT&).HlfNode + 1, uBT&)
    FOR Cnt& = 1 TO ItmPtr&(uBT&) - 2
        CALL BtSetItm(Cnt&, BtGetItm$(Cnt& + Btr(uBT&).HlfNode + 1, uBT&), uBT&)
    NEXT
    CALL BtSetItm(ItmPtr&(uBT&) - 1, TmpAdd$, uBT&)
    IF ItmPtr&(uBT&) > Btr(uBT&).HlfNode THEN
       GOTO BtSetLeftSon
    ELSE
       FOR Cnt& = ItmPtr&(uBT&) TO Btr(uBT&).HlfNode
           CALL BtSetItm(Cnt&, BtGetItm$(Cnt& + Btr(uBT&).HlfNode, uBT&), uBT&)
       NEXT
    END IF
'
BtSetLeftSon:
    GOSUB BtSetRightSon
    CALL BtSetRecPtr(ItmPtr&(uBT&) - 2, Temp&, uBT&)
    ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    GOSUB BtGetAvailableNode
    Tmp2$ = MID$(RecBuf$(uBT&), 2, LEN(Temp$))
    LSET Tmp2$ = Temp$
    MID$(RecBuf$(uBT&), 2, LEN(Temp$)) = Tmp2$
    ASC(RecBuf$(uBT&), 1) = Btr(uBT&).HlfNode
    Temp& = CurRec&(uBT&)
BtWriteNode:
    ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    TmpAdd$ = Emerg$: CurLvl&(uBT&) = CurLvl&(uBT&) - 1
    IF CurLvl&(uBT&) = 0 THEN
       GOSUB BtGetAvailableNode
       ItmPtr&(uBT&) = 1
       Btr(uBT&).RootNode = CurRec&(uBT&)
       CALL BtSetRecPtr(0, Temp&, uBT&)
       GOTO BtCheckFull
    ELSE
       GOSUB BtGetStackNode
       GOTO BtCheckFull
    END IF
'
BtInsInNode:
    FOR Cnt& = Cnt& TO ItmPtr&(uBT&) + 1 STEP -1
        CALL BtSetItm(Cnt&, BtGetItm$(Cnt& - 1, uBT&), uBT&)
    NEXT
    CALL BtSetItm(ItmPtr&(uBT&), TmpAdd$, uBT&)
    RETURN
'
BtGetAvailableNode:
    IF Btr(uBT&).LastDel > 0 THEN
      CurRec&(uBT&) = Btr(uBT&).LastDel: GOSUB BtGetCur: Btr(uBT&).LastDel = BtGetRecPtr(0, uBT&)
    ELSE
      CurRec&(uBT&) = Btr(uBT&).NxtNode: GOSUB BtGetCur: Btr(uBT&).NxtNode = Btr(uBT&).NxtNode + 1
    END IF
    Btr(uBT&).NumAct = Btr(uBT&).NumAct + 1
    ASC(RecBuf$(uBT&), 1) = 0
    RETURN
'
BtSetRightSon:
    ASC(RecBuf$(uBT&), 1) = Btr(uBT&).HlfNode
    CALL BtSetRecPtr(0, CVL(RIGHT$(Emerg$, 4)), uBT&)
    MID$(Emerg$, LEN(Emerg$) - 3, 4) = MKL$(CurRec&(uBT&))
    RETURN
'
BtSetCopy:
    Tmp2$ = MID$(RecBuf$(uBT&), 6, LEN(Temp$))
    LSET Tmp2$ = Temp$
    MID$(RecBuf$(uBT&), 6, LEN(Temp$)) = Tmp2$
    RETURN
'
BtGetNext: '*** Get Next Key in the Index ***
    IF CurLvl&(uBT&) = 0 THEN
       CurRec&(uBT&) = Btr(uBT&).RootNode: CurLvl&(uBT&) = 1: ItmPtr&(uBT&) = 1
    ELSE
       ItmPtr&(uBT&) = ItmPtr&(uBT&) + 1
    END IF
BtGetNextLeftSon:
    GOSUB BtGetCur
    RecPtr& = BtGetRecPtr(ItmPtr&(uBT&) - 1, uBT&)
    IF RecPtr& <> 0 THEN
       GOSUB BtPush
       CurRec&(uBT&) = RecPtr&
       CurLvl&(uBT&) = CurLvl&(uBT&) + 1: ItmPtr&(uBT&) = 1
       GOTO BtGetNextLeftSon
    END IF
BtGetNextOk:
    IF ItmPtr&(uBT&) <= ASC(RecBuf$(uBT&)) THEN
      BtErr& = 0
      RETURN
    ELSEIF CurLvl&(uBT&) = 1 THEN
      CurLvl&(uBT&) = 0
      BtErr& = 1
      RETURN
    ELSE
      GOSUB BtPop
      GOTO BtGetNextOk
    END IF
'
BtGetPrev: '*** Get Previous Key in the Index ***
    IF CurLvl&(uBT&) = 0 THEN
       CurRec&(uBT&) = Btr(uBT&).RootNode
    ELSE
       GOTO BtGetPreviousRight
    END IF
BtDwn1:
    CurLvl&(uBT&) = CurLvl&(uBT&) + 1
    GOSUB BtGetCur
    ItmPtr&(uBT&) = ASC(RecBuf$(uBT&)) + 1
BtGetPreviousRight:
    GOSUB BtPush
    RecPtr& = BtGetRecPtr(ItmPtr&(uBT&) - 1, uBT&)
    IF RecPtr& > 0 THEN
       CurRec&(uBT&) = RecPtr&
       GOTO BtDwn1
    END IF
    DO
       IF ItmPtr&(uBT&) > 1 THEN
          ItmPtr&(uBT&) = ItmPtr&(uBT&) - 1
          BtErr& = 0
          EXIT DO
       ELSEIF CurLvl&(uBT&) = 1 THEN
          BtErr& = 1
          CurLvl&(uBT&) = 0
          EXIT DO
       END IF
       GOSUB BtPop
    LOOP
    RETURN
'
BtDelCur: '*** Delete The Key at the Current Place in the Index ***
    GOSUB BtPush
    IF BtGetRecPtr(ItmPtr&(uBT&), uBT&) > 0 THEN
       GOSUB BtGetNext
       TmpAdd$ = BtGetItm$(ItmPtr&(uBT&), uBT&)
       GOSUB BtGetPrev
       GOSUB BtRepFthItem
       ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
       GOSUB BtGetNext
       GOTO BtDelCur
    ELSE
       GOSUB BtDecrNode
       IF ItmPtr&(uBT&) - 1 <> ASC(RecBuf$(uBT&)) THEN
          GOSUB BtShfFmRht
       END IF
    END IF
    ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    IF (CurRec&(uBT&) = Btr(uBT&).RootNode) OR (ASC(RecBuf$(uBT&)) >= Btr(uBT&).HlfNode) THEN
       GOTO BtDCDone
    END IF
    DO
       GOSUB BtUnderflow
    LOOP UNTIL BtErr& = 1
BtDCDone:
    Btr(uBT&).Numkeys = Btr(uBT&).Numkeys - 1
    RETURN ' 05-05-2001
'
BtDecrNode:
    ASC(RecBuf$(uBT&), 1) = ASC(RecBuf$(uBT&)) - 1
    RETURN
'
BtUnderflow:
    BtErr& = 0: GOSUB BtPop
    IF ASC(RecBuf$(uBT&)) = ItmPtr&(uBT&) - 1 THEN
       GOTO BtUnf2Lft
    ELSE
       CurRec&(uBT&) = BtGetRecPtr(ItmPtr&(uBT&), uBT&)
       GOSUB BtGetMVBL
       Emerg$ = MKL$(BtGetRecPtr(0, uBT&))
    END IF
    IF WrkHlf& <= 0 THEN
       GOTO BtMrgRht
    ELSE
       Tmp2$ = MID$(RecBuf$(uBT&), 6, Btr(uBT&).ItmLen * (WrkHlf& - 1))
       Temp$ = Tmp2$
       TmpAdd$ = BtGetItm$(WrkHlf&, uBT&)
       CALL BtSetRecPtr(0, BtGetRecPtr(WrkHlf&, uBT&), uBT&)
       ASC(RecBuf$(uBT&), 1) = ASC(RecBuf$(uBT&)) - WrkHlf&
       IF ASC(RecBuf$(uBT&)) > 0 THEN
          FOR Cnt& = 1 TO ASC(RecBuf$(uBT&))
              CALL BtSetItm(Cnt&, BtGetItm$(Cnt& + WrkHlf&, uBT&), uBT&)
          NEXT
       END IF
    END IF
    ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    GOSUB BtGetStackNode
    Temp$ = BtGetItm$(ItmPtr&(uBT&), uBT&) + Temp$
    GOSUB BtRepFthItem
    GOSUB BtWriteFth
    Tmp2$ = MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Btr(uBT&).HlfNode - 1), LEN(Temp$))
    LSET Tmp2$ = Temp$
    MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Btr(uBT&).HlfNode - 1), LEN(Temp$)) = Tmp2$
    CALL BtSetRecPtr(Btr(uBT&).HlfNode, CVL(Emerg$), uBT&)
    GOTO BtAdjCnt
'
BtMrgRht:
    Tmp2$ = MID$(RecBuf$(uBT&), 6, Btr(uBT&).HlfNode * Btr(uBT&).ItmLen)
    Temp$ = Tmp2$
    Tmp2$ = MKL$(BtGetRecptr(0, uBT&))
    ASC(RecBuf$(uBT&), 1) = 0
    CALL BtSetRecPtr(0, Btr(uBT&).LastDel, uBT&)
    Btr(uBT&).LastDel = CurRec&(uBT&)
    Btr(uBT&).NumAct = Btr(uBT&).NumAct - 1
    ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    GOSUB BtGetStackNode
    CALL BtSetRecPtr(ItmPtr&(uBT&), CVL(Tmp2$), uBT&)
    Temp$ = BtGetItm$(ItmPtr&(uBT&), uBT&) + Temp$
    GOSUB BtDecrNode
    IF CurRec&(uBT&) = Btr(uBT&).RootNode AND ASC(RecBuf$(uBT&)) = 0 THEN
       Btr(uBT&).RootNode = Stk&(CurLvl&(uBT&) + 1, 0)
       CALL BtSetRecPtr(0, Btr(uBT&).LastDel, uBT&)
       Btr(uBT&).LastDel = CurRec&(uBT&)
       Btr(uBT&).NumAct = Btr(uBT&).NumAct - 1
       BtErr& = 1
       GOTO BtWriteModFth
    END IF
    IF (ASC(RecBuf$(uBT&)) >= Btr(uBT&).HlfNode) OR (CurRec&(uBT&) = Btr(uBT&).RootNode) THEN
       BtErr& = 1
    END IF
    IF ASC(RecBuf$(uBT&)) >= ItmPtr&(uBT&) THEN GOSUB BtShfFmRht
'
BtWriteModFth:
    GOSUB BtWriteFth
    Tmp2$ = MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Btr(uBT&).HlfNode - 1), LEN(Temp$))
    LSET Tmp2$ = Temp$
    MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Btr(uBT&).HlfNode - 1), LEN(Temp$)) = Tmp2$
    ASC(RecBuf$(uBT&), 1) = Btr(uBT&).HlfNode * 2
    ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    IF BtErr& = 0 THEN GOSUB BtPop
    RETURN
'
BtUnf2Lft:
    CurRec&(uBT&) = BtGetRecPtr(ItmPtr&(uBT&) - 2, uBT&)
    GOSUB BtGetMVBL
    IF WrkHlf& <= 0 THEN GOTO BtMrgLft
    ASC(RecBuf$(uBT&), 1) = ASC(RecBuf$(uBT&)) - WrkHlf&
    TmpAdd$ = BtGetItm$(ASC(RecBuf$(uBT&)) + 1, uBT&)
    Tmp2$ = MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (ASC(RecBuf$(uBT&)) + 1), Btr(uBT&).ItmLen * (WrkHlf& - 1))
    Temp$ = Tmp2$
    Emerg$ = MKL$(BtGetRecPtr(ASC(RecBuf$(uBT&)) + 1, uBT&))
    ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    GOSUB BtGetStackNode
    Temp$ = Temp$ + BtGetItm$(ItmPtr&(uBT&) - 1, uBT&)
    CALL BtSetItm(ItmPtr&(uBT&) - 1, TmpAdd$, uBT&)
    CALL BtSetRecPtr(ItmPtr&(uBT&) - 1, Stk&(CurLvl&(uBT&) + 1, 0), uBT&)
    GOSUB BtWriteFth
    IF Btr(uBT&).HlfNode > 1 THEN
       FOR Cnt& = Btr(uBT&).HlfNode - 1 TO 1 STEP -1
           CALL BtSetItm(Cnt& + WrkHlf&, BtGetItm$(Cnt&, uBT&), uBT&)
       NEXT
    END IF
    GOSUB BtSetCopy
    CALL BtSetRecPtr(WrkHlf&, BtGetRecPtr(0, uBT&), uBT&)
    CALL BtSetRecPtr(0, CVL(Emerg$), uBT&)
BtAdjCnt:
    ASC(RecBuf$(uBT&), 1) = Btr(uBT&).HlfNode - 1 + WrkHlf&
    ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    BtErr& = 1
    RETURN
'
BtMrgLft:
    Tmp2$ = MID$(RecBuf$(uBT&), 2, 4 + ASC(RecBuf$(uBT&)) * Btr(uBT&).ItmLen)
    Temp$ = Tmp2$
    ASC(RecBuf$(uBT&), 1) = 0
    CALL BtSetRecPtr(0, Btr(uBT&).LastDel, uBT&)
    Btr(uBT&).LastDel = CurRec&(uBT&)
    Btr(uBT&).NumAct = Btr(uBT&).NumAct - 1
    ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    GOSUB BtGetStackNode
    Temp$ = Temp$ + LEFT$(BtGetItm$(ItmPtr&(uBT&) - 1, uBT&), Btr(uBT&).ItmLen - 4) ' 05-20-2001
    CALL BtSetRecPtr(ItmPtr&(uBT&) - 2, Stk&(CurLvl&(uBT&) + 1, 0), uBT&)
    GOSUB BtDecrNode
    BtErr& = 1
    IF CurRec&(uBT&) = Btr(uBT&).RootNode AND ASC(RecBuf$(uBT&)) = 0 THEN
       Btr(uBT&).RootNode = Stk&(CurLvl&(uBT&) + 1, 0)
       CALL BtSetRecPtr(0, Btr(uBT&).LastDel, uBT&)
       Btr(uBT&).LastDel = CurRec&(uBT&)
       Btr(uBT&).NumAct = Btr(uBT&).NumAct - 1
    ELSEIF (CurRec&(uBT&) <> Btr(uBT&).RootNode) AND (ASC(RecBuf$(uBT&)) < Btr(uBT&).HlfNode) THEN
       BtErr& = 0
    END IF
    GOSUB BtWriteFth
    Tmp2$ = MID$(RecBuf$(uBT&), 6, Btr(uBT&).ItmLen * ASC(RecBuf$(uBT&)))
    Temp$ = Temp$ + MKL$(BtGetRecPtr(0, uBT&)) + Tmp2$
'
    Tmp2$ = MID$(RecBuf$(uBT&), 2, LEN(Temp$)) ' 05-05-2001
'
    LSET Tmp2$ = Temp$
    MID$(RecBuf$(uBT&), 2, LEN(Temp$)) = Tmp2$
    ASC(RecBuf$(uBT&), 1) = Btr(uBT&).HlfNode * 2
    ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    IF BtErr& = 0 THEN GOSUB BtPop
    RETURN
'
BtShfFmRht:
    FOR Cnt& = ItmPtr&(uBT&) TO ASC(RecBuf$(uBT&))
        CALL BtSetItm(Cnt&, BtGetItm$(Cnt& + 1, uBT&), uBT&)
    NEXT
    RETURN
'
BtWriteFth:
    ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
    CurLvl&(uBT&) = CurLvl&(uBT&) + 1
    GOSUB BtGetStackNode
    RETURN
'
BtGetMVBL:
    GOSUB BtGetCur
    WrkHlf& = INT((ASC(RecBuf$(uBT&)) - Btr(uBT&).HlfNode + 1) / 2)
    RETURN
'
BtRepFthItem:
    Tmp2$ = MKL$(BtGetRecPtr(ItmPtr&(uBT&), uBT&))
    CALL BtSetItm(ItmPtr&(uBT&), TmpAdd$, uBT&)
    CALL BtSetRecPtr(ItmPtr&(uBT&), CVL(Tmp2$), uBT&)
    RETURN
'
END FUNCTION'BT
'
FUNCTION dvBtClose& ALIAS "dvBtClose" (BYVAL hBtFile&) EXPORT
'
    uBT& = BtTestBuffer(hBtFile&)
  ' Write the record before closing it
    LSET RecBuf$(uBT&) = Btr(uBT&)
    FUNCTION = FPutR(hBtFile&, RecBuf$(uBT&), 1)
    CALL dvFClose(hBtFile&)
'
    BtBuffer&(uBT&) = 0
    RecBuf$(uBT&) = ""
    ItmPtr&(uBT&) = 0
    CurRec&(uBT&) = 0
    CurLvl&(uBT&) = 0
'
END FUNCTION
'
FUNCTION dvBtDelete& ALIAS "dvBtDelete" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
    WasRecord& = Record&
    FUNCTION = Bt&(hBtFile&, 68, zRKey, Record&, BtErr&)
    Record& = WasRecord&
END FUNCTION
'
FUNCTION dvBtFirst& ALIAS "dvBtFirst" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
    Record& = 0
    FUNCTION = Bt&(hBtFile&, 70, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtInsert& ALIAS "dvBtInsert" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
  ' Add only unique keys
    FUNCTION = Bt&(hBtFile&, 85, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtLast& ALIAS "dvBtLast" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
    Record& = 0
    FUNCTION = Bt&(hBtFile&, 76, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtMatch& ALIAS "dvBtMatch" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
'   Must match exactly to the key
    Record& = 0
    FUNCTION = Bt&(hBtFile&, 71, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtNext& ALIAS "dvBtNext" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
    FUNCTION = Bt&(hBtFile&, 78, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtOpen& ALIAS "dvBtOpen" (zFilName AS ASCIIZ, BYVAL Klen&, hBtFile&, BtErr&) EXPORT
'
    BtErr& = 0: Pres& = dvExist(zFilName)
'
    BTMaxHalfNode& = 25
'
    Signature$ = "BT"
    CALL dvFClose(hBtFile&)
    ErrCode& = dvFOpen(zFilName, 2, 4, hBtFile&)
    IF ErrCode& = 0 THEN
'
       uBT& = 0
       BtMaxHandle& = UBOUND(BtBuffer&)
       FOR K& = 1 TO BtMaxHandle&
           IF BtBuffer&(K&) = 0 THEN
              BtBuffer&(K&) = hBtFile&: uBT& = K&: EXIT FOR
           END IF
       NEXT
       IF uBT& = 0 THEN
          uBT& = BtMaxHandle& + 1
          REDIM PRESERVE BtBuffer&(uBT&)
          REDIM PRESERVE RecBuf$(uBT&)
          REDIM PRESERVE Btr(uBT&) AS Btrecord
          REDIM PRESERVE ItmPtr&(uBT&)
          REDIM PRESERVE CurRec&(uBT&)
          REDIM PRESERVE CurLvl&(uBT&)
          BtBuffer&(uBT&) = hBtFile&
       END IF
'
       RecBuf$(uBT&) = SPACE$(1024) ' Warning this one is global and its size
                                    ' must be always 1024 !
'
       IF NOT Pres& THEN ' Create and init a new index
        ' data passed in is ALWAYS a 4 byte record pointer
        ' key passed MUST be full length
        ' Data Length + Key Pointer Length = 8
        ' how many keys will fit inside a half page
'
          Btr(uBT&).Klen = Klen&
          Btr(uBT&).KeyLen = Klen& + 4
'
          Btr(uBT&).HlfNode = (1019 \ (Btr(uBT&).Klen + 8)) \ 2
'
          IF Btr(uBT&).HlfNode < 1 THEN ' Key is too long
             BtErr& = 7              ' max Length = 501
          ELSE
             IF Btr(uBT&).HlfNode > BTMaxHalfNode& THEN
                Btr(uBT&).HlfNode = BTMaxHalfNode&
             END IF
             Btr(uBT&).DtaLen = 4
             Btr(uBT&).ItmLen = Btr(uBT&).KeyLen + 4
             Btr(uBT&).IDCode = Signature$
             Btr(uBT&).RootNode = 2
             Btr(uBT&).NxtNode = 3
             Btr(uBT&).LastDel = 0
             Btr(uBT&).NumAct = 1
             Btr(uBT&).NumKeys = 0
             LSET RecBuf$(uBT&) = Btr(uBT&)
             CALL FPutR(hBtFile&, RecBuf$(uBT&), 1)
          END IF
'
       ELSE
          CALL FGetR(hBtFile&, RecBuf$(uBT&), 1)
'
          Btr(uBT&).HlfNode = CVI(MID$(RecBuf$(uBT&), 1, 2))
          Btr(uBT&).Klen = CVI(MID$(RecBuf$(uBT&), 3, 2))
          Btr(uBT&).DtaLen = CVI(MID$(RecBuf$(uBT&), 5, 2))
          Btr(uBT&).ItmLen = CVI(MID$(RecBuf$(uBT&), 7, 2))
          Btr(uBT&).IDCode = MID$(RecBuf$(uBT&), 9, 2)
          Btr(uBT&).RootNode = CVL(MID$(RecBuf$(uBT&), 11, 4))
          Btr(uBT&).NxtNode = CVL(MID$(RecBuf$(uBT&), 15, 4))
          Btr(uBT&).LastDel = CVL(MID$(RecBuf$(uBT&), 19, 4))
          Btr(uBT&).NumAct = CVI(MID$(RecBuf$(uBT&), 23, 2))
          Btr(uBT&).NumKeys = CVL(MID$(RecBuf$(uBT&), 25, 4))
          Btr(uBT&).Filler = MID$(RecBuf$(uBT&), 29, 994)
          Btr(uBT&).KeyLen = CVI(MID$(RecBuf$(uBT&), 1023, 2))
'
        ' if no header info in memory then close file
          IF Btr(uBT&).IDCode <> Signature$ THEN
             BtErr& = 5 ' Not a valid Btree index
          END IF
       END IF
    ELSE
       BtErr& = 6
    END IF
    IF BtErr& THEN CALL dvFClose(hBtFile&)
    FUNCTION = ErrCode&
'
END FUNCTION
'
FUNCTION dvBtPrev& ALIAS "dvBtPrev" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
    FUNCTION = Bt&(hBtFile&, 80&, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtSearch& ALIAS "dvBtSearch" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
'   Perform a radical search
    Record& = 0
    FUNCTION = Bt&(hBtFile&, 83, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtKeyNbr& ALIAS "dvBtKeyNbr" (BYVAL hBtFile&) EXPORT
'   Returns the number of keys in the index.
    uBT& = BtTestBuffer&(hBtFile&)
    FUNCTION = Btr(uBT&).NumKeys
END FUNCTION
'
' Version 2.02 ----------------------------------------------------
FUNCTION dvBtBefore& ALIAS "dvBtBefore" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
    KeyIn$ = zRKey
    FUNCTION = Bt&(hBtFile&, 66&, zRKey, Record&, BtErr&)
    IF LEN(zRKey) AND zRKey > KeyIn$ THEN
       Record& = 0: zRKey = "": IF Bterr& = 0 THEN Bterr& = 1
    END IF
END FUNCTION
'
FUNCTION dvBtAfter& ALIAS "dvBtAfter" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
'
    KeyIn$ = zRKey
'
    ' 06-26-2002 Jean-Pierre LEROY
    IF Bt&(hBtFile&, 70, zRKey, FirstRecord&, BtErrFirst&) = 0 THEN FirstKey$ = zRKey
    zRKey = KeyIn$

    FUNCTION = Bt&(hBtFile&, 66&, zRKey, Record&, BtErr&)
    IF LEN(zRKey) AND zRKey < KeyIn$ THEN
       FUNCTION = dvBtNext(hBtFile&, zRKey, Record&, BtErr&)
    ELSE
       IF LEN(FirstKey$) AND KeyIn$ < FirstKey$ THEN ' 06-26-2002 Jean-Pierre LEROY
            Record& = FirstRecord&
            zRKey = FirstKey$
            BtErr& = BtErrFirst&
            EXIT FUNCTION
       END IF
       FUNCTION = Bt&(hBtFile&, 69&, zRKey, Record&, BtErr&)
    END IF
END FUNCTION