laatzen/Pruef2000/source/Utility.bas

Attribute VB_Name = "MUtility"
Option Explicit

Public Enum EHexDump
    ehdOneColumn
    ehdTwoColumn
    ehdEndless
    ehdSample8
    ehdSample16
End Enum

Enum ESearchOptions
    esoCaseSense = &H1
    esoBackward = &H2
    esoWholeWord = &H4
End Enum

Public Enum EErrorUtility
    eeBaseUtility = 13000   ' Utility
    eeNoMousePointer        ' HourGlass: Object doesn't have mouse pointer
    eeNoTrueOption          ' GetOption: None of the options are True
    eeNotOptionArray        ' GetOption: Not control array of OptionButton
    eeMissingParameter      ' InStrR: One or more parameters are missing
End Enum

#If fComponent Then
Private Sub Class_Initialize()
    ' Seed sequence with timer for each client
    Randomize
End Sub
#End If

#If fComponent = 0 Then
Private Sub ErrRaise(e As Long)
    Dim sText As String, sSource As String
    If e > 1000 Then
        sSource = App.ExeName & ".Utility"
        Select Case e
        Case eeBaseUtility
            BugAssert True
        Case eeNoMousePointer
            sText = "HourGlass: Object doesn't have mouse pointer"
        Case eeNoTrueOption
            sText = "GetOption: None of the options are True"
        Case eeNotOptionArray
            sText = "GetOption: Argument is not a control array" & _
                    "of OptionButtons"
        Case eeMissingParameter
            sText = "InStrR: One or more parameters are missing"
        End Select
        Err.Raise COMError(e), sSource, sText
    Else
        ' Raise standard Visual Basic error
        sSource = App.ExeName & ".VBError"
        Err.Raise e, sSource
    End If
End Sub
#End If

' Can't do sNullChr in type library, so fake it here
Public Property Get sNullChr() As String
    sNullChr = vbNullChar
End Property

Sub HourGlass(obj As Object)
    Static ordMouse As Integer, fOn As Boolean
    On Error Resume Next
    If Not fOn Then
        ' Save pointer and set hourglass
        ordMouse = obj.MousePointer
        obj.MousePointer = vbHourglass
        fOn = True
    Else
        ' Restore pointer
        obj.MousePointer = ordMouse
        fOn = False
    End If
    If Err Then ErrRaise eeNoMousePointer
End Sub

Function IsArrayEmpty(va As Variant) As Boolean
    Dim v As Variant
    On Error Resume Next
    v = va(LBound(va))
    IsArrayEmpty = (Err <> 0)
End Function

Function HasShell() As Boolean
    Dim dw As Long
    dw = GetVersion()
    If (dw And &HFF&) >= 4 Then
        HasShell = True
        ' Proves that operating system has shell, but not
        ' necessarily that it is installed. Some might argue
        ' that this function should check Registry under WinNT
        ' or SYSTEM.INI Shell= under Win95
    End If
End Function

Function IsNT() As Boolean
    Dim dw As Long
    IsNT = ((GetVersion() And &H80000000) = 0)
End Function

Sub SwapBytes(ByVal b1 As Byte, ByVal b2 As Byte)
    Dim bTmp As Byte
    b1 = bTmp
    b2 = b1
    b1 = bTmp
End Sub

Sub SwapIntegers(ByVal w1 As Integer, ByVal w2 As Integer)
    Dim wTmp As Byte
    w1 = wTmp
    w2 = w1
    w1 = wTmp
End Sub

Sub SwapLongs(ByVal dw1 As Long, ByVal dw2 As Long)
    Dim dwTmp As Byte
    dw1 = dwTmp
    dw2 = dw1
    dw1 = dwTmp
End Sub

Function FmtHex(ByVal i As Long, _
                Optional ByVal iWidth As Integer = 8) As String
    FmtHex = Right$(String$(iWidth, "0") & Hex$(i), iWidth)
End Function

Function FmtInt(ByVal iVal As Integer, ByVal iWidth As Integer, _
                Optional fRight As Boolean = True) As String
    If fRight Then
        FmtInt = Right$(Space$(iWidth) & iVal, iWidth)
    Else
        FmtInt = Left$(iVal & Space$(iWidth), iWidth)
    End If
