一个VB数组指针类

Option Explicit

‘自定义的数组类型枚举
Public Enum vbArray_Type
    vbArrayByte = vbByte Or vbArray             ‘1Bytes
    vbArrayInteger = vbInteger Or vbArray       ‘2Bytes
    vbArrayLong = vbLong Or vbArray             ‘4Bytes
    vbArrayCurrency = vbCurrency Or vbArray     ‘8Bytes
End Enum

Private Type SAFEARRAYBOUND
    cElements As Long                           ‘这一维有多少个元素？
    lLbound As Long                             ‘它的索引从几开始？
End Type
Private Const MAX_DIMS = 0                      ‘数组最大维数为1维(下标为0)
Private Type SAFEARRAY                          ‘安全数组结构定义
    cDims As Integer                            ‘维数
    fFeatures As Integer                        ‘标志
    cbElements As Long                          ‘单个元素的字节数
    clocks As Long                              ‘锁定计数
    pvData As Long                              ‘指向数组元素的指针
    rgsabound(MAX_DIMS) As SAFEARRAYBOUND       ‘定义维数边界
End Type

Private Declare Function VarPtrArray Lib “msvbvm60.dll” Alias “VarPtr” (ptr() As Any) As Long
Private Declare Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetCurrentProcess Lib “kernel32” () As Long

Private Const FADF_AUTO = &H1                   ‘在栈上创建数组
Private Const FADF_STATIC = &H2                 ‘在堆上创建数组
Private Const FADF_EMBEDDED = &H4               ‘在结构中创建
Private Const FADF_FIXEDSIZE = &H10             ‘不能改变数组大小
Private Const FADF_RECORD = &H20                ‘记录容器
Private Const FADF_HAVEIID = &H40               ‘有IID 身份标记 数组
Private Const FADF_HAVEVARTYPE = &H80           ‘VT 类型数组
Private Const FADF_BSTR = &H100                 ‘BSTR数组
Private Const FADF_UNKNOWN = &H200              ‘IUnknown* 数组
Private Const FADF_DISPATCH = &H400             ‘IDispatch* 数组
Private Const FADF_VARIANT = &H800              ‘VARIANTs数组
Private Const FADF_RESERVED = &HF0E8            ‘保留，将来使用
 
Private Type MEMORY_BASIC_INFORMATION
     BaseAddress As Long
     AllocationBase As Long
     AllocationProtect As Long
     RegionSize As Long
     State As Long
     Protect As Long
     lType As Long
End Type
Private Declare Function VirtualQueryEx Lib “kernel32” (ByVal hProcess As Long, lpAddress As Any, lpBuffer As MEMORY_BASIC_INFORMATION, ByVal dwLength As Long) As Long
Private Const PAGE_READONLY = &H2               ‘只读属性，如果试图进行写操作，将引发访问违规。如果系统区分只读、执行两种属性，那么试图在该区域执行代码也将引发访问违规
Private Const PAGE_READWRITE = &H4              ‘允许读写
Private Const PAGE_EXECUTE_READ = &H20          ‘允许读和执行代码
Private Const PAGE_EXECUTE_READWRITE = &O40     ‘允许读和执行代码

Dim m_pvArray() As Variant                      ‘通用指针数组
Dim m_nCountRef As Long                         ‘引用计数

‘将一个VB一维数组绑定指定的内存地址上
Public Function Bind(ByVal lpMemoryAddress As Long, dwBytes As Long, Optional ByVal vtType As vbArray_Type = vbByte) As Variant
    Dim SA As SAFEARRAY
   
    ‘置默认返回值为Empty
    Bind = Empty
   
    ‘判断字节数是否合法
    If dwBytes <= 0 Then Exit Function
   
    ‘判断内存是否可读
    Dim hProcess As Long
    Dim MBI As MEMORY_BASIC_INFORMATION
    Dim MBI_SIZE As Long
    MBI_SIZE = Len(MBI)
    hProcess = GetCurrentProcess()
    If VirtualQueryEx(hProcess, lpMemoryAddress, MBI, MBI_SIZE) <> MBI_SIZE Then ‘函数运行失败
        Exit Function
    End If
    If Not (((MBI.Protect And PAGE_READONLY) = PAGE_READONLY) Or ((MBI.Protect And PAGE_READWRITE) = PAGE_READWRITE) Or ((MBI.Protect And PAGE_EXECUTE_READ) = PAGE_EXECUTE_READ) Or ((MBI.Protect And PAGE_EXECUTE_READWRITE) = PAGE_EXECUTE_READWRITE)) Then
        Exit Function
    End If
   
    ‘构造一个一维数组
    Dim cbElem As Long
    cbElem = Switch(vtType = vbArrayByte, 1, vtType = vbArrayInteger, 2, vtType = vbArrayLong, 4, vtType = vbArrayCurrency, 8)
    SA.cDims = 1
    SA.fFeatures = FADF_AUTO Or FADF_EMBEDDED Or FADF_FIXEDSIZE
    SA.cbElements = cbElem
    SA.clocks = 0
    SA.pvData = lpMemoryAddress                        ‘真实数组(非安全数组结构)的地址(可用VarPtr(数组首个成员变量)获取)或指定内址地址，注意：绝对不能使用VarPtrArray获取地址
    SA.rgsabound(0).cElements = dwBytes / cbElem       ‘按数组单个元素的大小对齐
    SA.rgsabound(0).lLbound = 0
   
    ‘设置pV的数据类型为安全数组
    m_nCountRef = m_nCountRef + 1
    If m_nCountRef > UBound(m_pvArray) Then
        ReDim Preserve m_pvArray(UBound(m_pvArray) + 10)          ‘以10递增扩展VARIANT类型的指针数组
    End If
   
    ‘绑定数组到一个VARIANT变量上
    Dim pSV As Long
    Dim pSA As Long
    pSA = VarPtr(SA)
    pSV = VarPtr(m_pvArray(m_nCountRef))
    CopyMemory ByVal pSV, vtType, 2
    CopyMemory ByVal pSV + 8, pSA, 4
  
    Bind = m_pvArray(m_nCountRef)
End Function

‘此函数释放未被使用的m_pV数组的成员变量，并减少引用计数
Public Function UnBind(ByRef pvSA As Variant) As Boolean
    Dim lpMemoryAddress As Long
   
    On Error GoTo ErrHandle
    If (VarType(pvSA) And vbArray) = vbArray Then           ‘说明参数为数组
        ‘获得数组的下标和维数
       
        lpMemoryAddress = VarPtr(pvSA(0))
    Else
        If VarType(pvSA) = vbLong Then                      ‘说明参数为地址
        End If
    End If
ErrHandle:
End Function

Private Sub Class_Initialize()
    m_nCountRef = 0
    ReDim m_pvArray(1 To 10)                                  ‘为了减少内存调整，预定义10个VARIANT类型的指针
End Sub

Private Sub Class_Terminate()
    Dim i As Long
    Dim pSV As Long

    pSV = VarPtr(m_pvArray(1))
    For i = 1 To m_nCountRef
        CopyMemory ByVal pSV + 8 + (i – 1) * 16, 0&, 4
    Next
    Erase m_pvArray
End Sub

Option Explicit

Sub main()
    Dim s As String
    Dim vbptr As New VbArrayPtr
    Dim p As Variant
    Dim i As Integer
   
    s = “我爱你中国”
    p = vbptr.Bind(StrPtr(s), LenB(StrConv(s, vbFromUnicode)), vbArrayInteger)
    For i = 0 To UBound(p)
        Debug.Print p(i)
    Next
    vbptr.UnBind (p)
   
End Sub