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
评论