La Lista di Stringhe

La lista di stringhe, almeno in base alla mia esperienza, è la struttura dati più utile in assoluto, in effetti mi sarà capitato di utilizzarla centinaia di volte in qualsiasi linguaggio.

La classe ETStringList è in grado di trattare un numero di stringhe molto elevato con ottime prestazioni e supporta Unicode per il caricamento e salvataggio dei file.
Implementa il QuickSort e consente di ordinare le stringhe, anche in modo custom.
Ad ogni stringa nella lista è possibile associare un qualunque valore di tipo Variant.
Sono implementati anche i metodi per eseguire ricerche in base alle coppie Nome=Valore tipiche dei file .Ini.
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ETStringList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'**************************************************************
'* ETLib4VB - Easy Target Library for Visual Basic            *
'* (C) 2003 By Andrea Molino                                  *
'* Class: ETStringList                                        *
'* Implements a List of Strings with Variant Data             *
'**************************************************************

Option Explicit

Private Const BASE_ERROR_NUM = 1000
Private Const ETErrIdxOutOfBound = 11
Private Const ETErrChangeNotAllowed = 12


Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwBytes As Long)

Private Type ETStringItem
  Str As String
  Dat As Variant
End Type

Private FList() As ETStringItem

Private FCapacity As Long
Private FCount As Long
Private FSorted As Boolean

Public Event OnStrCompareItems(ByVal Index1 As Long, ByVal Index2 As Long, IsBigger As Boolean)



Private Sub Class_Initialize()
  FCount = 0
  FCapacity = 32
  FSorted = False
  ReDim FList(0 To 31)
End Sub

Private Sub Class_Terminate()
  Clear
End Sub

Private Sub RaiseError(ETErr As Long, Optional MethodName As String = "", Optional Parm As Variant, Optional MoreDesc As String = "")
Dim Dsc As String
Dim ETErrDesc As String

  Select Case ETErr
    Case ETErrChangeNotAllowed: ETErrDesc = "Change not Allowed when Sorted = "
    Case ETErrIdxOutOfBound:    ETErrDesc = "Index Out of Bounds"
  End Select
  
  Dsc = "ETStringList"
  If MethodName <> "" Then Dsc = Dsc & "." & MethodName
  Dsc = Dsc & " - " & ETErrDesc
  If Not IsMissing(Parm) Then Dsc = Dsc & " [" & Parm & "]"
  If MoreDesc <> "" Then Dsc = Dsc & vbCrLf & MoreDesc
  Err.Raise BASE_ERROR_NUM + ETErr, , Dsc, "", 0
End Sub

Private Sub Grow()
  FCapacity = FCapacity + 32
  ReDim Preserve FList(0 To FCapacity - 1)
End Sub

Private Sub Shrink()
  FCapacity = FCapacity - 32
  ReDim Preserve FList(0 To FCapacity - 1)
End Sub

Private Sub RightShiftItems(ByVal SrcIdx As Long, ByVal Cnt As Long)
Dim I As Long
  
  For I = SrcIdx + Cnt - 1 To SrcIdx Step -1
    FList(I + 1) = FList(I)
  Next I
End Sub

Private Sub LeftShiftItems(ByVal SrcIdx As Long, ByVal Cnt As Long)
Dim I As Long

  For I = SrcIdx To SrcIdx + Cnt - 1
    FList(I - 1) = FList(I)
  Next I
  FList(SrcIdx + Cnt - 1).Str = ""
  FList(SrcIdx + Cnt - 1).Dat = Empty
End Sub

Private Function SetNameOf(ByVal Index As Long, N As String) As String
Dim P As Long
Dim S As String
  
  S = FList(Index).Str
  P = InStr(S, "=")
  If P > 0 Then
    FList(Index).Str = N & "=" & Mid$(S, P + 1)
  Else
    FList(Index).Str = N
  End If
End Function

Private Function GetNameOf(ByVal Index As Long) As String
Dim P As Long
Dim S As String
  
  S = FList(Index).Str
  P = InStr(S, "=")
  If P > 0 Then
    GetNameOf = Mid$(S, 1, P - 1)
  Else
    GetNameOf = S
  End If