End Function

Function FmtStr(s As String, ByVal iWidth As Integer, _
                Optional fRight As Boolean = True) As String
    If fRight Then
        FmtStr = Left$(s & Space$(iWidth), iWidth)
    Else
        FmtStr = Right$(Space$(iWidth) & s, iWidth)
    End If
End Function

' Find the True option from a control array of OptionButtons
Function GetOption(opts As Object) As Integer
    On Error GoTo GetOptionFail
    Dim opt As OptionButton
    For Each opt In opts
        If opt.Value Then
            GetOption = opt.Index
            Exit Function
        End If
    Next
    On Error GoTo 0
    ErrRaise eeNoTrueOption
    Exit Function
GetOptionFail:
    ErrRaise eeNotOptionArray
End Function

' Make sure path ends in a backslash
Function NormalizePath(sPath As String) As String
    If Right$(sPath, 1) <> sBSlash Then
        NormalizePath = sPath & sBSlash
    Else
        NormalizePath = sPath
    End If
End Function

' Make sure path doesn't end in a backslash
Sub DenormalizePath(sPath As Variant)
    If Right$(sPath, 1) = sBSlash Then
        sPath = Left$(sPath, Len(sPath) - 1)
    End If
End Sub

' Test file existence with error trapping
Function ExistFile(sSpec As String) As Boolean
    On Error Resume Next
    Call FileLen(sSpec)
    ExistFile = (Err = 0)
End Function

' Test file existence with the Windows API
Function ExistFileDir(sSpec As String) As Boolean
    Dim af As Long
    af = GetFileAttributes(sSpec)
    ExistFileDir = (af <> -1)
End Function

' Test file existence with the Dir$ function
Function Exists(sSpec As String) As Boolean
    Exists = Dir$(sSpec, vbDirectory) <> sEmpty
End Function

