Dan Appleman's Visual Bas…s Guide to the Win32 API/Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD/VB5PG32.mdf/articles/vbpj/source/llist1.bas

BASIC Source File | 1996-01-29 | 10.7 KB | 349 lines

Attribute VB_Name = "LLIST1"
Option Explicit

' Schedule entry
Type ScheduleEntry
    Start As Double     ' Start time of event
    Duration As Double  ' Duration of event
    Person As Integer   ' Who the event applies to
    Description As String * 80  ' Short description of event
End Type


Type LinkType   ' Type used to implement linked lists
    Forward As Integer  ' Link to next entry
    Back As Integer     ' Link to previous entry
End Type

' Schedule entry
Type ScheduleEntryLL
    Start As Double     ' Start time of event, 0 for empty
    Duration As Double  ' Duration of event
    Person As Integer   ' Who the event applies to
    Description As String * 80  ' Short description of event
    StartLink As LinkType   ' Linked list of start times
    PersonLink As LinkType  ' Linked List of People
End Type

'--------------  Global Arrays  --------------
Global NameArray(20) As String * 10    ' List of names
Global ScheduleARY() As ScheduleEntry ' Array based list
Global ScheduleLL() As ScheduleEntryLL  ' Linked List based

Global FirstPerson(20) As Integer   ' Start of linked list for each person
Global FirstTask As Integer         ' Start of linked list for task
Global FirstFree As Integer         ' Start of linked list of free entries

' Set this constant to True to use a free list
Global Const UseFreeList = True

' API Declarations
#If Win32 Then
Declare Function GetCurrentTime Lib "kernel32" Alias "GetTickCount" () As Long
#Else
Declare Function GetCurrentTime& Lib "User" ()
#End If

'
'   Add an entry to the ScheduleARY array
'
Sub AddEntry(se As ScheduleEntry)
    Dim newentry%
    Dim highest%
    Dim lastentry%
    Dim idx%
    ' First, make sure there is room at the end of the
    ' array
    highest% = UBound(ScheduleARY)
    If highest% < 1 Or ScheduleARY(highest%).Start <> 0 Then
        ReDim Preserve ScheduleARY(highest% + 10)
    End If

    ' Find where it goes
    idx% = 1
    Do While se.Start <> 0 And se.Start < ScheduleARY(idx%).Start
        idx% = idx% + 1
    Loop

    ' Now find the highest valid entry
    lastentry% = UBound(ScheduleARY)
    Do While lastentry% > 1 And ScheduleARY(lastentry%).Start = 0
        lastentry% = lastentry% - 1
    Loop

    ' Now move any entries to make room
    Do While lastentry% >= idx%
        LSet ScheduleARY(lastentry% + 1) = ScheduleARY(lastentry%)
        lastentry% = lastentry% - 1
    Loop

    ' And assign the new entry
    LSet ScheduleARY(idx%) = se
End Sub