End Function

Private Function SetValueOf(ByVal Index As Long, V As String) As String
Dim P As Long
Dim S As String
  
  S = FList(Index).Str
  P = InStr(S, "=")
  If P > 0 Then
    FList(Index).Str = Mid$(S, 1, P) & V
  Else
    FList(Index).Str = S & "=" & V
  End If
End Function

Private Function GetValueOf(ByVal Index As Long) As String
Dim P As Long
Dim S As String
  
  S = FList(Index).Str
  P = InStr(S, "=")
  If P > 0 Then
    GetValueOf = Mid$(S, P + 1)
  Else
    GetValueOf = ""
  End If
End Function

Private Sub StrQuickSort(Desc As Boolean, SortOnData As Boolean, Optional CompareMode = vbTextCompare)
Dim Value As ETStringItem, Temp As ETStringItem
Dim Sp As Long
Dim LStk(32) As Long, RStk(32) As Long
Dim LNdx As Long, RNdx As Long
Dim I As Long, J As Long

  LNdx = 0
  RNdx = FCount - 1
  Sp = 1
  LStk(Sp) = LNdx
  RStk(Sp) = RNdx
  Do
    If RNdx > LNdx Then
      Value = FList(RNdx)
      I = LNdx - 1
      J = RNdx
      If Desc Then
        Do
          If SortOnData Then
            Do: I = I + 1: Loop Until FList(I).Dat <= Value.Dat
            Do: J = J - 1: Loop Until J = LNdx Or FList(J).Dat >= Value.Dat
          Else
            Do: I = I + 1: Loop Until StrComp(FList(I).Str, Value.Str, CompareMode) <= 0 'FList(I).Str <= Value.Str
            Do: J = J - 1: Loop Until J = LNdx Or StrComp(FList(J).Str, Value.Str, CompareMode) >= 0 'FList(J).Str >= Value.Str
          End If
          Temp = FList(I): FList(I) = FList(J): FList(J) = Temp
        Loop Until J <= I
      Else
        Do
          If SortOnData Then
            Do: I = I + 1: Loop Until FList(I).Dat >= Value.Dat
            Do: J = J - 1: Loop Until J = LNdx Or FList(J).Dat <= Value.Dat
          Else
            Do: I = I + 1: Loop Until StrComp(FList(I).Str, Value.Str, CompareMode) >= 0 'FList(I).Str >= Value.Str
            Do: J = J - 1: Loop Until J = LNdx Or StrComp(FList(J).Str, Value.Str, CompareMode) <= 0 'FList(J).Str <= Value.Str
          End If
          Temp = FList(I): FList(I) = FList(J): FList(J) = Temp
        Loop Until J <= I
      End If
      Temp = FList(J)
      FList(J) = FList(I)
      FList(I) = FList(RNdx)
      FList(RNdx) = Temp
      Sp = Sp + 1
      If (I - LNdx) > (RNdx - I) Then
        LStk(Sp) = LNdx: RStk(Sp) = I - 1: LNdx = I + 1
      Else
        LStk(Sp) = I + 1: RStk(Sp) = RNdx: RNdx = I - 1
      End If
    Else
      LNdx = LStk(Sp)
      RNdx = RStk(Sp)
      Sp = Sp - 1
      If Sp = 0 Then Exit Do
    End If
  Loop
End Sub

Private Sub CustomShellSort(Desc As Boolean)
Dim Index As Long, Index2 As Long
Dim Distance As Long, Value As ETStringItem
Dim CompRes As Boolean
  
  Do
    Distance = Distance * 3 + 1
  Loop Until Distance > FCount
  Do
    Distance = Distance \ 3
    For Index = Distance To FCount - 1
      Value = FList(Index)
      Index2 = Index
      RaiseEvent OnStrCompareItems((Index2 - Distance), Index, CompRes)
      Do While CompRes Xor Desc
        FList(Index2) = FList(Index2 - Distance)
        Index2 = Index2 - Distance
        If Index2 < Distance Then Exit Do
        RaiseEvent OnStrCompareItems((Index2 - Distance), Index, CompRes)
      Loop
      FList(Index2) = Value
    Next
  Loop Until Distance = 1