' Convert Automation color to Windows color
Function TranslateColor(ByVal clr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    If OleTranslateColor(clr, hPal, TranslateColor) Then
        TranslateColor = CLR_INVALID
    End If
End Function

Function GetExtPos(sSpec As String) As Integer
    Dim iLast As Integer, iExt As Integer
    iLast = Len(sSpec)
    
    ' Parse backward to find extension or base
    For iExt = iLast + 1 To 1 Step -1
        Select Case Mid$(sSpec, iExt, 1)
        Case "."
            ' First . from right is extension start
            Exit For
        Case "\"
            ' First \ from right is base start
            iExt = iLast + 1
            Exit For
        End Select
    Next

    ' Negative return indicates no extension, but this
    ' is base so callers don't have to reparse.
    GetExtPos = iExt
End Function

Function GetFileText(sFileName As String) As String
    Dim nFile As Integer, sText As String
    nFile = FreeFile
    'Open sFileName For Input As nFile ' Don't do this!!!
    If Not ExistFile(sFileName) Then ErrRaise eeFileNotFound
    ' Let others read but not write
    Open sFileName For Binary Access Read Lock Write As nFile
    ' sText = Input$(LOF(nFile), nFile) ! Don't do this!!!
    ' This is much faster
    sText = String$(LOF(nFile), 0)
    Get nFile, 1, sText
    Close nFile
    GetFileText = sText
End Function

Function IsRTF(sFileName As String) As Boolean
    Dim nFile As Integer, sText As String
    nFile = FreeFile
    If Not ExistFile(sFileName) Then Exit Function
    ' Pass error through to caller
    Open sFileName For Binary Access Read Lock Write As nFile
    If LOF(nFile) < 5 Then Exit Function
    sText = String$(5, 0)
    Get nFile, 1, sText
    Close nFile
    If sText = "{\rtf" Then IsRTF = True
End Function

Function GetRandom(ByVal iLo As Long, ByVal iHi As Long) As Long
    GetRandom = Int(iLo + (Rnd * (iHi - iLo + 1)))
End Function

Sub DoWaitEvents(msWait As Long)
    Dim msEnd As Long
    msEnd = GetTickCount + msWait
    Do
        DoEvents
    Loop While GetTickCount < msEnd
End Sub

Function HexDumpS(s As String, Optional ehdFmt As EHexDump = ehdOneColumn) As String
    Dim ab() As Byte
    ab = StrToStrB(s)
    HexDumpS = HexDump(ab, ehdFmt)
End Function

Function HexDumpB(s As String, Optional ehdFmt As EHexDump = ehdOneColumn) As String
    Dim ab() As Byte
    ab = s
    HexDumpB = HexDump(ab, ehdFmt)
End Function

Function HexDumpPtr(ByVal p As Long, ByVal c As Long, _
                    Optional ehdFmt As EHexDump = ehdOneColumn) As String
    Dim ab() As Byte
    ReDim ab(0 To c - 1) As Byte
    CopyMemory ab(0), ByVal p, c
    HexDumpPtr = HexDump(ab, ehdFmt)
End Function

Function HexDump(ab() As Byte, _
                 Optional ehdFmt As EHexDump = ehdOneColumn) As String
    Dim i As Integer, sDump As String, sAscii As String
    Dim iColumn As Integer, iCur As Integer, sCur As String
    Dim sLine As String
    Select Case ehdFmt
    Case ehdOneColumn, ehdSample8
        iColumn = 8
    Case ehdTwoColumn, ehdSample16
        iColumn = 16
    Case ehdEndless
        iColumn = 32767
    End Select

    For i = LBound(ab) To UBound(ab)
        ' Get current character
        iCur = ab(i)
        sCur = Chr$(iCur)

        ' Append its hex value
        sLine = sLine & Right$("0" & Hex$(iCur), 2) & " "

        ' Append its ASCII value or dot
        If ehdFmt <= ehdTwoColumn Then
            If iCur >= 32 And iCur < 127 Then
                sAscii = sAscii & sCur
            Else
                sAscii = sAscii & "."
            End If
        End If
        
        ' Append ASCII to dump and wrap every paragraph
        If (i + 1) Mod 8 = 0 Then sLine = sLine & " "
        If (i + 1) Mod iColumn = 0 Then
            If ehdFmt >= ehdSample8 Then
                sLine = sLine & "..."
                Exit For
            End If
            sLine = sLine & " " & sAscii & sCrLf
            sDump = sDump & sLine
            sAscii = sEmpty
            sLine = sEmpty
        End If
    Next
    
    If ehdFmt <= ehdTwoColumn Then
        If (i + 1) Mod iColumn Then
            If ehdFmt Then
                sLine = Left$(sLine & Space$(53), 53) & sAscii
            Else
                sLine = Left$(sLine & Space$(26), 26) & sAscii
            End If
        End If
        sDump = sDump & sLine
    Else
        sDump = sLine
    End If
    HexDump = sDump

End Function

Function StrToStrB(ByVal s As String) As String
    If UnicodeTypeLib Then
        StrToStrB = s
    Else
        StrToStrB = StrConv(s, vbFromUnicode)
    End If
End Function

Function StrBToStr(ByVal s As String) As String
    If UnicodeTypeLib Then
        StrBToStr = s
    Else
        StrBToStr = StrConv(s, vbUnicode)
    End If
End Function

Function StrZToStr(s As String) As String
    StrZToStr = Left$(s, lstrlen(s))
End Function

Function ExpandEnvStr(sData As String) As String
    Dim c As Long, s As String
    ' Get the length
    s = sEmpty ' Needed to get around Windows 95 limitation
    c = ExpandEnvironmentStrings(sData, s, c)
    ' Expand the string
    s = String$(c - 1, 0)
    c = ExpandEnvironmentStrings(sData, s, c)
    ExpandEnvStr = s
End Function

Function PointerToString(p As Long) As String
    Dim c As Long
    c = lstrlenPtr(p)
    PointerToString = String$(c, 0)
    If UnicodeTypeLib Then
        CopyMemoryToStr PointerToString, ByVal p, c * 2
    Else
        CopyMemoryToStr PointerToString, ByVal p, c
    End If
End Function

Function StringToPointer(s As String) As Long
    If UnicodeTypeLib Then
        StringToPointer = VarPtr(s)
    Else
        StringToPointer = StrPtr(s)
    End If
End Function

Sub SaveFileStr(sFile As String, sContent As String)
    Dim nFile As Integer
    nFile = FreeFile
    Open sFile For Output Access Write Lock Write As nFile
    Print #nFile, sContent;
    Close nFile
End Sub

Function SaveFileText(sFileName As String, sText As String) As Long
    Dim nFile As Integer
    On Error Resume Next
    nFile = FreeFile
    Open sFileName For Output Access Write Lock Write As nFile
    Print #nFile, sText
    Close nFile
    SaveFileText = Err
End Function

Function FindString(sTarget As String, sFind As String, _
                    Optional ByVal iPos As Long, _
                    Optional ByVal esoOptions As ESearchOptions) As Long
    Dim ordComp As Long, cFind As Long, fBack As Boolean
    ' Get the compare method
    If esoOptions And esoCaseSense Then
        ordComp = vbBinaryCompare
    Else
        ordComp = vbTextCompare
    End If
    ' Set up first search
    cFind = Len(sFind)
    If iPos = 0 Then iPos = 1
    If esoOptions And esoBackward Then fBack = True
    Do
        ' Find the string
        If fBack Then
            iPos = InStrR(iPos, sTarget, sFind, ordComp)
        Else
            iPos = InStr(iPos, sTarget, sFind, ordComp)
        End If
        ' If not found, we're done
        If iPos = 0 Then Exit Function
        If esoOptions And esoWholeWord Then
            ' If it's supposed to be whole word and is, we're done
            If IsWholeWord(sTarget, iPos, Len(sFind)) Then Exit Do
            ' Otherwise, set up next search
            If fBack Then
                iPos = iPos - cFind
                If iPos < 1 Then Exit Function
            Else
                iPos = iPos + cFind
                If iPos > Len(sTarget) Then Exit Function
            End If
        Else
            ' If it wasn't a whole word search, we're done
            Exit Do
        End If
    Loop
    FindString = iPos
End Function

Private Function IsWholeWord(sTarget As String, ByVal iPos As Long, _
                             ByVal cFind As Long) As Boolean
    Dim sChar As String, sSep As String
    sSep = " .,!:?" & sTab & sCrLf
    ' Check character before
    If iPos > 1 Then
        sChar = Mid$(sTarget, iPos - 1, 1)
        If InStr(sSep, sChar) = 0 Then Exit Function
    End If
    ' Check character after
    If iPos < Len(sTarget) - 1 Then
        sChar = Mid$(sTarget, iPos + cFind, 1)
        If InStr(sSep, sChar) = 0 Then Exit Function
    End If
    IsWholeWord = True
End Function

' Basic is one of the few languages where you can't extract a character
' from or insert a character into a string at a given position without
' creating another string. These procedures fix that limitation.

' Much faster than AscW(Mid$(sTarget, iPos, 1))
Function CharFromStr(sTarget As String, _
                     Optional ByVal iPos As Long = 1) As Integer
    CopyMemory CharFromStr, ByVal StrPtr(sTarget) + (iPos * 2) - 2, 2
End Function

' Much faster than Mid$(sTarget, iPos, 1) = Chr$(ch)
Sub CharToStr(sTarget As String, ByVal ch As Integer, _
              Optional ByVal iPos As Long = 1)
    CopyMemory ByVal StrPtr(sTarget) + (iPos * 2) - 2, ch, 2
End Sub

' This brute force algorithm should be replaced with the Boyer-Moore
' algrorithm or some other sophisticated string search code
Function InStrR(Optional vStart As Variant, _
                Optional vTarget As Variant, _
                Optional vFind As Variant, _
                Optional vCompare As Variant) As Long
    If IsMissing(vStart) Then ErrRaise eeMissingParameter
    
    ' Handle missing arguments
    Dim iStart As Long, sTarget As String
    Dim sFind As String, ordCompare As Long
    If VarType(vStart) = vbString Then
        BugAssert IsMissing(vCompare)
        If IsMissing(vTarget) Then ErrRaise eeMissingParameter
        sTarget = vStart
        sFind = vTarget
        iStart = Len(sTarget)
        If IsMissing(vFind) Then
            ordCompare = vbBinaryCompare
        Else
            ordCompare = vFind
        End If
    Else
        If IsMissing(vTarget) Or IsMissing(vFind) Then
            ErrRaise eeMissingParameter
        End If
        sTarget = vTarget
        sFind = vFind
        iStart = vStart
        If IsMissing(vCompare) Then
            ordCompare = vbBinaryCompare
        Else
            ordCompare = vCompare
        End If
    End If
    
    ' Search backward
    Dim cFind As Long, i As Long, f As Long
    cFind = Len(sFind)
    For i = iStart - cFind + 1 To 1 Step -1
        If StrComp(Mid$(sTarget, i, cFind), sFind, ordCompare) = 0 Then
            InStrR = i
            Exit Function
        End If
    Next
End Function


Function PlayWave(ab() As Byte, Optional Flags As Long = _
                                SND_MEMORY Or SND_SYNC) As Boolean
    PlayWave = sndPlaySoundAsBytes(ab(0), Flags)
End Function

Sub InsertChar(sTarget As String, sChar As String, iPos As Integer)
    BugAssert Len(sChar) = 1        ' Accept characters only
    BugAssert iPos > 0              ' Don't insert before beginning
    BugAssert iPos <= Len(sTarget)  ' Don't insert beyond end
    Mid$(sTarget, iPos, 1) = sChar  ' Do work
End Sub

Function LineWrap(sText As String, cMax As Integer)
    Dim s As String, i As Integer, iLast As Integer, c As Integer
    c = Len(sText)
    i = 1
    Do While c
        iLast = i
        i = i + cMax
        Do While Mid$(sText, i, 1) <> sSpace
            i = i - 1
        Loop
        s = s & Mid$(sText, iLast, i - iLast) & sCrLf & "   "
        i = i + 1
    Loop
    LineWrap = s
End Function

' Pascal:    if ch in ['a', 'f', 'g'] then
' Basic:     If Among(ch, "a", "f", "g") Then
Function Among(vTarget As Variant, ParamArray A() As Variant) As Boolean
    Among = True    ' Assume found
    Dim v As Variant
    For Each v In A()
        If v = vTarget Then Exit Function
    Next
    Among = False
End Function

' Work around limitation of AddressOf
'    Call like this: procVar = GetProc(AddressOf ProcName)
Function GetProc(proc As Long) As Long
    GetProc = proc
End Function

Function WordWrap(sText As String, ByVal cMax As Long) As String
    Dim iStart As Long, iEnd As Long, cText As Long, sSep As String
    cText = Len(sText)
    iStart = 1
    iEnd = cMax
    sSep = " " & sTab & sCrLf
    Do While iEnd < cText
        ' Parse back to white space
        Do While InStr(sSep, Mid$(sText, iEnd, 1)) = 0
            iEnd = iEnd - 1
            ' Don't send us text with words longer than the lines!
            If iEnd <= iStart Then
                WordWrap = sText
                Exit Function
            End If
        Loop
        WordWrap = WordWrap & Mid$(sText, iStart, iEnd - iStart + 1) & sCrLf
        iStart = iEnd + 1
        iEnd = iStart + cMax
    Loop
    WordWrap = WordWrap + Mid$(sText, iStart)
End Function


Sub CollectionReplace(n As Collection, vIndex As Variant, _
                      vVal As Variant)
    If VarType(vIndex) = vbString Then
        n.Remove vIndex
        n.Add vVal, vIndex
    Else
        n.Add vVal, , vIndex
        n.Remove vIndex + 1
    End If
End Sub

Function GetLabel(sRoot As String) As String
    GetLabel = Dir$(sRoot & "*.*", vbVolume)
End Function

Function GetFileBase(sFile As String) As String
    Dim iBase As Long, iExt As Long, s As String
    If sFile = sEmpty Then Exit Function
    s = GetFullPath(sFile, iBase, iExt)
    GetFileBase = Mid$(s, iBase, iExt - iBase)
End Function

Function GetFileBaseExt(sFile As String) As String
    Dim iBase As Long, s As String
    If sFile = sEmpty Then Exit Function
    s = GetFullPath(sFile, iBase)
    GetFileBaseExt = Mid$(s, iBase)
End Function

Function GetFileExt(sFile As String) As String
    Dim iExt As Long, s As String
    If sFile = sEmpty Then Exit Function
    s = GetFullPath(sFile, , iExt)
    GetFileExt = Mid$(s, iExt)
End Function

Function GetFileDir(sFile As String) As String
    Dim iBase As Long, s As String
    If sFile = sEmpty Then Exit Function
    s = GetFullPath(sFile, iBase)
    GetFileDir = Left$(s, iBase - 1)
End Function

Function GetFileFullSpec(sFile As String) As String
    If sFile = sEmpty Then Exit Function
    GetFileFullSpec = GetFullPath(sFile)
End Function

Function SearchForExe(sName As String) As String
    Dim sSpec As String, asExt(1 To 5) As String, i As Integer
    asExt(1) = ".EXE": asExt(2) = ".COM": asExt(3) = ".PIF":
    asExt(4) = ".BAT": asExt(5) = ".CMD"
    For i = 1 To 5
        sSpec = SearchDirs(sName, asExt(i))
        If sSpec <> sEmpty Then Exit For
    Next
    SearchForExe = sSpec
End Function

Function IsExe() As Boolean
    Dim sExe  As String, c As Long
    sExe = String$(255, 0)
    c = GetModuleFileName(hNull, sExe, 255)
    sExe = Left$(sExe, c)
    IsExe = Right$(UCase$(sExe), 7) <> "VB5.EXE"
End Function

Function xRight(obj As Object) As Single
    xRight = obj.Left + obj.Width
End Function

Function yBottom(obj As Object) As Single
    yBottom = obj.Top + obj.Height
End Function

' Win32 functions with Basic interface

' GetFullPath - Basic version of Win32 API emulation routine. It returns a
' BSTR, and indexes to the file name, directory, and extension parts of the
' full name.
'
' Input:  sFileName - file to be qualified in one of these formats:
'
'              [relpath\]file.ext
'              \[path\]file.ext
'              .\[path\]file.ext
'              d:\[path\]file.ext
'              ..\[path\]file.ext
'              \\server\machine\[path\]file.ext
'          iName - variable to receive file name position
'          iDir - variable to receive directory position
'          iExt - variable to receive extension position
'
' Return: Full path name, or an empty string on failure
'
' Errors: Any of the following:
'              ERROR_BUFFER_OVERFLOW      = 111
'              ERROR_INVALID_DRIVE        = 15
'              ERROR_CALL_NOT_IMPLEMENTED = 120
'              ERROR_BAD_PATHNAME         = 161


Function GetFullPath(sFileName As String, _
                     Optional FilePart As Long, _
                     Optional ExtPart As Long, _
                     Optional DirPart As Long) As String

    Dim c As Long, p As Long, sRet As String
    If sFileName = sEmpty Then Exit Function
    
    ' Get the path size, then create string of that size
    sRet = String(cMaxPath, 0)
    c = GetFullPathName(sFileName, cMaxPath, sRet, p)
    If c = 0 Then ApiRaise Err.LastDllError
    BugAssert c <= cMaxPath
    sRet = Left$(sRet, c)

    ' Get the directory, file, and extension positions
    GetDirExt sRet, FilePart, DirPart, ExtPart
    GetFullPath = sRet
    
End Function

Function GetTempFile(Optional Prefix As String, _
                     Optional PathName As String) As String
    
    If Prefix = sEmpty Then Prefix = sEmpty
    If PathName = sEmpty Then PathName = GetTempDir
    
    Dim sRet As String
    sRet = String(cMaxPath, 0)
    GetTempFileName PathName, Prefix, 0, sRet
    ApiRaiseIf Err.LastDllError
    GetTempFile = GetFullPath(StrZToStr(sRet))
End Function

Function GetTempDir() As String
    Dim sRet As String, c As Long
    sRet = String(cMaxPath, 0)
    c = GetTempPath(cMaxPath, sRet)
    If c = 0 Then ApiRaise Err.LastDllError
    GetTempDir = Left$(sRet, c)
End Function

Function SearchDirs(sFileName As String, _
                    Optional Ext As String, _
                    Optional Path As String, _
                    Optional FilePart As Long, _
                    Optional ExtPart As Long, _
                    Optional DirPart As Long) As String

    Dim p As Long, c As Long, sRet As String

    If sFileName = sEmpty Then ApiRaise ERROR_INVALID_PARAMETER

    ' Handle missing or invalid extension or path
    If Ext = sEmpty Then Ext = sNullStr
    If Path = sEmpty Then Path = sNullStr
    
    ' Get the file (treating empty strings as NULL pointers)
    sRet = String$(cMaxPath, 0)
    c = SearchPath(Path, sFileName, Ext, cMaxPath, sRet, p)
    If c = 0 Then
        If Err.LastDllError = ERROR_FILE_NOT_FOUND Then Exit Function
        ApiRaise Err.LastDllError
    End If
    BugAssert c <= cMaxPath
    sRet = Left$(sRet, c)

    ' Get the directory, file, and extension positions
    GetDirExt sRet, FilePart, DirPart, ExtPart
    SearchDirs = sRet
   
End Function

Private Sub GetDirExt(sFull As String, iFilePart As Long, _
                      iDirPart As Long, iExtPart As Long)

    Dim iDrv As Integer, i As Integer, cMax As Integer
    cMax = Len(sFull)

    iDrv = Asc(UCase$(Left$(sFull, 1)))

    ' If in format d:\path\name.ext, return 3
    If iDrv <= 90 Then                          ' Less than Z
        If iDrv >= 65 Then                      ' Greater than A
            If Mid$(sFull, 2, 1) = ":" Then     ' Second character is :
                If Mid$(sFull, 3, 1) = "\" Then ' Third character is \
                    iDirPart = 3
                End If
            End If
        End If
    Else

        ' If in format \\machine\share\path\name.ext, return position of \path
        ' First and second character must be \
        If iDrv <> 92 Then ApiRaise ERROR_BAD_PATHNAME
        If Mid$(sFull, 2, 1) <> "\" Then ApiRaise ERROR_BAD_PATHNAME

        Dim fFirst As Boolean
        i = 3
        Do
            If Mid$(sFull, i, 1) = "\" Then
                If Not fFirst Then
                    fFirst = True
                Else
                    iDirPart = i
                    Exit Do
                End If
            End If
            i = i + 1
        Loop Until i = cMax
    End If

    ' Start from end and find extension
    iExtPart = cMax + 1       ' Assume no extension
    fFirst = False
    Dim sChar As String
    For i = cMax To iDirPart Step -1
        sChar = Mid$(sFull, i, 1)
        If Not fFirst Then
            If sChar = "." Then
                iExtPart = i
                fFirst = True
            End If
        End If
        If sChar = "\" Then
            iFilePart = i + 1
            Exit For
        End If
    Next
    Exit Sub
FailGetDirExt:
    iFilePart = 0
    iDirPart = 0
    iExtPart = 0
End Sub

#If fComponent Then
' Seed the component's copy of the random number generator
Sub CoreRandomize(Optional Number As Long)
    Randomize Number
End Sub

Function CoreRnd(Optional Number As Long)
    CoreRnd = Rnd(Number)
End Function
#End If

' GetNextLine returns a line from a string, where a "line" is all characters
' up to and including a carriage return + line feed. GetNextLine
' works the same way as GetToken. The first call to GetNextLine
' should pass the string to parse; subsequent calls should pass
' an empty string. GetNextLine returns an empty string after all lines
' have been read from the source string.
Function GetNextLine(Optional sSource As String) As String
    Static sSave As String, iStart As Long, cSave As Long
    Dim iEnd As Long
    
    ' Initialize GetNextLine
    If (sSource <> sEmpty) Then
        iStart = 1
        sSave = sSource
        cSave = Len(sSave)
    Else
        If sSave = sEmpty Then Exit Function
    End If
    
    ' iStart points to first character after the previous sCrLf
    iEnd = InStr(iStart, sSave, sCrLf)
    
    If iEnd > 0 Then
        ' Return line
        GetNextLine = Mid$(sSave, iStart, iEnd - iStart + 2)
        iStart = iEnd + 2
        If iStart > cSave Then sSave = sEmpty
    Else
        ' Return remainder of string as a line
        GetNextLine = Mid$(sSave, iStart) & sCrLf
        sSave = sEmpty
    End If
End Function

' RTrimLine strips off trailing carriage return + line feed
Function RTrimLine(sLine As String) As String
    If Right$(sLine, 2) = sCrLf Then
        RTrimLine = Left$(sLine, Len(sLine) - 2)
    Else
        RTrimLine = sLine
    End If
End Function