home *** CD-ROM | disk | FTP | other *** search
/ Dan Appleman's Visual Bas…s Guide to the Win32 API / Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD / VB5PG32.mdf / classlib / desaware / dwmemory.cls < prev    next >
Encoding:
Text File  |  1996-04-05  |  4.8 KB  |  157 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "dwMemory"
  6. Attribute VB_Creatable = True
  7. Attribute VB_Exposed = True
  8. Option Explicit
  9.  
  10. ' Class dwMemory
  11. ' Memory Heap class
  12. ' Copyright (c) 1996 by Desaware Inc.
  13. ' Part of the Desaware API Classes Library
  14.  
  15. #If Win32 Then
  16.  
  17. Private iMemAddr&
  18. Private iMemSize&
  19. Private iHeap&
  20.  
  21. '0 - Process Heap
  22. '1 - User Heap
  23. Private HeapSource%
  24. '**********************************
  25. '**  Function Declarations:
  26.  
  27. #If Win32 Then
  28. Private Declare Function apiGetProcessHeap& Lib "kernel32" Alias "GetProcessHeap" ()
  29. Private Declare Function apiHeapAlloc& Lib "kernel32" Alias "HeapAlloc" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long)
  30. Private Declare Function apiHeapCompact& Lib "kernel32" Alias "HeapCompact" (ByVal hHeap As Long, ByVal dwFlags As Long)
  31. Private Declare Function apiHeapCreate& Lib "kernel32" Alias "HeapCreate" (ByVal flOptions As Long, ByVal dwInitialSize As Long, ByVal dwMaximumSize As Long)
  32. Private Declare Function apiHeapDestroy& Lib "kernel32" Alias "HeapDestroy" (ByVal hHeap As Long)
  33. Private Declare Function apiHeapFree& Lib "kernel32" Alias "HeapFree" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long)
  34. Private Declare Function apiHeapLock& Lib "kernel32" Alias "HeapLock" (ByVal hHeap As Long)
  35. Private Declare Function apiHeapReAlloc& Lib "kernel32" Alias "HeapReAlloc" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long, ByVal dwBytes As Long)
  36. Private Declare Function apiHeapSize& Lib "kernel32" Alias "HeapSize" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long)
  37. Private Declare Function apiHeapUnlock& Lib "kernel32" Alias "HeapUnlock" (ByVal hHeap As Long)
  38. Private Declare Function apiHeapValidate& Lib "kernel32" Alias "HeapValidate" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long)
  39. #End If 'WIN32
  40.  
  41.  
  42. Public Sub NewHeap(initSize, MaxSize)
  43.     Dim ret&
  44.     
  45.     If HeapSource% = 1 Then
  46.         ret& = apiHeapDestroy(iHeap)
  47.         If ret& = 0 Then RaiseMemoryError
  48.     End If
  49.     HeapSource = 1
  50.     ret& = apiHeapCreate&(0, initSize, MaxSize)
  51.     If ret& = 0 Then RaiseMemoryError
  52.     iHeap = ret&
  53. End Sub
  54.  
  55. Public Property Let hHeap(vHeapHandle As Long)
  56.     Dim ret&
  57.  
  58.     If apiHeapUnlock&(vHeapHandle) = 0 Then RaiseMemoryError
  59.     If HeapSource% = 1 Then
  60.         ret& = apiHeapDestroy(iHeap)
  61.         If ret& = 0 Then RaiseMemoryError
  62.     End If
  63.     HeapSource% = 1
  64. End Property
  65.  
  66. Public Sub UseProcessHeap()
  67.     Dim ret&
  68.  
  69.     If HeapSource% = 1 Then
  70.         ret& = apiHeapDestroy(iHeap)
  71.         If ret& = 0 Then RaiseMemoryError
  72.     End If
  73.     HeapSource% = 0
  74.     iHeap = apiGetProcessHeap()
  75. End Sub
  76.  
  77. Private Sub RaiseMemoryError(Optional errval)
  78.     If IsMissing(errval) Then
  79.         RaiseMemoryError DWERR_APIRESULT
  80.     Else
  81.         RaiseError errval, "dwMemory"
  82.     End If
  83. End Sub
  84.  
  85. Public Sub Alloc(memLength As Long)
  86. Attribute Alloc.VB_HelpID = 2134
  87. Attribute Alloc.VB_Description = "Help available in Visual Basic Programmer's Guide to Win32 API CD ROM"
  88.     Dim ret&
  89.  
  90.     If iMemAddr <> 0 Then
  91.         ret& = apiHeapFree(iHeap, 0, iMemAddr)
  92.         If ret& = 0 Then RaiseMemoryError
  93.         iMemAddr = 0
  94.     End If
  95.     If memLength < 1 Then RaiseMemoryError
  96.     iMemAddr = apiHeapAlloc(iHeap, 0, memLength)
  97.     If iMemAddr = 0 Then RaiseMemoryError
  98.     iMemSize = memLength
  99. End Sub
  100.  
  101. Public Sub ReAlloc(memLength As Long)
  102. Attribute ReAlloc.VB_HelpID = 2135
  103. Attribute ReAlloc.VB_Description = "Help available in Visual Basic Programmer's Guide to Win32 API CD ROM"
  104.     Dim ret&
  105.  
  106.     If iMemAddr <> 0 Then
  107.         ret& = apiHeapFree(iHeap, 0, iMemAddr)
  108.         If ret& = 0 Then RaiseMemoryError
  109.     End If
  110.     If memLength < 1 Then RaiseMemoryError
  111.     iMemAddr = apiHeapReAlloc(iHeap, 0, iMemAddr, memLength)
  112.     If iMemAddr = 0 Then RaiseMemoryError
  113.     iMemSize = memLength
  114. End Sub
  115.  
  116. Private Sub Class_Initialize()
  117.     iMemAddr = 0
  118.     iHeap& = apiGetProcessHeap&
  119. End Sub
  120.  
  121. Private Sub Class_Terminate()
  122.     Cleanup
  123. End Sub
  124.  
  125. Private Sub Cleanup()
  126.     Dim ret&
  127.  
  128.     If iMemAddr <> 0 Then ret& = apiHeapFree(iHeap, 0, iMemAddr)
  129.     If HeapSource% = 1 Then
  130.         ret& = apiHeapDestroy(iHeap)
  131.         If ret& = 0 Then RaiseMemoryError
  132.     End If
  133. End Sub
  134.  
  135. Public Property Get MemAddr() As Long
  136.     MemAddr = iMemAddr
  137. End Property
  138.  
  139. Public Property Get MemSize() As Long
  140.     MemSize = iMemSize
  141. End Property
  142.  
  143. Public Property Get hHeap() As Long
  144.     hHeap = iHeap
  145. End Property
  146.  
  147. Public Sub CopyTo(DestAddr As Long)
  148.    agCopyData ByVal iMemAddr, ByVal DestAddr, iMemSize
  149. End Sub
  150.  
  151. Public Sub CopyFrom(SourceAddr As Long, memLength As Long)
  152.     Alloc (memLength)
  153.     agCopyData ByVal SourceAddr, ByVal iMemAddr, memLength
  154. End Sub
  155.  
  156. #End If ' This class exists in Win32 only
  157.