End Sub

' If MustExit = False and S is not founded, return the right insertion index
Private Function Search(ByVal S As String, ByVal MustExist As Boolean, Optional OnlyName As Boolean = False) As Long
Dim First As Long
Dim Last As Long
Dim Middle As Long
Dim ResComp As Long

  Search = -1
  If Not FSorted Then
    RaiseError ETErrChangeNotAllowed, "Search", FSorted
    Exit Function
  End If
  First = 0
  Last = FCount - 1
  Do
    Middle = (First + Last) \ 2
    If OnlyName Then
      ResComp = StrComp(GetNameOf(Middle), S, vbTextCompare)
    Else
      ResComp = StrComp(FList(Middle).Str, S, vbTextCompare)
    End If
    If ResComp = 0 Then
      Search = Middle
      Exit Do
    ElseIf (ResComp < 0) Then
      First = Middle + 1
    Else
      Last = Middle - 1
    End If
  Loop Until First > Last
  If Not MustExist Then
    If Search = -1 Then
      Search = Middle
      If Middle = Last Then Search = Search + 1
    End If
  End If
End Function

Private Sub InternInsert(Index As Long, S As String)
  If FCount = FCapacity Then
    Grow
  End If
  If Index < FCount Then
    RightShiftItems Index, (FCount - Index)
  End If
  FList(Index).Str = S
  FList(Index).Dat = Empty
  FCount = FCount + 1
End Sub


Public Sub Assign(List As ETStringList)
Dim I As Long

  FSorted = List.Sorted
  FCount = List.Count
  FCapacity = FCount
  ReDim FList(0 To FCapacity - 1)
  For I = 0 To FCount - 1
    FList(I).Str = List.Item(I)
    If IsObject(List.Data(I)) Then
      Set FList(I).Dat = List.Data(I)
    Else
      FList(I).Dat = List.Data(I)
    End If
  Next I
End Sub

Public Sub Clear()
Dim I As Long
  
  For I = 0 To FCount - 1
    FList(I).Str = ""
    FList(I).Dat = Empty
  Next I
  FCount = 0
  FCapacity = 1
  ReDim FList(0)
End Sub

Public Function Add(ByVal S As String) As Long
  If FSorted Then
    Add = Search(S, False) 'Return Index of S or the right insertion Index (may be = FCount)
    InternInsert Add, S
  Else
    Add = FCount
    If FCount = FCapacity Then
      Grow
    End If
    FList(FCount).Str = S
    FList(FCount).Dat = Empty
    FCount = FCount + 1
  End If
End Function

Public Function AddData(ByVal S As String, Data As Variant) As Long
  AddData = Add(S)
  If IsObject(Data) Then
    Set FList(AddData).Dat = Data
  Else
    FList(AddData).Dat = Data
  End If
End Function

Public Sub AddStrings(List As ETStringList)
Dim I As Long
Dim OldCnt As Integer
  
  OldCnt = FCount
  FCount = FCount + List.Count
  FCapacity = FCount
  ReDim Preserve FList(0 To FCapacity - 1)
  For I = 0 To List.Count - 1
    FList(OldCnt + I).Str = List.Item(I)
    If IsObject(List.Data(I)) Then
      Set FList(OldCnt + I).Dat = List.Data(I)
    Else
      FList(OldCnt + I).Dat = List.Data(I)
    End If
  Next I
  If FSorted Then Sort
End Sub

Public Sub Insert(ByVal Index As Long, ByVal S As String)
  If FSorted Then
    RaiseError ETErrChangeNotAllowed, "Insert"
  ElseIf (Index > -1) And (Index <= FCount) Then
    InternInsert Index, S
  Else
    RaiseError ETErrIdxOutOfBound, "Insert", Index
  End If
End Sub

Public Sub InsertData(ByVal Index As Long, ByVal S As String, Data As Variant)
  Insert Index, S
  If IsObject(Data) Then
    Set FList(Index).Dat = Data
  Else
    FList(Index).Dat = Data
  End If
End Sub

