VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "dwMemory"
Attribute VB_Creatable = True
Attribute VB_Exposed = True
Option Explicit

' Class dwMemory
' Memory Heap class
' Copyright (c) 1996 by Desaware Inc.
' Part of the Desaware API Classes Library

#If Win32 Then

Private iMemAddr&
Private iMemSize&
Private iHeap&

'0 - Process Heap
'1 - User Heap
Private HeapSource%
'**********************************
'**  Function Declarations:

#If Win32 Then
Private Declare Function apiGetProcessHeap& Lib "kernel32" Alias "GetProcessHeap" ()
Private Declare Function apiHeapAlloc& Lib "kernel32" Alias "HeapAlloc" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long)
Private Declare Function apiHeapCompact& Lib "kernel32" Alias "HeapCompact" (ByVal hHeap As Long, ByVal dwFlags As Long)
Private Declare Function apiHeapCreate& Lib "kernel32" Alias "HeapCreate" (ByVal flOptions As Long, ByVal dwInitialSize As Long, ByVal dwMaximumSize As Long)
Private Declare Function apiHeapDestroy& Lib "kernel32" Alias "HeapDestroy" (ByVal hHeap As Long)
Private Declare Function apiHeapFree& Lib "kernel32" Alias "HeapFree" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long)
Private Declare Function apiHeapLock& Lib "kernel32" Alias "HeapLock" (ByVal hHeap As Long)
Private Declare Function apiHeapReAlloc& Lib "kernel32" Alias "HeapReAlloc" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long, ByVal dwBytes As Long)
Private Declare Function apiHeapSize& Lib "kernel32" Alias "HeapSize" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long)
Private Declare Function apiHeapUnlock& Lib "kernel32" Alias "HeapUnlock" (ByVal hHeap As Long)
Private Declare Function apiHeapValidate& Lib "kernel32" Alias "HeapValidate" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long)
#End If 'WIN32


Public Sub NewHeap(initSize, MaxSize)
    Dim ret&
    
    If HeapSource% = 1 Then
        ret& = apiHeapDestroy(iHeap)
        If ret& = 0 Then RaiseMemoryError
    End If
    HeapSource = 1
    ret& = apiHeapCreate&(0, initSize, MaxSize)
    If ret& = 0 Then RaiseMemoryError
    iHeap = ret&
End Sub

Public Property Let hHeap(vHeapHandle As Long)
    Dim ret&

    If apiHeapUnlock&(vHeapHandle) = 0 Then RaiseMemoryError
    If HeapSource% = 1 Then
        ret& = apiHeapDestroy(iHeap)
        If ret& = 0 Then RaiseMemoryError
    End If
    HeapSource% = 1
End Property

Public Sub UseProcessHeap()
    Dim ret&

    If HeapSource% = 1 Then
        ret& = apiHeapDestroy(iHeap)
        If ret& = 0 Then RaiseMemoryError
    End If
    HeapSource% = 0
    iHeap = apiGetProcessHeap()
End Sub

Private Sub RaiseMemoryError(Optional errval)
    If IsMissing(errval) Then
        RaiseMemoryError DWERR_APIRESULT
    Else
        RaiseError errval, "dwMemory"
    End If
End Sub

Public Sub Alloc(memLength As Long)
Attribute Alloc.VB_HelpID = 2134
Attribute Alloc.VB_Description = "Help available in Visual Basic Programmer's Guide to Win32 API CD ROM"
    Dim ret&

    If iMemAddr <> 0 Then
        ret& = apiHeapFree(iHeap, 0, iMemAddr)
        If ret& = 0 Then RaiseMemoryError
        iMemAddr = 0
    End If
    If memLength < 1 Then RaiseMemoryError
    iMemAddr = apiHeapAlloc(iHeap, 0, memLength)
    If iMemAddr = 0 Then RaiseMemoryError
    iMemSize = memLength
End Sub

Public Sub ReAlloc(memLength As Long)
Attribute ReAlloc.VB_HelpID = 2135
Attribute ReAlloc.VB_Description = "Help available in Visual Basic Programmer's Guide to Win32 API CD ROM"
    Dim ret&

    If iMemAddr <> 0 Then
        ret& = apiHeapFree(iHeap, 0, iMemAddr)
        If ret& = 0 Then RaiseMemoryError
    End If
    If memLength < 1 Then RaiseMemoryError
    iMemAddr = apiHeapReAlloc(iHeap, 0, iMemAddr, memLength)
    If iMemAddr = 0 Then RaiseMemoryError
    iMemSize = memLength
End Sub

Private Sub Class_Initialize()
    iMemAddr = 0
    iHeap& = apiGetProcessHeap&
End Sub

Private Sub Class_Terminate()
    Cleanup
End Sub

Private Sub Cleanup()
    Dim ret&

    If iMemAddr <> 0 Then ret& = apiHeapFree(iHeap, 0, iMemAddr)
    If HeapSource% = 1 Then
        ret& = apiHeapDestroy(iHeap)
        If ret& = 0 Then RaiseMemoryError
    End If
End Sub

Public Property Get MemAddr() As Long
    MemAddr = iMemAddr
End Property

Public Property Get MemSize() As Long
    MemSize = iMemSize
End Property

Public Property Get hHeap() As Long
    hHeap = iHeap
End Property

Public Sub CopyTo(DestAddr As Long)
   agCopyData ByVal iMemAddr, ByVal DestAddr, iMemSize
End Sub

Public Sub CopyFrom(SourceAddr As Long, memLength As Long)
    Alloc (memLength)
    agCopyData ByVal SourceAddr, ByVal iMemAddr, memLength
End Sub

#End If ' This class exists in Win32 only
