OPTION Explicit

'constants
Global CONST WINSTATE_NORMAL = 0
Global CONST WINSTATE_MINIMIZED = 1
Global CONST WINSTATE_MAXIMIZED = 2

Global CONST MODAL = 1
Global CONST MODLESS = 0

Global CONST MOUSE_DEFAULT = 0
Global CONST MOUSE_CROSS = 2
Global CONST MOUSE_MOVE = 5
Global CONST MOUSE_HOURGLASS = 11

Global CONST WM_USER = &H400
Global CONST EM_GETSEL = WM_USER + 0
Global CONST EM_SETSEL = WM_USER + 1
Global CONST EM_GETRECT = WM_USER + 2
Global CONST EM_SETRECT = WM_USER + 3
Global CONST EM_LINEINDEX = WM_USER + 11
Global CONST EM_LINELENGTH = WM_USER + 17
Global CONST EM_GETLINE = WM_USER + 20

Global CONST DB_LANG_GENERAL = ";LANGID=0x0809;CP=1252;COUNTRY=0"
' Field Data Types
Global CONST DB_BOOLEAN = 1
Global CONST DB_BYTE = 2
Global CONST DB_INTEGER = 3
Global CONST DB_LONG = 4
Global CONST DB_CURRENCY = 5
Global CONST DB_SINGLE = 6
Global CONST DB_DOUBLE = 7
Global CONST DB_DATE = 8
Global CONST DB_TEXT = 10
Global CONST DB_LONGBINARY = 11
Global CONST DB_MEMO = 12

'defined types
TYPE TableSpec          'field specs for a db table
    strName AS STRING
    intType AS INTEGER
    intSize AS INTEGER
END TYPE

TYPE IndexSpec          'index specs for a db table
    strName AS STRING
    strDesc AS STRING
    intPrim AS INTEGER
    intUniq AS INTEGER
END TYPE

SUB BuildFileList (strDirName AS STRING, strFiles() AS STRING)
    'this will take all of the file names  in strDirName and put them into strFiles
    'be sure to dimention the array before calling this (use dim strFiles(0) as string)
    'make sure strDirName ends with a '\'
    DIM strFileName AS STRING
    REDIM strFiles(0)
   
    strFileName = Dir$(strDirName, 6)  ' 6 indicates normal hidden and special files
    DO UNTIL strFileName = ""
        IF strFiles(UBOUND(strFiles)) <> "" THEN    ' increase dimention if last field is filled
            REDIM Preserve strFiles(UBOUND(strFiles) + 1)' use preserve to keep old entries
        END IF
        strFiles(UBOUND(strFiles)) = strFileName 'add it to the array
        strFileName = Dir$ 'get the next filename from the list
    LOOP
END SUB

FUNCTION CountOf (strMain, strDelim) AS INTEGER
' count the number of strDelim in strMain
DIM intCount AS INTEGER
DIM intLpCnt AS INTEGER
DIM intCharPos AS INTEGER
DIM intMainLen AS INTEGER
DIM intDelimLen AS INTEGER

'initialize
intCount = 0
intMainLen = LEN(strMain)
intDelimLen = LEN(strDelim)
CountOf = 0
intCharPos = 1

IF strDelim = "" THEN EXIT FUNCTION

DO
    intCharPos = INSTR(intCharPos, strMain, strDelim)
    IF intCharPos = 0 THEN
        EXIT DO
    END IF
    intCount = intCount + 1
    intCharPos = intCharPos + intDelimLen
LOOP

CountOf = intCount

END FUNCTION

FUNCTION CreateTable (dbOpen AS Database, strTableName AS STRING, udtFSpecs() AS TableSpec, udtISpecs() AS IndexSpec) AS INTEGER
    'creates a new table in an open database
    'if the table exists, it is removed and rebuilt

'declarations
DIM tblNew AS New TableDef
DIM fldNew AS FIELD
DIM indNew AS Index
DIM intLpCnt AS INTEGER

'inititalization
CreateTable = False