Public Sub Delete(ByVal Index As Long)
  If (Index > -1) And (Index < FCount) Then
    FCount = FCount - 1
    If Index < FCount Then
      LeftShiftItems (Index + 1), (FCount - Index)
    End If
    If (FCapacity - FCount) > 32 Then Shrink
  Else
    RaiseError ETErrIdxOutOfBound, "Delete", Index
  End If
End Sub

Public Function IndexOf(ByVal S As String) As Long
Dim I As Long

  If FSorted Then
    IndexOf = Search(S, True) 'Return Index of S or -1 if not found
  Else
    For I = 0 To FCount - 1
      If FList(I).Str = S Then
        IndexOf = I
        Exit Function
      End If
    Next I
    IndexOf = -1
  End If
End Function

Public Function IndexOfData(Data As Variant) As Long
Dim I As Long

  For I = 0 To FCount - 1
    If FList(I).Dat = Data Then
      IndexOfData = I
      Exit Function
    End If
  Next I
  IndexOfData = -1
End Function

Public Function IndexOfName(ByVal N As String) As Long
Dim I As Long

  If FSorted Then
    IndexOfName = Search(N, True, True) 'Return Index of S or -1 if not found
  Else
    For I = 0 To FCount - 1
      If GetNameOf(I) = N Then
        IndexOfName = I
        Exit Function
      End If
    Next I
    IndexOfName = -1
  End If
End Function

Public Function IndexOfValue(ByVal V As String) As Long
Dim I As Long

  For I = 0 To FCount - 1
    If GetValueOf(I) = V Then
      IndexOfValue = I
      Exit Function
    End If
  Next I
  IndexOfValue = -1
End Function

Public Function FileIsUnicode(ByVal FileName As String) As Boolean
Dim FNum As Integer
Dim isOpen As Boolean
Dim Buffer() As Byte

On Error GoTo Error_Handler
  FNum = FreeFile()
  Open FileName For Binary Access Read As #FNum
  isOpen = True
  If Not EOF(FNum) Then
    ReDim Buffer(0 To 1)
    Get #FNum, , Buffer
    If Buffer(0) = &HFF And Buffer(1) = &HFE Then FileIsUnicode = True
  End If

Error_Handler:
  If isOpen Then Close #FNum
  If Err Then Err.Raise Err.Number, , Err.Description
End Function

Public Sub LoadFromFile(ByVal FileName As String, Optional ByRef blnIsUnicode As Boolean)
Dim FNum As Integer
Dim isOpen As Boolean
Dim FSize As Long
Dim Buffer() As Byte
Dim S As String

On Error GoTo Error_Handler
  Clear
  FNum = FreeFile()
  If FileIsUnicode(FileName) Then
    blnIsUnicode = True
    Open FileName For Binary Access Read As #FNum
    isOpen = True
    If Not EOF(FNum) Then
      FSize = LOF(FNum)
      ReDim Buffer(0 To FSize)
      Get #FNum, , Buffer
      S = Buffer
      Erase Buffer
      Parse Mid$(S, 2), vbCrLf
    End If
  Else
    Open FileName For Input As #FNum
    isOpen = True
    If Not EOF(FNum) Then
      Line Input #FNum, S
      Add S
    End If
    Do Until EOF(FNum)
      Line Input #FNum, S
      Add S
    Loop
  End If
  If FSorted Then Sort

Error_Handler:
  If isOpen Then Close #FNum
  If Err Then Err.Raise Err.Number, , Err.Description
End Sub

Public Sub SaveToFile(ByVal FileName As String, _
             Optional ByVal Unicode As Boolean = False)
Dim FNum As Integer
Dim isOpen As Boolean
Dim ChrBuff() As Byte
Dim UHead(1) As Byte
Dim I As Long

On Error GoTo Error_Handler
  FNum = FreeFile()
  If Unicode Then
    Open FileName For Output As #FNum
    Close #FNum
    Open FileName For Binary Access Write As #FNum
    isOpen = True
    UHead(0) = &HFF
    UHead(1) = &HFE
    ChrBuff = Mount(vbCrLf)
    Put #FNum, , UHead
    Put #FNum, , ChrBuff
  Else
    Open FileName For Output As #FNum
    isOpen = True
    For I = 0 To FCount - 1
      Print #FNum, FList(I).Str
    Next I
  End If
  