'
'   Add an entry to the ScheduleLL array
'
Sub AddEntryLL(se As ScheduleEntryLL)
    Dim newentry%, idx%, tidx%

    ' Make sure links are clear by default
    se.StartLink.Forward = 0
    se.StartLink.Back = 0
    se.PersonLink.Forward = 0
    se.PersonLink.Back = 0

    ' Find a free entry
    newentry% = FindFreeEntry()

    LSet ScheduleLL(newentry%) = se

    ' Now find where it goes
    If FirstTask = 0 Then ' The simple case
        FirstTask = newentry%
    Else
        idx% = FirstTask
        tidx% = 0
        Do While idx% <> 0 And se.Start < ScheduleLL(idx%).Start
            tidx% = idx%    ' Keep a copy of the latest
            idx% = ScheduleLL(idx%).StartLink.Forward
        Loop

        ' We link the new entry in after tidx
        ' First place the forward links
        If tidx% = 0 Then   ' Add to start of list
            ScheduleLL(newentry%).StartLink.Forward = FirstTask
            FirstTask = newentry%
        Else
            ScheduleLL(newentry%).StartLink.Forward = ScheduleLL(tidx%).StartLink.Forward
            ScheduleLL(tidx%).StartLink.Forward = newentry%
        End If
        ' Now the back links
        idx% = ScheduleLL(newentry%).StartLink.Forward
        If idx% <> 0 Then ScheduleLL(idx%).StartLink.Back = newentry%
        ScheduleLL(newentry%).StartLink.Back = tidx%
    End If

    ' Now add it to the person list
    If FirstPerson(se.Person) = 0 Then ' The simple case
        FirstPerson(se.Person) = newentry%
    Else
        idx% = FirstPerson(se.Person)
        tidx% = 0
        Do While idx% <> 0 And se.Start < ScheduleLL(idx%).Start
            tidx% = idx%    ' Keep a copy of the latest
            idx% = ScheduleLL(idx%).PersonLink.Forward
        Loop

        ' We link the new entry in after tidx
        ' First place the forward links
        If tidx% = 0 Then   ' Add to start of list
            ScheduleLL(newentry%).PersonLink.Forward = FirstPerson(se.Person)
            FirstPerson(se.Person) = newentry%
        Else
            ScheduleLL(newentry%).PersonLink.Forward = ScheduleLL(tidx%).PersonLink.Forward
            ScheduleLL(tidx%).PersonLink.Forward = newentry%
        End If
        ' Now the back links
        idx% = ScheduleLL(newentry%).PersonLink.Forward
        If idx% <> 0 Then ScheduleLL(idx%).PersonLink.Back = newentry%
        ScheduleLL(newentry%).PersonLink.Back = tidx%
    End If

End Sub

'
'   Delete an entry from the ScheduleARY array
'
Sub DeleteEntry(entrynum%)
    Dim highest%

    highest% = UBound(ScheduleARY)
    Do While entrynum% < highest%
        If ScheduleARY(entrynum% + 1).Start = 0 Then Exit Do
        LSet ScheduleARY(entrynum%) = ScheduleARY(entrynum% + 1)
        entrynum% = entrynum% + 1
    Loop
    ' And clear the last entry
    ScheduleARY(entrynum%).Start = 0
End Sub

'
'   Delete an entry from the ScheduleLL array
'
Sub DeleteEntryLL(entrynum%)
    Dim previdx%, nextidx%, idx%
    Dim useperson%

    ' Unlink first
    If FirstTask = entrynum% Then   ' First in list
        ' Simple unlink
        FirstTask = ScheduleLL(entrynum%).StartLink.Forward
        ' And back link is null
        If FirstTask <> 0 Then ScheduleLL(FirstTask).StartLink.Back = 0
    Else
        previdx% = ScheduleLL(entrynum%).StartLink.Back
        nextidx% = ScheduleLL(entrynum%).StartLink.Forward
        If previdx% <> 0 Then ScheduleLL(previdx%).StartLink.Forward = ScheduleLL(entrynum%).StartLink.Forward
        If nextidx% <> 0 Then ScheduleLL(nextidx%).StartLink.Back = ScheduleLL(entrynum%).StartLink.Back
    End If

    ' Now do the same for the person list
    useperson% = ScheduleLL(entrynum%).Person

    If FirstPerson(useperson%) = entrynum% Then   ' First in list
        ' Simple unlink
        idx% = ScheduleLL(entrynum%).PersonLink.Forward
        FirstPerson(useperson%) = idx% ' New start of list
        ' And back link is null
        If idx% <> 0 Then ScheduleLL(idx%).PersonLink.Back = 0
    Else
        previdx% = ScheduleLL(entrynum%).PersonLink.Back
        nextidx% = ScheduleLL(entrynum%).PersonLink.Forward
        If previdx% <> 0 Then ScheduleLL(previdx%).PersonLink.Forward = ScheduleLL(entrynum%).PersonLink.Forward
        If nextidx% <> 0 Then ScheduleLL(nextidx%).PersonLink.Back = ScheduleLL(entrynum%).PersonLink.Back
    End If

    ' Now free the current entry
    ScheduleLL(entrynum%).Start = 0 ' Mark as empty
    If UseFreeList Then ' Add it to free list
        ScheduleLL(entrynum%).StartLink.Forward = FirstFree
        FirstFree = entrynum%
    End If

