VB模拟指针模块mPoint.bas

'File:      mPoint.bas
'Name:      VB模拟指针模块
'Author:    zyl910
'Version:   V1.2
'Updata:    2005-8-28
'E-Mail:    zyl910@sina.com

'功能&特点：
'1.是在栈中建立模拟指针的。这样就允许 递归、多线程
'2.允许编译优化。且这种模拟指针构造方法是 在栈中建立、编译优化 的情况下最快的
'3.能像C/C++的指针一样将指针当数组用
'4.允许负向寻址。这样有助于图像卷积处理、缩放旋转
'5.允许元素大小与步长不同。（Byte可以，好像Single不行）
'6.与VBBoost库兼容。VBBoost库的ArrayOwner是用轻量级对象实现的，使用起来很方便，但不太适合大量数据处理时（如图像处理）的复杂寻址需求及速度需求

'注意：
'1.String、Object都是引用型数据类型。除非你非常了解，否则不要轻易使用。
'2.初始化地址时，别直接改SAFEARRAY1D.pvData修改地址，应该使用Ptr属性。这样具有通用性
'3.别迷信Ptr属性。循环中可以利用地址的连续性优化代码（直接修改SAFEARRAY1D.pvData）

 

Option Explicit

'#################################################
'## Const 常数 ###################################
'#################################################

'## 全局编译常数 #################################
'请在工程属性对话框设置“条件编译参数”

'== [Matthcw Curland]VBBoost =====================
'NOVBOOST:  VBBoost库是否存在

'== [zyl910]API Library ==========================
'IncludeAPILib: 引用了API库，此时不需要手动写API声明

 

'#################################################
'## Win32 API ####################################
'#################################################

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

 

#If NOVBOOST And (IncludeAPILib = 0) Then

Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Var() As Any) As Long

Public Type SAFEARRAY
    cDims As Integer         '这个数组有几维？
    fFeatures As Integer     '这个数组有什么特性？
    cbElements As Long       '数组的每个元素有多大？
    cLocks As Long           '这个数组被锁定过几次？
    pvData As Long           '这个数组里的数据放在什么地方？
    'rgsabound() As SFArrayBOUND
End Type
Public Type SAFEARRAYBOUND
    cElements As Long      '这一维有多少个元素？
    lLbound As Long        '它的索引从几开始？
End Type
Public Type SAFEARRAY1D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    cElements As Long      '这一维有多少个元素？
    lLbound As Long        '它的索引从几开始？
End Type

Public Const FADF_AUTO         As Integer = &H1
Public Const FADF_STATIC       As Integer = &H2
Public Const FADF_EMBEDDED     As Integer = &H4
Public Const FADF_FIXEDSIZE   As Integer = &H10
Public Const FADF_RECORD      As Integer = &H20
Public Const FADF_HAVEIID     As Integer = &H40
Public Const FADF_HAVEVARTYPE As Integer = &H80
Public Const FADF_BSTR       As Integer = &H100
Public Const FADF_UNKNOWN    As Integer = &H200
Public Const FADF_DISPATCH   As Integer = &H400
Public Const FADF_VARIANT    As Integer = &H800
Public Const FADF_RESERVED  As Integer = &HF008

#End If '#If NOVBOOST Then

 

'#################################################
'#################################################
'#################################################

 

'功能：构造模拟指针
'参数：
'pArray:数组的SafeArray结构的地址（VarPtrArray(数组名)的返回值）。必须是空的动态数组
'SA:某个SAFEARRAY1D，用于保存模拟指针描述
'ItemSize:数组元素的长度（所占字节，如Byte型为1），允许元素大小与步长不同
'lLbound:数组的下界
'cElements:数组的项目数（上界 = 下界 + 项目数 - 1）
'返回值：是否成功
Public Function MakePoint(ByVal pArray As Long, _
        ByRef SA As SAFEARRAY1D, ByVal ItemSize As Long, _
        Optional ByVal lLbound As Long = 0, _
        Optional ByVal cElements As Long = &H7FFFFFFF) As Boolean
    If pArray = 0 Then Exit Function
   
    With SA
        .cDims = 1
        .fFeatures = FADF_AUTO Or FADF_FIXEDSIZE
        .cbElements = ItemSize
        .cLocks = 0
        .pvData = 0
        .lLbound = lLbound
        .cElements = cElements
    End With
    CopyMemory ByVal pArray, VarPtr(SA), 4
   
    MakePoint = True
   
End Function

'功能：释放模拟指针
'参数：
'pArray:数组的SafeArray结构的地址（VarPtrArray(数组名)的返回值）
'返回值：是否成功
Public Function FreePoint(ByVal pArray As Long) As Boolean
    If pArray = 0 Then Exit Function
   
    CopyMemory ByVal pArray, 0&, 4
   
    FreePoint = True
   
End Function

'设置模拟指针的地址
'参数：
'SA：某个模拟指针的SafeArray结构
Public Property Get Ptr(ByRef SA As SAFEARRAY1D) As Long
    Ptr = SA.pvData - SA.lLbound * SA.cbElements
End Property

Public Property Let Ptr(ByRef SA As SAFEARRAY1D, ByVal RHS As Long)
    SA.pvData = RHS + SA.lLbound * SA.cbElements
End Property

'取得数组的维数
Public Function GetArrayDims(ByVal pArray As Long) As Integer
    Dim pSA As Long
    Dim cDims As Integer
   
    If pArray = 0 Then Exit Function
   
    CopyMemory pSA, ByVal pArray, 4
    CopyMemory cDims, ByVal CLng(pSA + 0), 2
   
    GetArrayDims = cDims
   
End Function