Error_Handler:
  If isOpen Then Close #FNum
  If Err Then Err.Raise Err.Number, , Err.Description
End Sub

Public Function LoadFromStream(ByRef Stream As Object) As Boolean
Dim Unicode As Boolean
Dim UHead(1) As Byte
Dim S As String
Dim Count As Long

On Error GoTo Skip
  If (TypeName(Stream) Like "ET*Stream") Then
    Count = Stream.Size - Stream.Position
    If Count > 0 Then
      Stream.ReadB UHead(0), 2
      Unicode = (UHead(0) = &HFF) And (UHead(1) = &HFE)
      If Unicode Then
        Count = (Count - 2) \ 2
      Else
        Stream.StreamSeek -2, 2 'msSoCurrent
      End If
      S = String(Count, " ")
      Stream.ReadS S, Count, Unicode
      Parse S, vbCrLf
    End If
    LoadFromStream = True
    Exit Function
  End If
  
Skip:
  LoadFromStream = False
End Function

Public Function SaveToStream(ByRef Stream As Object, _
                    Optional ByVal Unicode As Boolean = False) As Boolean
Dim I As Long
Dim J As Long
Dim S As String
Dim CrLf(4) As Byte
Dim UHead(2) As Byte

On Error GoTo Skip
  If (TypeName(Stream) Like "ET*Stream") Then
    If Unicode Then
      UHead(0) = &HFF
      UHead(1) = &HFE
      CrLf(0) = 13
      CrLf(1) = 0
      CrLf(2) = 10
      CrLf(3) = 0
      With Stream
        .WriteB UHead(0), 2
        For I = 0 To FCount - 2
          S = FList(I).Str
          .WriteS S, Len(S), Unicode
          .WriteB CrLf(0), 4
        Next I
        If FCount > 0 Then
          S = FList(FCount - 1).Str
          .WriteS S, Len(S), Unicode
        End If
      End With
      SaveToStream = True
    Else
      CrLf(0) = 13
      CrLf(1) = 10
      With Stream
        For I = 0 To FCount - 2
          S = FList(I).Str
          .WriteS S, Len(S)
          .WriteB CrLf(0), 2
        Next I
        If FCount > 0 Then
          S = FList(FCount - 1).Str
          .WriteS S, Len(S)
        End If
      End With
      SaveToStream = True
    End If
    Exit Function
  End If
  
Skip:
  SaveToStream = False
End Function

Public Function LoadFromBuffer(ByRef BinData() As Byte) As Boolean
Dim S As String
Dim Cnt As Long
Dim Unicode As Boolean

On Error GoTo Skip:
  LoadFromBuffer = False
  Unicode = (BinData(0) = &HFF) And (BinData(1) = &HFE)
  If Unicode Then
    S = BinData
    Parse Mid$(S, 2), vbCrLf
  Else
    Cnt = UBound(BinData) + 1
    S = Space$(Cnt)
    MoveMemory ByVal S, BinData(0), Cnt
    Parse S, vbCrLf
  End If
  LoadFromBuffer = True

Skip:
End Function

Public Function SaveToBuffer(ByRef BinData() As Byte) As Boolean
Dim S As String
Dim Cnt As Long

On Error GoTo Skip:
  SaveToBuffer = False
  S = Mount(vbCrLf)
  BinData = S
  SaveToBuffer = True

Skip:
End Function

Public Function LoadFromResData(ByVal ResType As String, ByVal ResID As Long) As Boolean
Dim BinData() As Byte

On Error GoTo Skip:
  LoadFromResData = False
  BinData = LoadResData(ResID, ResType)
  LoadFromResData = LoadFromBuffer(BinData)

Skip:
End Function

Public Function Parse(ByRef S As String, ByVal Brk As String, Optional DoTrim As Boolean) As Long
Dim StrArray As Variant
Dim I As Long
  
  StrArray = Split(S, Brk)
  FCount = UBound(StrArray) + 1
  FCapacity = FCount
  ReDim FList(0 To FCapacity - 1)
  If DoTrim Then
    For I = 0 To FCount - 1
      FList(I).Str = Trim(StrArray(I))
      FList(I).Dat = Empty
    Next I
  Else
    For I = 0 To FCount - 1
      FList(I).Str = StrArray(I)
      FList(I).Dat = Empty
    Next I
  End If
  StrArray = Empty
  If FSorted Then Sort