End Sub

'
' Returns the index of a free entry in the ScheduleLL array
' Adds space to the list if necessary
'
Function FindFreeEntry() As Integer
    Dim highest%
    Dim idx%
    If UseFreeList Then
        If FirstFree <> 0 Then
            FindFreeEntry = FirstFree
            FirstFree = ScheduleLL(FirstFree).StartLink.Forward
            Exit Function
        Else
            highest% = UBound(ScheduleLL)
        End If
    Else
        ' We're not using a free list
        highest% = UBound(ScheduleLL)
        For idx% = 1 To highest%
            If ScheduleLL(idx%).Start = 0 Then
                ' Found a free entry
                FindFreeEntry = idx%
                Exit Function
            End If
        Next idx%
    End If

    ' None free - extend the size of the array
    ReDim Preserve ScheduleLL(highest% + 10)

    If UseFreeList Then
        ' Link the new entries into the free list
        FirstFree = highest + 1
        For idx% = highest% + 1 To highest% + 9
            ScheduleLL(idx%).StartLink.Forward = idx% + 1
        Next idx%
        ' Recursively call the function - we should find
        ' it now
        FindFreeEntry = FindFreeEntry()
    Else
        ' Not using the free list - simply return an entry
        FindFreeEntry = highest% + 1
    End If

End Function

'
' This function generates a random start date/time
' project duration and assigns it to a random person.
' The parameters are passed by reference.
'
Sub GenerateRandom(Start#, Duration#, Person%)
    Dim date1 As Variant
    date1 = DateSerial(2041, 12, 11)

    ' Now choose a random day within a month or so of this date
    date1 = (Rnd * 31) + date1
    Start# = date1
    ' Pick a duration of up to 1 week
    Duration# = (Rnd * 7)
    ' Pick a person
    Person% = Int(Rnd * 20 + 1)
End Sub

'
' Get the count of entries for this person
'
Function GetCount(forperson%) As Integer
    Dim idx%, highest%
    Dim count%
    highest% = UBound(ScheduleARY)
    For idx% = 1 To highest%
        If ScheduleARY(idx%).Start = 0 Then Exit For
        If ScheduleARY(idx%).Person = forperson% Then count% = count% + 1
    Next idx%
    GetCount = count%

End Function

Function GetCountLL(forperson%) As Integer
    Dim idx%
    Dim count%
    idx% = FirstPerson(forperson%)
    Do While idx% <> 0
        count% = count% + 1
        idx% = ScheduleLL(idx%).PersonLink.Forward
    Loop
    GetCountLL = count%
End Function

'
'   Return a ready to print string summary of an entry in
'   the ScheduleARY array
'
Function GetEntryDesc(entrynum%) As String
    Dim res$
    Dim starttime#
    res$ = NameArray(ScheduleARY(entrynum%).Person)
    starttime# = ScheduleARY(entrynum%).Start
    res$ = res$ & CVDate(starttime#) & " to " & CVDate(ScheduleARY(entrynum%).Duration + starttime#)
    res$ = res$ & " - " & ScheduleARY(entrynum%).Description
    GetEntryDesc = res$
End Function

Function GetEntryDescLL(entrynum%) As String
    Dim res$
    Dim starttime#
    res$ = NameArray(ScheduleLL(entrynum%).Person)
    starttime# = ScheduleLL(entrynum%).Start
    res$ = res$ & CVDate(starttime#) & " to " & CVDate(ScheduleLL(entrynum%).Duration + starttime#)
    res$ = res$ & " - " & ScheduleLL(entrynum%).Description
    GetEntryDescLL = res$

End Function

'
' Initialize the global variables
'
Sub InitializeGlobals()
    Dim x%

    ' Clear the current array
    ReDim ScheduleARY(0)
    ReDim ScheduleLL(0)

    FirstTask = 0
    FirstFree = 0
    For x% = 1 To 20
        FirstPerson(x%) = 0
    Next x%

End Sub