Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/nojet/db.bas

BASIC Source File | 1995-03-06 | 7.8 KB | 289 lines

DefInt A-Z
Option Explicit
Option Compare Text
Type Contact
    Salutation  As String * 10
    LastName    As String * 30
    FirstName   As String * 20
    Company     As String * 30
    Title       As String * 30
    Address_1   As String * 30
    Address_2   As String * 30
    City        As String * 30
    State       As String * 30
    ZipCode     As String * 10
    Country     As String * 30
    Phone       As String * 15
    Extension   As String * 10
    Fax         As String * 15
    EMail       As String * 30
    Link        As Long
End Type
Type ContactIndex
    sKey        As String * 50
    lRecNo      As Long
End Type
Type Comment
    Text        As String * 252
    lRecNo      As Long
End Type

'Handles for data, comment
'  and index files
Global hDat As Integer
Global hCmt As Integer
Global hIdx As Integer
Global sNull As String

Declare Function llseek Lib "Kernel" Alias "_llseek" (ByVal hFile As Integer, ByVal lOffset As Long, ByVal iOrigin As Integer) As Long
Declare Function lread Lib "Kernel" Alias "_lread" (ByVal hFile As Integer, lpBuffer As Any, ByVal wBytes As Integer) As Integer
Declare Function lwrite Lib "Kernel" Alias "_lwrite" (ByVal hFile As Integer, lpBuffer As Any, ByVal wBytes As Integer) As Integer

Function AppPath$ ()

    Static sPath As String

    'Just do this once
    If Len(sPath) = 0 Then
        sPath = App.Path
        If Asc(Right$(sPath, 1)) <> 92 Then
            sPath = sPath & "\"
        End If
    End If

    AppPath$ = sPath

End Function

Sub CommentDelete (lRecNo As Long)

    Dim udtComment As Comment

    'See comments in ContactDelete
    Get hCmt, 1, udtComment
    If udtComment.lRecNo = 0 Then
        udtComment.lRecNo = -lRecNo
    End If
    Put hCmt, lRecNo, udtComment
    udtComment.lRecNo = -lRecNo
    Put hCmt, 1, udtComment

End Sub

Sub ContactDelete (lRecNo As Long)

    Dim udtIndex As ContactIndex
    Dim udtContact As Contact

    'Examine header record. If its record pointer
    '  is zero, set deleted record to point to itself.
    '  Otherwise, copy header rec to lRecNo (negative
    '  lRecNo indicates a deleted record)
    Get hIdx, lRecNo, udtIndex
    Get hDat, 1, udtContact
    If udtContact.Link = 0 Then
        udtContact.Link = -udtIndex.lRecNo
    End If
    Put hDat, udtIndex.lRecNo, udtContact
    'Set header to point to lRecNo
    udtContact.Link = -udtIndex.lRecNo
    Put hDat, 1, udtContact

End Sub

Function FileOpen (sFileName As String, iRecLen As Integer)

    Dim iHandle As Integer
    Dim sTemp As String
    Dim udtIndex As ContactIndex

    iHandle = FreeFile
    Open sFileName For Random Shared As iHandle Len = iRecLen

    'If we're not opening the index...
    If iRecLen <> Len(udtIndex) Then
        'Create header record if none exists
        If LOF(iHandle) = 0 Then
            sTemp = String$(iRecLen - 2, 0)
            Put iHandle, 1, sTemp
        End If
    End If
    FileOpen = iHandle

End Function

Function FreeComment& (hFile As Integer)

    Dim lRecNo As Long
    Dim udtComment As Comment

    'Get pointer to next free record
    Get hFile, 1, udtComment
    'If it's not zero...
    If udtComment.lRecNo Then
        lRecNo = Abs(udtComment.lRecNo)
        'Get that record's pointer
        Get hFile, lRecNo, udtComment
        '  and save it in rec #1
        Put hFile, 1, udtComment
    Else
        'Extend file
        lRecNo = LOF(hFile) \ Len(udtComment) + 1
    End If
    FreeComment& = lRecNo

End Function

Function FreeContact& (hFile As Integer)

    Dim lRecNo As Long
    Dim udtContact As Contact

    'Get pointer to next free record
    Get hFile, 1, udtContact
    'If it's not zero...
    If udtContact.Link Then
        lRecNo = Abs(udtContact.Link)
        'Get that record's pointer
        Get hFile, lRecNo, udtContact
        'and save it in rec #1
        Put hFile, 1, udtContact
    Else
        'Extend file
        lRecNo = LOF(hFile) \ Len(udtContact) + 1
    End If
    FreeContact& = lRecNo