End Function

Public Function Mount(ByVal Brk As String) As String
Dim OutBuff() As Byte
Dim BrkBuff() As Byte
Dim ChrBuff() As Byte
Dim Lb As Long
Dim L As Long
Dim I As Long
Dim P As Long

On Error GoTo Skip
  Mount = ""
  
  If FCount > 0 Then
    Lb = Len(Brk)
    L = 0
    For I = 0 To FCount - 1
      L = L + Len(FList(I).Str)
      If I < (FCount - 1) Then L = L + Lb
    Next I
    
    OutBuff = String(L, " ")
    If (UBound(OutBuff) + 1) <> L * 2 Then
      Mount = "Error: Unable to allocate memory!"
      Exit Function
    End If
    BrkBuff = Brk
  
    ' From Here think in Unicode :-)
    Lb = Len(Brk) * 2
    P = 0
    
    For I = 0 To FCount - 1
      L = Len(FList(I).Str) * 2
      
      If L > 0 Then
        ChrBuff = FList(I).Str
        MoveMemory OutBuff(P), ChrBuff(0), L
      End If
      
      If Brk <> "" And I < (FCount - 1) Then
        MoveMemory OutBuff(P + L), BrkBuff(0), Lb
      End If
      
      P = P + L + Lb
    Next I
    Mount = OutBuff
  End If
  Exit Function
  
Skip:
  Mount = "Error: " & Err.Description
End Function

Public Sub ReplaceAll(OldStr As String, NewStr As String)
Dim I As Long
  
  For I = 0 To FCount - 1
    FList(I).Str = Replace(FList(I).Str, OldStr, NewStr)
  Next I
End Sub

Public Sub Sort(Optional Desc As Boolean = False, Optional CompareMode = vbTextCompare)
  StrQuickSort Desc, False, CompareMode
End Sub

Public Sub DataSort(Optional Desc As Boolean = False)
  StrQuickSort Desc, True
End Sub

'To Use Custom Sort:
'   You must declare the StringList object at module level using [WithEvents] keyword.
'     Ex.: [Dim] [Private] [Public] WithEvents StrList As ETStringList
'
'   Then, You need to create an 'Event' Sub Routine in the same module.
'     Ex.:
'     Private Sub StrList_OnStrCompareItems(ByVal Index1 As Long, ByVal Index2 As Long, IsBigger As Boolean)
'       IsBigger = (StrList.GetData(Index1) > StrList.GetData(Index2))
'     End Sub
Public Sub CustomSort(Optional Desc As Boolean = False)
  CustomShellSort Desc
End Sub

'Sparse the Items: useful to reverse sorting order with quick sort
Public Sub UnSort()
Dim C As Long
Dim K As Long
Dim I As Long
Dim J As Long
Dim Temp As ETStringItem

  FSorted = False
  C = FCount \ 2
  For K = 0 To C
    I = Int(C * Rnd)
    J = Int(C * Rnd) + C
    Temp = FList(I)
    FList(I) = FList(J)
    FList(J) = Temp
  Next K
End Sub

Public Sub FillListControl(Lb As Control, Optional FillItemData As Boolean = False, Optional ShowData As Boolean = False)
Dim I As Long

On Error GoTo Skip
  Lb.Clear
  If ShowData Then
    For I = 0 To FCount - 1
      Lb.AddItem FList(I).Str & ": " & FList(I).Dat
    Next I
  Else
    For I = 0 To FCount - 1
      Lb.AddItem FList(I).Str
    Next I
  End If
  If FillItemData Then
    For I = 0 To FCount - 1
      Lb.ItemData(I) = FList(I).Dat
    Next I
  End If
  
Skip:
End Sub

Public Sub GrabListControl(Lb As Control)
Dim I As Long

On Error GoTo Skip
  Clear
  For I = 0 To Lb.ListCount - 1
    AddData Lb.List(I), Lb.ItemData(I)
  Next I
  
