vbAccelerator - Contents of code file: mIMalloc.bas

Attribute VB_Name = "mIMalloc"
Option Explicit

Public Const gcOLE_DATA_FORMAT As Long = &HFFFFB044

Public Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As
 Long, ByVal lpString As String) As Long
Public Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As
 Long, ByVal lpString As String, ByVal hData As Long) As Long
Public Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd
 As Long, ByVal lpString As String) As Long
Public Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As
 Any, lpvSource As Any, ByVal cbCopy As Long)


Private Declare Function SHGetMalloc Lib "shell32" (ppMalloc As IMalloc) As Long
' Defined as an HRESULT that corresponds to S_OK.
Private Const NOERROR = 0

Public m_TreeViewControl As vbalTreeView
Public Const gcOBJECT_PROP As String = "vbalTreeViewCtl:ObjectPtr"

Private m_lID As Long

Public Property Get NextId() As Long
   m_lID = m_lID + 1
   If (m_lID = 0) Then m_lID = 1
   NextId = m_lID
   If (m_lID = &H7FFFFFFF) Then
      m_lID = &H80000000
   End If
End Property

' Returns a reference to the IMalloc interface.
Public Function isMalloc() As IMalloc
Static im As IMalloc
   If (im Is Nothing) Then
      If Not (SHGetMalloc(im) = NOERROR) Then
         ' Fatal error
         Err.Raise 7
      End If
   End If
   Set isMalloc = im
End Function

Public Function tvCustomSortProc(ByVal lParam1 As Long, ByVal lParam2 As Long,
 ByVal lParamSort As Long) As Long
On Error GoTo ErrHandler
   If m_TreeViewControl Is Nothing Then
   Else
       tvCustomSortProc = m_TreeViewControl.OnCustomSort(lParam1, lParam2,
        lParamSort)
   End If
   Exit Function

ErrHandler:
   Debug.Print "Custom sort error " & Err.Number & "," & Err.Description
   Exit Function
End Function

Public Property Get ObjectFromPtr(ByVal lPtr As Long) As Object
Dim objT As Object
   If Not (lPtr = 0) Then
      ' Turn the pointer into an illegal, uncounted interface
      CopyMemory objT, lPtr, 4
      ' Do NOT hit the End button here! You will crash!
      ' Assign to legal reference
      Set ObjectFromPtr = objT
      ' Still do NOT hit the End button here! You will still crash!
      ' Destroy the illegal reference
      CopyMemory objT, 0&, 4
   End If
End Property

Public Sub gErr(ByVal lErrNum As Long, ByVal sSource As String)
Dim sDesc As String
Debug.Assert False
   
   On Error GoTo 0
   
   Select Case lErrNum
   Case 1
      ' Cannot find owner object
      lErrNum = 364
      sDesc = "Object has been unloaded."
   
   Case 2
      ' Bar does not exist
      lErrNum = vbObjectError + 25001
      sDesc = "TreeView does not exist."
      
   Case 3
      ' Item does not exist
      lErrNum = vbObjectError + 25002
      sDesc = "Node does not exist."
      
   Case 4
      ' Invalid key: numeric
      lErrNum = 13
      sDesc = "Type Mismatch."
      
   Case 5
      ' Invalid Key: duplicate
      lErrNum = 457
      sDesc = "This key is already associated with an element of this
       collection."
   
   Case 6
      ' Subscript out of range
      lErrNum = 9
      sDesc = "Subscript out of range."
      
   Case 7
      ' Failed to add a resource/out of memory
      lErrNum = 7
      sDesc = "Out of Memory."
            
   Case Else
      Debug.Assert "Unexpected Error" = ""
   
   End Select
      
   Err.Raise lErrNum, App.EXEName & "." & sSource, sDesc
End Sub