'main()

    'search to see if table exists
    ON ERROR GOTO errKillTable
    dbOpen.TableDefs.Refresh
    FOR intLpCnt = 0 TO dbOpen.TableDefs.Count - 1
        IF UCase(dbOpen.TableDefs(intLpCnt).NAME) = UCase(strTableName) THEN
            dbOpen.TableDefs.Delete dbOpen.TableDefs(strTableName)
            EXIT FOR
            DoEvents
        END IF
    NEXT
   
    ON ERROR GOTO errTableCreate
    'create the tabledef
    tblNew.NAME = strTableName

    'create the first field in the tabledef
    Set fldNew = New FIELD
    fldNew.NAME = udtFSpecs(0).strName
    fldNew.TYPE = udtFSpecs(0).intType
    fldNew.Size = udtFSpecs(0).intSize
    tblNew.Fields.APPEND fldNew
   
    'append the tabledef to the database
    dbOpen.TableDefs.APPEND tblNew
   
    'now add all other fields
    FOR intLpCnt = 1 TO UBOUND(udtFSpecs)
        Set fldNew = New FIELD
        fldNew.NAME = udtFSpecs(intLpCnt).strName
        fldNew.TYPE = udtFSpecs(intLpCnt).intType
        fldNew.Size = udtFSpecs(intLpCnt).intSize
        dbOpen.TableDefs(tblNew.NAME).Fields.APPEND fldNew
        DoEvents
    NEXT intLpCnt

    CreateTable = True

    ' add the indecies
    ON ERROR GOTO errIndexCreate
    FOR intLpCnt = 0 TO UBOUND(udtISpecs)
        IF udtISpecs(intLpCnt).strName = "" THEN EXIT FOR
        Set indNew = New Index
        indNew.NAME = udtISpecs(intLpCnt).strName
        indNew.Fields = udtISpecs(intLpCnt).strDesc
        indNew.Unique = udtISpecs(intLpCnt).intUniq
        indNew.Primary = udtISpecs(intLpCnt).intPrim
        dbOpen.TableDefs(tblNew.NAME).Indexes.APPEND indNew
        DoEvents
ndIndexCreate:
    NEXT intLpCnt
    dbOpen.TableDefs.Refresh
ndCreateTable:

EXIT FUNCTION

errKillTable:
    MsgBox "Could not remove table '" & strTableName & "'"
    RESUME ndCreateTable

errTableCreate:
    MsgBox "Could not create table '" & strTableName & "'.  Err# " & ERR & " - " & ERROR$(ERR)
    'dbOpen.TableDefs.Delete dbOpen.TableDefs(strTableName)
    ON ERROR RESUME NEXT
    RESUME ndCreateTable

errIndexCreate:
    ON ERROR RESUME NEXT
    IF ERR <> 9 THEN
        MsgBox "Index '" & udtISpecs(intLpCnt).strName & "' not created!"
        RESUME ndIndexCreate
    ELSE
        RESUME ndCreateTable
    END IF

END FUNCTION

FUNCTION GetField (strMain AS STRING, intPos AS INTEGER, strDelim AS STRING) AS STRING
'return the intPos string of strMain delimited by strDelim
DIM intMainLen AS INTEGER
DIM intDelimLen AS INTEGER
DIM intFieldCnt AS INTEGER
DIM strOutPut AS STRING
DIM strParsing AS STRING
DIM intCharPos AS INTEGER
DIM intLastPos AS INTEGER

IF intPos = 0 THEN
    GetField = strMain
    EXIT FUNCTION
END IF

'initialize
GetField = ""
intMainLen = LEN(strMain)
intDelimLen = LEN(strDelim)
intLastPos = 1
intFieldCnt = 1
strOutPut = ""
strParsing = ""

intCharPos = 1
DO
    intCharPos = INSTR(intCharPos, strMain, strDelim)
    IF intCharPos = 0 THEN
        IF intFieldCnt = intPos THEN
            strOutPut = MID$(strMain, intLastPos)
        END IF
        EXIT DO
    END IF
    IF intFieldCnt = intPos THEN
        strOutPut = MID$(strMain, intLastPos, intCharPos - intLastPos)
        EXIT DO
    END IF
    intLastPos = intCharPos + intDelimLen
    intCharPos = intCharPos + 1
    intFieldCnt = intFieldCnt + 1
LOOP

IF intFieldCnt = intPos THEN GetField = strOutPut

   
END FUNCTION

FUNCTION isValidFile (strPath AS STRING) AS INTEGER
    'checks for valid existing filespec
    DIM strRC AS STRING
    DIM intValid AS INTEGER
   
    ON ERROR GOTO ErrIsValidFile
    intValid = False
    IF RIGHT$(strPath, 1) <> "\" THEN
        strRC = Dir$(strPath)
        IF strRC <> "" THEN
            strRC = Dir$
            IF strRC = "" THEN intValid = True
        END IF
    END IF
NDIsValidFile:
    isValidFile = intValid