Skip:
End Sub



Public Property Get Count() As Long
  Count = FCount
End Property

Public Property Let Capacity(ByVal vData As Long)
  If vData < 1 Then vData = 1
  FCapacity = vData
  ReDim Preserve FList(0 To FCapacity - 1)
  If FCount > FCapacity Then FCount = FCapacity
End Property

Public Property Get Capacity() As Long
  Capacity = FCapacity
End Property

Public Property Let Sorted(ByVal vData As Boolean)
  If FSorted <> vData Then
    FSorted = vData
    If FSorted Then
      UnSort 'Sparse to avoid bad performance on reverse sorting
      Sort
      FSorted = True 'Unsort set Sorted to False
    End If
  End If
End Property

Public Property Get Sorted() As Boolean
  Sorted = FSorted
End Property

Public Property Let Item(ByVal Index As Long, ByVal vData As String)
  If FSorted Then
    RaiseError ETErrChangeNotAllowed, "Let Item"
  ElseIf (Index > -1) And (Index < FCount) Then
    FList(Index).Str = vData
  Else
    RaiseError ETErrIdxOutOfBound, "Let Item", Index
  End If
End Property

Public Property Get Item(ByVal Index As Long) As String
Attribute Item.VB_UserMemId = 0
  If (Index > -1) And (Index < FCount) Then
    Item = FList(Index).Str
  Else
    RaiseError ETErrIdxOutOfBound, "Get Item", Index
  End If
End Property

'Data can be located by Index or by key if Sorted = True
Public Property Let Data(Index As Variant, ByVal vData As Variant)
  If VarType(Index) = vbString Then Index = Search(Index, True)
  If (Index > -1) And (Index < FCount) Then
    FList(Index).Dat = vData
  Else
    RaiseError ETErrIdxOutOfBound, "Let Data", Index
  End If
End Property

Public Property Set Data(Index As Variant, ByVal vData As Variant)
  If VarType(Index) = vbString Then Index = Search(Index, True)
  If (Index > -1) And (Index < FCount) Then
    Set FList(Index).Dat = vData
  Else
    RaiseError ETErrIdxOutOfBound, "Set Data", Index
  End If
End Property

Public Property Get Data(Index As Variant) As Variant
  If VarType(Index) = vbString Then Index = Search(Index, True)
  If (Index > -1) And (Index < FCount) Then
    If IsObject(FList(Index).Dat) Then
      Set Data = FList(Index).Dat
    Else
      Data = FList(Index).Dat
    End If
  Else
    RaiseError ETErrIdxOutOfBound, "Get Data", Index
  End If
End Property

Public Property Let ItemName(ByVal Index As Long, ByVal vData As String)
  If FSorted Then
    RaiseError ETErrChangeNotAllowed, "Let ItemName"
  ElseIf (Index > -1) And (Index < FCount) Then
     SetNameOf Index, vData
  Else
    RaiseError ETErrIdxOutOfBound, "Let ItemName", Index
  End If
End Property

Public Property Get ItemName(ByVal Index As Long) As String
  If (Index > -1) And (Index < FCount) Then
    ItemName = GetNameOf(Index)
  Else
    RaiseError ETErrIdxOutOfBound, "Get ItemName", Index
  End If
End Property

Public Property Let ItemValue(ByVal Index As Long, ByVal vData As String)
  If FSorted Then
    RaiseError ETErrChangeNotAllowed, "Let ItemValue"
  ElseIf (Index > -1) And (Index < FCount) Then
    SetValueOf Index, vData
  Else
    RaiseError ETErrIdxOutOfBound, "Let ItemValue", Index
  End If
End Property

Public Property Get ItemValue(ByVal Index As Long) As String
  If (Index > -1) And (Index < FCount) Then
    ItemValue = GetValueOf(Index)
  Else
    RaiseError ETErrIdxOutOfBound, "Get ItemValue", Index
  End If
End Property

Public Property Let Text(ByVal vData As String)
  Parse vData, vbCrLf
End Property


Public Property Get Text() As String
  Text = Mount(vbCrLf)
End Property
Tutte le Utility