Hi,
I took the libery to 'migrate' a subset of the work Paul Squires did on his Linked List source code and made it into a class. This is just a small set
of his functions that I used. There nothing to it actually, since all the hard
work was already done by Paul.
I took the libery to 'migrate' a subset of the work Paul Squires did on his Linked List source code and made it into a class. This is just a small set
of his functions that I used. There nothing to it actually, since all the hard
work was already done by Paul.
Code:
' ' ====================================================================================================== DECLARE FUNCTION lstrcmp LIB "KERNEL32.DLL" ALIAS "lstrcmpA" (lpString1 AS ASCIIZ, lpString2 AS ASCIIZ) AS LONG DECLARE FUNCTION lstrcmpi LIB "KERNEL32.DLL" ALIAS "lstrcmpiA" (lpString1 AS ASCIIZ, lpString2 AS ASCIIZ) AS LONG Declare Function GetProcessHeap Lib "KERNEL32.DLL" Alias "GetProcessHeap" () As Long Declare Function HeapAlloc Lib "KERNEL32.DLL" Alias "HeapAlloc" (ByVal hHeap As Dword, ByVal dwFlags As Dword, ByVal dwBytes As Dword) As Dword Declare Function HeapCompact Lib "KERNEL32.DLL" Alias "HeapCompact" (ByVal hHeap As Dword, ByVal dwFlags As Dword) As Dword Declare Function HeapCreate Lib "KERNEL32.DLL" Alias "HeapCreate" (ByVal flOptions As Dword, ByVal dwInitialSize As Dword, ByVal dwMaximumSize As Dword) As Dword Declare Function HeapDestroy Lib "KERNEL32.DLL" Alias "HeapDestroy" (ByVal hHeap As Dword) As Long Declare Function HeapFree Lib "KERNEL32.DLL" Alias "HeapFree" (ByVal hHeap As Dword, ByVal dwFlags As Dword, ByVal lpMem As Dword) As Long Declare Function HeapLock Lib "KERNEL32.DLL" Alias "HeapLock" (ByVal hHeap As Dword) As Long Declare Function HeapReAlloc Lib "KERNEL32.DLL" Alias "HeapReAlloc" (ByVal hHeap As Dword, ByVal dwFlags As Dword, ByVal lpMem As Dword, ByVal dwBytes As Dword) As Dword Declare Function HeapSize Lib "KERNEL32.DLL" Alias "HeapSize" (ByVal hHeap As Dword, ByVal dwFlags As Dword, ByVal lpMem As Dword) As Dword Declare Function HeapValidate Lib "KERNEL32.DLL" Alias "HeapValidate" (ByVal hHeap As Dword, ByVal dwFlags As Dword, lpMem As Any) As Long Declare Function FormatMessage Lib "KERNEL32.DLL" Alias "FormatMessageA" (ByVal dwFlags As Dword, lpSource As Any, ByVal dwMessageId As Dword, ByVal dwLanguageId As Dword, lpBuffer As Asciiz, ByVal nSize As Dword, Arguments As Any) As Dword Declare Function LocalFree Lib "KERNEL32.DLL" Alias "LocalFree" (ByVal hMem As Dword) As Long Declare Function GetLastError Lib "KERNEL32.DLL" Alias "GetLastError" () As Long Type LINKED_LIST_TYPE pNext As LINKED_LIST_TYPE Ptr pPrev As LINKED_LIST_TYPE Ptr zKey As Asciiz Ptr zData As Long nType As Integer ' 0 = Long, 1 = String End Type Type LINKED_LIST_HEADER_TYPE pFirst As LINKED_LIST_TYPE Ptr pLast As LINKED_LIST_TYPE Ptr UseStrings As Byte ' TRUE if zData is pointer to a string SortList As Byte ' TRUE if zData is to maintained in sorted order Count As Long End Type %LINKED_LIST_INSERT_START = 1 %LINKED_LIST_INSERT_END = 2 %LINKED_LIST_INSERT_BEFORE = 3 %LINKED_LIST_INSERT_AFTER = 4 %HEAP_GENERATE_EXCEPTIONS = &H00000004 %HEAP_NO_SERIALIZE = &H00000001 %HEAP_REALLOC_IN_PLACE_ONLY = &H00000010 %HEAP_ZERO_MEMORY = &H00000008 %STATUS_ACCESS_VIOLATION = &HC0000005??? %STATUS_NO_MEMORY = &HC0000017??? %FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100 %FORMAT_MESSAGE_IGNORE_INSERTS = &H200 %FORMAT_MESSAGE_FROM_STRING = &H400 %FORMAT_MESSAGE_FROM_HMODULE = &H800 %FORMAT_MESSAGE_FROM_SYSTEM = &H1000 %FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000 %FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF %LANG_NEUTRAL = &H00 %SUBLANG_DEFAULT = &H01 ' user default %TRUE = 1 %FALSE = 0 %Null = 0 ' ====================================================================================================== Class cList Instance pListAddress As Dword ' ====================================================================================================== ' ' ====================================================================================================== Class Method iMemFree(ByRef pMem As Dword) As Long If pMem Then Method = HeapFree( GetProcessHeap(), 0, ByVal pMem) pMem = 0 End If End Method ' ====================================================================================================== ' ' ====================================================================================================== Class Method iMemAlloc(ByVal nSize As Long) As Dword If nSize > 0 Then Method = HeapAlloc( GetProcessHeap(), %HEAP_ZERO_MEMORY, nSize) End If End Method ' ====================================================================================================== ' ' ====================================================================================================== Class Method iHeapAllocString(ByVal sData As String) As Dword Local sPtr As String Ptr sPtr = me.iHeapAlloc(Len(sData)) If sPtr > 0 Then @sPtr = sData Method = sPtr Else Method = 0 End If Exit Method End Method ' ====================================================================================================== ' ' ====================================================================================================== Class Method iHeapAlloc(ByVal Size As Dword) As Dword Local lHeapPtr As Dword Local Retval As Dword If Size = 0 Then Exit Method End If If Size < 4 Then Size = Size + (4 - Size) RetVal = HeapAlloc(GetProcessHeap,%HEAP_GENERATE_EXCEPTIONS Or %HEAP_ZERO_MEMORY, Size) Select Case RetVal Case %STATUS_ACCESS_VIOLATION MsgBox FuncName$ & ": " & "Access Violation !" Case %STATUS_NO_MEMORY MsgBox FuncName$ & ": " & "No memory !" Case Else Method = RetVal End Select Exit Method End Method ' ====================================================================================================== ' ' ====================================================================================================== Class Method AllocString(ByVal sData As String) As Dword Local sPtr As String Ptr sPtr = me.iHeapAlloc(Len(sData)) If sPtr Then @sPtr = sData Method = sPtr Else Method = 0 End If End Method ' ====================================================================================================== ' ' ====================================================================================================== Class Method RetrieveString(ByVal zData As Long) As String Local pS As String Ptr If zData = 0 Then method = "" else pS = zData Method = @pS end if End Method ' ====================================================================================================== ' ' ====================================================================================================== Class Method iGetByPosition(ByVal nPosition As Dword) As Dword Local pList As LINKED_LIST_HEADER_TYPE Ptr Local pListItem As LINKED_LIST_TYPE Ptr Local x As Long pList = pListAddress If pList = 0 Then Exit Method End If ' Iterate to the specified ordinal position pListItem = @pList.pFirst MsgBox "getpos: " & format$(pListItem) x = 1 Do Until x >= nPosition pListItem = @pListItem.pNext MsgBox "getpos: " & Format$(x) & ", " & format$(pListItem) If pListItem = 0 Then Exit Do Incr x Loop Method = pListItem End Method ' ====================================================================================================== ' ' ====================================================================================================== Class Method iMemoryString(ByRef pMem As Dword, ByVal sData As String) If pMem Then HeapFree( GetProcessHeap(), ByVal 0, ByVal pMem) ' free any existing memory sData = sData & $Nul pMem = HeapAlloc( GetProcessHeap(), %HEAP_ZERO_MEMORY, Len( sData ) + 1) If pMem Then Poke$ pMem, sData End Method ' ====================================================================================================== ' ' ====================================================================================================== Class Method iList_Add_Internal(ByVal sKey As String, _ ByVal zData As Long, _ ByVal nAddMethod As Long, _ ByVal nDataType As Integer) As Dword Local pList As LINKED_LIST_HEADER_TYPE Ptr Local pNewItem As LINKED_LIST_TYPE Ptr Local pListItem As LINKED_LIST_TYPE Ptr Local zPtr1 As Asciiz Ptr Local zPtr2 As Asciiz Ptr Local nFirstElement As Long Local nLastElement As Long Local nPos As Long Local nResult As Long pList = pListAddress If pList = 0 Then Method = 0 Exit Method End If sKey = lcase$(sKey) pListItem = 0 ' Create memory for the new node to occupy pNewItem = me.iMemAlloc(SizeOf(LINKED_LIST_TYPE)) If pNewItem = 0 Then Method = 0 Exit Method End If ' Assign the Data. The assignment depends on whether the ' data being added is a string or a numeric. If @pList.UseStrings Then zPtr1 = zData me.iMemoryString(@pNewItem.zData, @zPtr1) Else @pNewItem.zData = zData End If @pNewItem.nType = nDataType ' Assign the Key me.iMemoryString(@pNewItem.zKey, sKey) 'MemString @pNewItem.zKey, sKey ' Determine how this key will be added to the List. The fastest ' way is to simply add it to the end of the list. If the user ' wants the list in sorted order then we must find where in the ' list the new item should be placed. ' We will use a binary search type of algoritm because the list ' should already be in sorted. This is a little more complicated ' then a normal linear search but the performance improvement is ' substantial - normally 200% to 300% (especially for large lists). If @pList.SortList Then nFirstElement = 1 nLastElement = @pList.Count Do nPos = (nFirstElement + nLastElement) \ 2 pListItem = me.iGetByPosition(nPos) If pListItem = 0 Then Exit Do If @pList.UseStrings Then ' Do string comparisons (case sensitive) zPtr1 = @pListItem.zData zPtr2 = zData nResult = lstrcmp( @zPtr1, @zPtr2 ) Else ' Do a simple numeric comparison If @pListItem.zData = zData Then nResult = 0 If @pListItem.zData < zData Then nResult = -1 If @pListItem.zData > zData Then nResult = 1 End If Select Case nResult Case 0 Exit Do ' exact match Case > 0 nLastElement = nPos - 1 Case < 0 nFirstElement = nPos + 1 End Select Loop While nLastElement >= nFirstElement If pListItem = 0 Then nAddMethod = %LINKED_LIST_INSERT_END Else Select Case nResult Case >= 0 nAddMethod = %LINKED_LIST_INSERT_BEFORE Case Else nAddMethod = %LINKED_LIST_INSERT_AFTER End Select End If End If Select Case nAddMethod Case %LINKED_LIST_INSERT_START ' Add the new item at the start of the list If @pList.pLast = 0 Then @pList.pFirst = pNewItem @pList.pLast = pNewItem Else @pNewItem.pNext = @pList.pFirst If @pList.pFirst Then @[email protected] = pNewItem End If @pList.pFirst = pNewItem End If Case %LINKED_LIST_INSERT_END '- Add this item to the end of the list. We save the link to ' the last item in pList in order to speed up adding future ' items otherwise we need to iterate the entire list for every ' add in order to find the last item. If @pList.pLast = 0 Then @pList.pFirst = pNewItem Else If @pList.pLast Then @[email protected] = pNewItem End If @pNewItem.pPrev = @pList.pLast End If @pList.pLast = pNewItem Case %LINKED_LIST_INSERT_BEFORE If @pListItem.pPrev = 0 Then ' Start of list If @pList.pFirst Then @[email protected] = pNewItem End If @pList.pFirst = pNewItem @pNewItem.pNext = pListItem Else @pNewItem.pPrev = @pListItem.pPrev @pNewItem.pNext = pListItem @pListItem.pPrev = pNewItem @[email protected] = pNewItem End If Case %LINKED_LIST_INSERT_AFTER If @pListItem.pNext = 0 Then ' last item in list @pListItem.pNext = pNewItem @pNewItem.pPrev = pListItem @pList.pLast = pNewItem Else @[email protected] = pNewItem @pNewItem.pNext = @pListItem.pNext @pNewItem.pPrev = pListItem @pListItem.pNext = pNewItem End If End Select Incr @pList.Count Method = pNewItem End Method ' ====================================================================================================== ' Interface ' ====================================================================================================== Interface cIList Inherit IDispatch ' ====================================================================================================== ' ' ====================================================================================================== Method Default() me.Init(0, 0) End Method ' ====================================================================================================== ' Method: Init ' ====================================================================================================== Method Init (ByVal nUseStrings As Long, ByVal nSortList As Long) As Integer Local pList As LINKED_LIST_HEADER_TYPE Ptr pList = me.iMemAlloc(SizeOf(LINKED_LIST_HEADER_TYPE)) If pList Then ' The data in the Linked List items can represent either a ' string or a simple numeric value. If you want the list to ' hold strings for the Data then set nUseStrings = TRUE @pList.UseStrings = nUseStrings ' Set flag to determine whether the zData element is maintained ' in a sorted order. @pList.SortList = nSortList pListAddress = pList Method = 1 Else Method = 0 End If End Method ' ====================================================================================================== ' Method: Free ' ====================================================================================================== Method Free () As Integer Local pList As LINKED_LIST_HEADER_TYPE Ptr Local pNext As LINKED_LIST_TYPE Ptr Local pSave As Dword Local hResult As Dword pList = pListAddress If pList = 0 Then Method = 0 Exit Method End If pNext = @pList.pFirst Do Until pNext = 0 If @pNext.zKey Then me.iMemFree(@pNext.zKey) End If 'If @pList.UseStrings Then ' If @pNext.zData Then MemFree @pNext.zData 'End If If @pNext.nType = 1 Then If @pNext.zData Then me.iMemFree(@pNext.zData) End If Else If @pList.UseStrings Then If @pNext.zData Then me.iMemFree(@pNext.zData) End If End If End If pSave = pNext pNext = @pNext.pNext me.iMemFree (pSave) Loop ' Free memory for the List header itself me.iMemFree (pList) Method = 1 End Method ' ====================================================================================================== ' ' ====================================================================================================== Method AddString(ByVal sKey As String, ByVal zData As String) As Dword Local pData As Long pData = me.iHeapAllocString(zData) method = me.iList_Add_internal(sKey, pData, %LINKED_LIST_INSERT_END, 1) End Method ' ====================================================================================================== ' ' ====================================================================================================== Method AddValue (ByVal sKey As String, ByVal zData As Long) As Dword method = me.iList_Add_internal(sKey, zData, %LINKED_LIST_INSERT_END, 0) End Method ' ====================================================================================================== ' ' ====================================================================================================== method RetrieveDataStringByKey(ByVal zKey As String) As String Local pList As LINKED_LIST_HEADER_TYPE Ptr Local pNext As LINKED_LIST_TYPE Ptr Local hResult As Long pList = pListAddress If pList = 0 Then Exit Method End If pNext = @pList.pFirst Do Until pNext = 0 If @pNext.zKey Then If Lstrcmpi( @[email protected], ByCopy zKey ) = 0 Then If @pNext.zData Then Method = me.RetrieveString(@pNext.zData) End If Exit Do End If End If pNext = @pNext.pNext Loop End method ' ====================================================================================================== ' ' ====================================================================================================== Method RetrieveDataValueByKey(ByVal zKey As String) As Long Local pList As LINKED_LIST_HEADER_TYPE Ptr Local pNext As LINKED_LIST_TYPE Ptr zKey = lcase$(zKey) pList = pListAddress If pList = 0 Then Exit Method End If pNext = @pList.pFirst Do Until pNext = 0 If @pNext.zKey Then If Lstrcmpi( @[email protected], ByCopy zKey ) = 0 Then Method = @pNext.zData Exit Do End If End If pNext = @pNext.pNext Loop End method ' ====================================================================================================== ' SearchByKey ' ====================================================================================================== Method SearchByKey(ByVal zKey As String) As Dword Local pList As LINKED_LIST_HEADER_TYPE Ptr Local pNext As LINKED_LIST_TYPE Ptr zKey = lcase$(zKey) pList = pListAddress If pList = 0 Then Exit Method pNext = @pList.pFirst Do Until pNext = 0 If @pNext.zKey Then If Lstrcmpi( @[email protected], ByCopy zKey ) = 0 Then Method = pNext Exit Do End If End If pNext = @pNext.pNext Loop End Method ' ====================================================================================================== ' ' ====================================================================================================== Method UpdateString(ByVal zKey As String, ByVal zData As String) As Long Local pList As LINKED_LIST_HEADER_TYPE Ptr Local pListItem As LINKED_LIST_TYPE Ptr Local zPtr As Asciiz Ptr Local hResult As Long pList = pListAddress If pList = 0 Then Exit Method End If pListItem = me.SearchByKey(zKey) If pListItem = 0 Then pListItem = me.AddString(zKey, zData) Exit Method End If ' Assign the Key zKey = lcase$(zKey) ' Assign the Data. The assignment depends on whether the ' data being added is a string or a numeric. If @pListItem.zData Then me.iMemFree(@pListItem.zData) End If @pListItem.zData = me.AllocString(zData) @pListItem.nType = 1 End Method ' ====================================================================================================== ' ' ====================================================================================================== Method UpdateLong(ByVal sKey As String, ByVal zData As Long) As Long Local pList As LINKED_LIST_HEADER_TYPE Ptr Local pListItem As LINKED_LIST_TYPE Ptr Local zPtr As Asciiz Ptr pList = pListAddress If pList = 0 Then Exit Method End If pListItem = me.SearchByKey(sKey) If pListItem = 0 Then pListItem = me.AddValue(sKey, zData) Exit Method End If ' Assign the Key sKey = lcase$(sKey) ' Assign the Data. The assignment depends on whether the ' data being added is a string or a numeric. @pListItem.zData = zData @pListItem.nType = 0 End Method ' ====================================================================================================== ' ' ====================================================================================================== Method Delete (ByVal pListItemAddress As Long) As Long Local pList As LINKED_LIST_HEADER_TYPE Ptr Local pDelete As LINKED_LIST_TYPE Ptr Local hResult As Long pList = pListAddress If pList = 0 Then Exit Method End If pDelete = pListItemAddress If pDelete = 0 Then Exit Method End If ' If pLast points to the node being deleted then ' we need to adjust that to point to the previous node. If @pList.pLast = pDelete Then @pList.pLast = @pDelete.pPrev End If '- Remove the item from the list If @pDelete.pPrev = 0 Then @pList.pFirst = @pDelete.pNext If @pDelete.pNext Then @[email protected] = 0 End If Else @[email protected] = @pDelete.pNext If @pDelete.pNext Then If @pDelete.pNext Then @[email protected] = @pDelete.pPrev End If End If End If '- Free pDelete (and any allocated string memory) me.iMemFree(@pDelete.zKey) If @pList.UseStrings Then me.iMemFree (@pDelete.zData) Else If @pDelete.nType = 1 Then me.iMemFree(@pDelete.zData) Else @pDelete.zData = 0 End If End If me.iMemFree(pDelete) Decr @pList.Count Method = 1 End Method ' ====================================================================================================== ' GetDataLong ' ====================================================================================================== Method GetDataLong(ByVal pListItem As Dword) As Long Local pListItm As LINKED_LIST_TYPE Ptr If pListItem Then pListItm = pListItem If @pListItm.zData Then Method = @pListItm.zData End If End If End Method ' ====================================================================================================== ' ' ====================================================================================================== Method GetDataString(ByVAl pListItem As Dword) As String Local pListItm As LINKED_LIST_TYPE Ptr Local pString As String Ptr If pListItem Then pListItm = pListItem If @pListItm.zData Then pString = @pListItm.zData Method = @pString End If End If End Method ' ====================================================================================================== ' ' ====================================================================================================== method GetStringDataByPosition(ByVal nPosition As Long) As String Local pList As LINKED_LIST_HEADER_TYPE Ptr Local pListItem As LINKED_LIST_TYPE Ptr Local x As Long pList = pListAddress If pList = 0 Then Exit Method End If ' Iterate to the specified ordinal position pListItem = @pList.pFirst x = 1 Do Until x >= nPosition pListItem = @pListItem.pNext If pListItem = 0 Then Exit Do Incr x Loop If @pListItem.zData Then Method = me.RetrieveString(@pListItem.zData) End If End Method ' ====================================================================================================== ' ' ====================================================================================================== Property Get Count As Long Local pList As LINKED_LIST_HEADER_TYPE Ptr pList = pListAddress If pList = 0 Then Exit Property End If Property = @pList.Count End Property End Interface ' ====================================================================================================== ' ' ====================================================================================================== End Class ' ====================================================================================================== Function pbmain() As Long Local iList As cIList iList = Class "cList" iList.Default() iList.AddString("Test", "My value") Local n As Long For n = 1 To 250 iList.AddString(Format$(n), "Data " & Format$(n)) Next MsgBox "Count = " & Format$(iList.Count) MsgBox iList.RetrieveDataStringByKey("test") iList.Free
Comment