vbAccelerator - Contents of code file: cListBoxStorageIMalloc.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cListBoxStorageIMalloc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' ==========================================================
' Storing Objects against a controls ItemData or Tag
' property.
'
' This class shows how to store objects against a ListBox
' itemdata using IMalloc to allocate memory and serialising
' the class data into the memory.  To access the class again,
' we use IMalloc to deserialise the memory and recreate the
' object.
'
'
' Copyright  1999 Steve McMahon
' steve@vbaccelerator.com
'
' Uses the ISHF_Ex.tlb from Brad Martinez excellent
' EnumDeskVB sample (version 2). Visit his site at:
' http://www.mvps.org/btmtz/
' An alternative Type Library to do the same thing
' is available along with Bruce McKinney's Hardcore
' Visual Basic (win.tlb and winu.tlb).  The IMalloc
' interface there is call IVBMalloc.
'
' ----------------------------------------------------------
' vbAccelerator - advanced, free source code:
' http://vbAccelerator.com/
' ==========================================================

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

' The ListBox we are adding data for:
Private m_lstThis As ListBox

' Type to allow copying of multiple data items at the same time:
Private Type tListBoxStorage
   ' The ItemData to store:
   lItemData As Long
   ' The Extra ItemData to store:
   lItemExtraData As Long
   ' The size of the string we are storing:
   lStringSize As Long
   ' string follows...
End Type

Public Sub Initialise(lstThis As ListBox)
   ' Store a reference to the ListBox:
   Set m_lstThis = lstThis
End Sub

Public Sub RemoveItem(ByVal lItemIndex As Long)
' Use this method rather than the ListBox's native RemoveItem method.
Dim lPtr As Long

   ' Check if memory has been assigned against this
   ' item:
   lPtr = m_lstThis.ItemData(lItemIndex)
   If Not (lPtr = 0) Then
      ' Could check here whether the memory belongs to IMalloc:
      ' If isMalloc.DidAlloc(byval lPtr) then
      isMalloc.Free ByVal lPtr
   End If
   ' Remove the item from the list:
   m_lstThis.RemoveItem lItemIndex
   
End Sub
Public Sub Clear()
' Use this method rather than the ListBox's native Clear method.
Dim l As Long
Dim lPtr As Long
      
   ' Loop through all the item data and free the memory
   ' allocated:
   For l = m_lstThis.ListCount - 1 To 0 Step -1
      lPtr = m_lstThis.ItemData(l)
      If Not (lPtr = 0) Then
         isMalloc.Free ByVal lPtr
      End If
   Next l
   ' Ensure memory is compacted:
   isMalloc.HeapMinimize
   
   ' Clear the list:
   m_lstThis.Clear
   
End Sub

Public Property Let ItemData(ByVal lItemIndex As Long, ByRef cData As
 cListBoxItem)
Dim lPtr As Long
Dim tLBS As tListBoxStorage
Dim sString As String

   ' Get the current item data:
   lPtr = m_lstThis.ItemData(lItemIndex)
   ' Prepare space for the string we want to stor:
   sString = cData.ItemString
   tLBS.lStringSize = LenB(sString)
   
   If (lPtr = 0) Then
      ' No current memory assigned, allocate space:
      lPtr = isMalloc.Alloc(LenB(tLBS) + tLBS.lStringSize)
      If lPtr = 0 Then
         ' Fatal error - can't allocate memory.  Raise Out of Memory:
         Err.Raise 7
      End If
      ' The item data remains set to 0
   Else
      ' Ensure the memory block is the correct size to store the string
      ' and data:
      lPtr = isMalloc.Realloc(ByVal lPtr, LenB(tLBS) + tLBS.lStringSize)
   End If
   
   If Not (lPtr = 0) Then
      tLBS.lItemData = cData.ItemData
      tLBS.lItemExtraData = cData.ItemExtraData
      ' Store the data, extradata and string size:
      CopyMemory ByVal lPtr, tLBS, Len(tLBS)
      ' Store the Unicode string:
      CopyMemory ByVal lPtr + LenB(tLBS), ByVal StrPtr(sString),
       tLBS.lStringSize
      m_lstThis.ItemData(lItemIndex) = lPtr
   End If
   
End Property
Public Property Get ItemData(ByVal lItemIndex As Long) As cListBoxItem
Dim tLBS As tListBoxStorage
Dim lPtr As Long
Dim sString As String

   ' Get the pointer to the extra data (if it exists!)
   lPtr = m_lstThis.ItemData(lItemIndex)
   If Not (lPtr = 0) Then
      ' If we get one, then copy across the itemdata, itemextradata
      ' and string size from the memory:
      CopyMemory tLBS, ByVal lPtr, LenB(tLBS)
      ' If the string size >0
      If tLBS.lStringSize > 0 Then
         ' Allocate space in the string at the appropriate size:
         sString = String$(tLBS.lStringSize \ 2, 0)
         ' Copy the Unicode string data from the memory pointer:
         CopyMemory ByVal StrPtr(sString), ByVal lPtr + LenB(tLBS),
          tLBS.lStringSize
      End If
      ' Now set the item data, item extra data and string into an
      ' instance of the cListBoxItem class to make it easier for
      ' the client to interpret it:
      Dim cData As New cListBoxItem
      With cData
         .ItemData = tLBS.lItemData
         .ItemExtraData = tLBS.lItemExtraData
         .ItemString = sString
      End With
      Set ItemData = cData
   End If
   
End Property