EXIT FUNCTION
ErrIsValidFile:
    RESUME NDIsValidFile
END FUNCTION

FUNCTION IsValidPath (strPath AS STRING) AS INTEGER
    'checks for valid existing path
    DIM strRC AS STRING
    DIM intValid AS INTEGER
   
    ON ERROR GOTO ErrIsValidPath
    intValid = False
    IF RIGHT$(strPath, 1) = "\" THEN
        strRC = Dir$(strPath)
        IF strRC <> "" THEN
            intValid = True
        END IF
    END IF
NDIsValidPath:
    IsValidPath = intValid
EXIT FUNCTION
ErrIsValidPath:
    RESUME NDIsValidPath
END FUNCTION

FUNCTION JulianDate (dblDate AS DOUBLE) AS INTEGER
    'returns julian date for dlbDate
    DIM dblJan1 AS DOUBLE   'january 1st of whatever year
    DIM intJulian AS INTEGER
    DIM strYear AS STRING 'year for conversion

    strYear = Format$(dblDate, "yyyy")
    dblJan1 = CVDate("01/01/" & strYear)
    intJulian = DateDiff("y", dblJan1, dblDate)
    JulianDate = intJulian + 1
END FUNCTION

FUNCTION Numerics (strTest AS STRING) AS STRING
    'given a string, returns only the characters that are numbers
DIM strRtn AS STRING
DIM strTemp AS STRING
DIM intTestLen AS INTEGER
DIM intLpCnt AS INTEGER

    strRtn = ""
    intTestLen = LEN(strTest)
    FOR intLpCnt = 1 TO intTestLen
        strTemp = MID$(strTest, intLpCnt, 1)
        IF IsNumeric(strTemp) THEN
            strRtn = strRtn & strTemp
        END IF
    NEXT intLpCnt
    Numerics = strRtn
END FUNCTION

FUNCTION Replace (strMain AS STRING, strOld AS STRING, strNew AS STRING, intTimes AS INTEGER) AS STRING
'replace strOld with strNew in strMain intTimes times
'if intTimes is 0 replace all
DIM intMainLen AS INTEGER
DIM intOldLen AS INTEGER
DIM intNewLen AS INTEGER
DIM intReplCnt AS INTEGER
DIM intCharCnt AS INTEGER
DIM intLastPos AS INTEGER
DIM intReplFlag AS INTEGER
DIM strOutPut AS STRING

IF strOld = "" THEN
    Replace = strMain
    EXIT FUNCTION
END IF

'initialize
intMainLen = LEN(strMain)
intOldLen = LEN(strOld)
intNewLen = LEN(strNew)
intReplCnt = 0
strOutPut = ""
Replace = ""
intCharCnt = 1
intLastPos = 1

IF intTimes < 0 THEN
    MsgBox "Invalid paramater passed."
    Replace = strMain
    EXIT FUNCTION
END IF

DO
    IF intReplCnt <> 0 THEN
        IF intReplCnt = intTimes THEN
            strOutPut = strOutPut & MID$(strMain, intLastPos)
            EXIT DO
        END IF
    END IF
    intCharCnt = INSTR(intCharCnt, strMain, strOld)
    IF intCharCnt = 0 THEN
        strOutPut = strOutPut & MID$(strMain, intLastPos)
        EXIT DO
    END IF
    strOutPut = strOutPut & MID$(strMain, intLastPos, (intCharCnt - intLastPos)) & strNew
    intLastPos = intCharCnt + intOldLen
    intCharCnt = intCharCnt + intOldLen
    intReplCnt = intReplCnt + 1
   
LOOP

Replace = strOutPut

END FUNCTION

SUB SLEEP (intTime AS INTEGER)
DIM dblTime AS DOUBLE
    dblTime = TIMER
    DO UNTIL TIMER > dblTime + intTime
        DoEvents
    LOOP
END SUB

FUNCTION StringCompress (strMain AS STRING, strChar AS STRING) AS STRING
DIM strNew AS STRING
DIM strTemp AS STRING * 1
DIM intSizeOf AS INTEGER
DIM intLpCnt AS INTEGER
    'squeezes multiple occurances of strChar into one
    ON ERROR RESUME NEXT
strNew = strMain
DO
    intLpCnt = INSTR(strNew, strChar & strChar)
    IF intLpCnt = 0 THEN EXIT DO
    strNew = MID$(strNew, 1, intLpCnt) & Mid(strNew, intLpCnt + 2)
LOOP
StringCompress = strNew
END FUNCTION