自已做的一个API内存分配的类

昨天虽然用VB的byte数组去仿造的一个分配的内存，感觉不爽，今天自已做了一个调用api来分配内存的类。

'  clsFixedMemAlloc

Option Explicit

Private Declare Function LocalAlloc Lib "kernel32.dll" ( _
     ByVal wFlags As Long, _
     ByVal wBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32.dll" ( _
     ByVal hMem As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
     ByRef Destination As Any, _
     ByRef Source As Any, _
     ByVal Length As Long)
    
Private Declare Sub CopyMemoryPtrToStr Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
     ByVal Destination As String, _
     ByVal Source As Long, _
     ByVal Length As Long)
    
Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" ( _
     ByVal lpString As String) As Long
    
Private Declare Function lstrlenPtr Lib "kernel32.dll" Alias "lstrlenA" ( _
     ByVal lpString As Long) As Long
    
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyA" ( _
     ByVal lpString1 As String, _
     ByVal lpString2 As String) As Long
    
Private Declare Function lstrcpyPtrToStr Lib "kernel32.dll" Alias "lstrcpyA" ( _
     ByVal lpString1 As String, _
     ByVal lpString2 As String) As Long
Private Const LMEM_FIXED As Long = &H0
Private Const LMEM_ZEROINIT As Long = &H40

Private lPtr As Long
Private bExitFree As Boolean

Public Property Get GetPtr() As Long
    GetPtr = lPtr
End Property

 

Public Function Alloc(nCount As Long, SizeOf As Long, Optional bFreeOld As Boolean = True) As Boolean
    If bFreeOld Then
        If lPtr <> 0 Then
            If LocalFree(lPtr) = 0 Then
                lPtr = 0
            Else
                Err.Raise 2000, "clsFixedMemAlloc", "分配内存时，无法释放原内存"
                Exit Function
            End If
               
        End If
    End If
   
    Dim iRet As Long
    iRet = LocalAlloc(LMEM_FIXED Or LMEM_ZEROINIT, nCount * SizeOf)
    If iRet <> 0 Then
        lPtr = iRet
        Alloc = True
    End If
   
End Function

Public Function FreeOtherMem(ptr As Long) As Boolean
    Dim iRet As Long
    iRet = LocalFree(ptr)
    If iRet = 0 Then FreeOtherMem = True
   
End Function

Public Property Get ExitFree() As Boolean
    ExitFree = bExitFree
End Property

Public Property Let ExitFree(ByVal vNewValue As Boolean)
    bExitFree = vNewValue
End Property

Private Sub Class_Initialize()
    bExitFree = True
End Sub

Private Sub Class_Terminate()
    If bExitFree Then
        If lPtr <> 0 Then
            LocalFree lPtr
        End If
    End If
End Sub

Public Function ToVBStr() As String
    Dim iLen As Long
   
    If lPtr <> 0 Then
        iLen = lstrlenPtr(lPtr)
        If iLen > 0 Then
            ToVBStr = String(iLen, vbNullChar)
            CopyMemoryPtrToStr ToVBStr, lPtr, iLen
        End If
    End If
End Function
'------------------------

'另做了一个打印内存的内容的类

'clsMemPrint

Option Explicit
Private Declare Function lstrlenPtr Lib "kernel32.dll" Alias "lstrlenA" ( _
     ByVal lpString As Long) As Long
Private Declare Sub CopyMemorySrcPtr Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
     ByRef Destination As Any, _
     ByVal Source As Long, _
     ByVal Length As Long)
Private Declare Sub CopyMemoryPtrToStr Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
     ByVal Destination As String, _
     ByVal Source As Long, _
     ByVal Length As Long)
    
Public Enum ePrintOption
    ePO_Char
    ePO_Dec
    ePO_Hex
End Enum

Public Sub MemPrint(lPtr As Long, iLen As Long, Optional op As ePrintOption = ePO_Char)
    If lPtr = 0 Then Exit Sub
    Dim i As Long
    Dim b() As Byte
   
    If iLen <= 0 Then Exit Sub
    ReDim b(iLen - 1)
    CopyMemorySrcPtr b(0), lPtr, iLen
    Dim sHex As String
    For i = 0 To iLen - 1
        Select Case op
            Case ePO_Char
                Debug.Print Chr(b(i));
               
            Case ePO_Dec
                Debug.Print b(i)
            Case ePO_Hex
                sHex = Hex(b(i))
                If Len(sHex) = 1 Then sHex = "0" & sHex
                Debug.Print sHex & " ";
                If ((i + 1) Mod 16) = 0 Then Debug.Print
        End Select
    Next i
   
End Sub
Public Function ToVBStr(lPtr As Long) As String
    Dim iLen As Long
   
    If lPtr <> 0 Then
        iLen = lstrlenPtr(lPtr)
        If iLen > 0 Then
            ToVBStr = String(iLen, vbNullChar)
            CopyMemoryPtrToStr ToVBStr, lPtr, iLen
        End If
    End If
End Function
'------------------------

'另外还做了LMEM_MOVEABLE 类型的内存分配，就不贴代码了。它们的区别我的理解是，LMEM_MOVEABLE 是可以重分配的大小，就是不重分配，系统也可能移动这个分配的内存，只要它没被Lock。系统只记了一个hMem句柄，要获得真正的内存地址，还要用

Private Declare Function LocalLock Lib "kernel32.dll" ( _
  ByVal hMem As Long) As Long
如果用释放时，增长方式重分配时，还要用

Private Declare Function LocalUnlock Lib "kernel32.dll" ( _
  ByVal hMem As Long) As Long