End Function

Sub IndexDelete (lRecNo As Long)

    Dim hDOS As Integer
    Dim iLen As Integer
    Dim nBytes As Integer
    Dim lPos As Long
    Dim lRecs As Long
    Dim udtIndex As ContactIndex

    iLen = Len(udtIndex)
    lRecs = LOF(hIdx) \ iLen
    hDOS = FileAttr(hIdx, 2)
    If lRecNo < lRecs Then
        'Dim an array large enough to contain all
        '  index entries following lRecNo
        ReDim udtIdxArray(1 To (lRecs - lRecNo)) As ContactIndex
        'Use API calls to fill array
        lPos = llseek(hDOS, (iLen * lRecNo), 0)
        nBytes = lread(hDOS, udtIdxArray(1), UBound(udtIdxArray) * iLen)
        'Move file pointer up one record
        lPos = llseek(hDOS, (lPos - iLen), 0)
        'Write array contents
        nBytes = lwrite(hDOS, udtIdxArray(1), UBound(udtIdxArray) * iLen)
    End If
    'Seek to LOF - 1
    lPos = llseek(hDOS, (LOF(hIdx) - iLen), 0)
    'Write zero bytes to truncate file
    nBytes = lwrite(hDOS, ByVal sNull$, 0)

End Sub

Sub IndexInsert (udtIndex As ContactIndex)

    Dim hDOS As Integer
    Dim iLen As Integer
    Dim nBytes As Integer
    Dim lPos As Long
    Dim lRecNo As Long
    Dim lRecs As Long
    Dim udtTemp As ContactIndex

    iLen = Len(udtIndex)
    lRecs = LOF(hIdx) \ iLen
    If lRecs Then
        'Find first index entry greater than
        '  insertion key (okay, I know a loop
        '  is low-tech; whaddya want for free?!)
        For lRecNo = 1 To lRecs
            Get hIdx, lRecNo, udtTemp
            If udtTemp.sKey > udtIndex.sKey Then
                Exit For
            End If
        Next
        'If we need to insert our entry somewhere before
        '  the end, copy a block of records down one position
        '  (see comments in IndexDelete for details)
        If lRecNo <= lRecs Then
            hDOS = FileAttr(hIdx, 2)
            ReDim udtIdxArray(1 To (lRecs - lRecNo + 1)) As ContactIndex
            lPos = llseek(hDOS, (iLen * (lRecNo - 1)), 0)
            nBytes = lread(hDOS, udtIdxArray(1), UBound(udtIdxArray) * iLen)
            lPos = llseek(hDOS, (lPos + iLen), 0)
            nBytes = lwrite(hDOS, udtIdxArray(1), UBound(udtIdxArray) * iLen)
        End If
    Else
        lRecNo = 1
    End If
    'lRecNo will point past end of file if
    '  udtIndex.sKey is greater than all
    '  existing keys
    Put hIdx, lRecNo, udtIndex

End Sub

Sub IndexRebuild ()

    Dim I As Integer
    Dim udtContact As Contact
    Dim udtIndex As ContactIndex

    Kill AppPath$() & "contacts.idx"
    hDat = FileOpen(AppPath$() & "contacts.dat", Len(udtContact))
    hIdx = FileOpen(AppPath$() & "contacts.idx", Len(udtIndex))

    For I = 2 To LOF(hDat) \ Len(udtContact)
        Get hDat, I, udtContact
        If udtContact.Link >= 0 Then
            udtIndex.sKey = udtContact.LastName & udtContact.FirstName
            udtIndex.lRecNo = I
            Call IndexInsert(udtIndex)
        End If
    Next
    Close

End Sub

Function IndexSearch (sTarget As String)

    Dim I As Integer
    Dim iLen As Integer
    Dim iMin As Integer
    Dim iMax As Integer
    Dim iResult As Integer
    Dim udtIndex As ContactIndex

    'Perform case-insensitive binary search
    ' for sTarget
    iMin = 1
    iMax = LOF(hIdx) \ Len(udtIndex)
    iLen = Len(sTarget)
    Do
        I = (iMin + iMax) \ 2
        Get hIdx, I, udtIndex
        'Only as many characters of sKey as
        '  sTarget is long
        If Left$(udtIndex.sKey, iLen) = sTarget Then
            iResult = I
            Exit Do
        ElseIf udtIndex.sKey > sTarget Then
            iMax = I - 1
        Else
            iMin = I + 1
        End If
    Loop While iMax >= iMin

    'Return location (or zero if not found)
    IndexSearch = iResult

End Function