|
借用一下API：
Option
Explicit
Declare
Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, source As Any, ByVal Length As
Long)
Declare
Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As
Long
Const AppName = "Stanley Pan Hint:"
Public
Sub ArrayDimensionTest()
Dim varArray() As
Integer
'dim a variables to contain array
ReDim varArray(1) As
Integer
'one dimension
MsgBox ArrayDims(VarPtrArray(varArray)), vbInformation, AppName
ReDim varArray(1, 2) As
Integer
'two dimension
MsgBox ArrayDims(VarPtrArray(varArray)), vbInformation, AppName
ReDim varArray(2, 3, 4) As
Integer
'three dimension
MsgBox ArrayDims(VarPtrArray(varArray)), vbInformation, AppName
ReDim varArray(1, 2, 3, 4) As
Integer
'Four dimension
MsgBox ArrayDims(VarPtrArray(varArray)), vbInformation, AppName
End
Sub
Public
Function ArrayDims(ByVal lpArray As
Long) As
Integer
Dim lAddress As
Long
CopyMemory lAddress, ByVal lpArray, 4
If lAddress = 0 Then
' The array isn't initilized
ArrayDims = -1
Exit
Function
End
If
CopyMemory ArrayDims, ByVal lAddress, 2
End
Function
还有一个 'GetArrayInfo - Retreive number of dimensions and the SAFEARRAY memory structure
Type SAFEARRAYBOUND
cElements As
Long
' # of elements in the array dimension
lLbound As
Long
' lower bounds of the array dimension
End
Type
Type SAFEARRAY
cDims As
Integer
' Count of dimensions in this array.
fFeatures As
Integer
' Flags used by the SAFEARRAY routines documented
' below.
cbElements As
Long
' Size of an element of the array.
cLocks As
Long
' Number of times the array has been
' locked without corresponding unlock.
pvData As
Long
' Pointer to the data.
rgsabound(1 To 60) As SAFEARRAYBOUND ' One bound for each dimension.
' An array can have max 60 dimensions, only the first cDims items will be
' used
' note that rgsabound elements are in reverse order,
' e.g. for a 2-dimensional
' array, rgsabound(1) holds info about columns, and rgsabound(2) about rows
End
Type
Private
Declare
Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _
Any, source As Any, ByVal bytes As Long)
Private
Const VT_BYREF = &H4000&
' Fills a SAFEARRAY structure for the supplied array.
'
' The information contained in the SAFEARRAY structure allows
' the caller to identify the number of dimensions and the
' number of elements for each dimension (among other things).
' Element information for each dimension is stored in a
' one-based sub-array of SAFEARRAYBOUND structures (rgsabound).
'
' TheArray The array to get information on.
' ArrayInfo The output SAFEARRAY structure.
'
' RETURNS The number of dimensions of the array
' or zero if the array isn't dimensioned
Function GetArrayInfo(TheArray As
Variant, ArrayInfo As SAFEARRAY) As
Boolean
Dim lp As
Long
' work pointer variable
Dim VType As
Integer
' the VARTYPE member of the VARIANT structure
' Exit if no array supplied
If
Not IsArray(TheArray) Then
Exit
Function
With ArrayInfo
' Get the VARTYPE value from the first 2 bytes of the VARIANT structure
CopyMemory VType, TheArray, 2
' Get the pointer to the array descriptor (SAFEARRAY structure)
' NOTE: A Variant's descriptor, padding & union take up 8 bytes.
CopyMemory lp, ByVal VarPtr(TheArray) + 8, 4
' Test if lp is a pointer or a pointer to a pointer.
If (VType And VT_BYREF) <> 0 Then
' Get real pointer to the array descriptor (SAFEARRAY structure)
CopyMemory lp, ByVal lp, 4
End
If
' Fill the SAFEARRAY structure with the array info
' NOTE: The fixed part of the SAFEARRAY structure is 16 bytes.
CopyMemory ArrayInfo.cDims, ByVal lp, 16
' Ensure the array has been dimensioned before getting SAFEARRAYBOUND
' Information
If ArrayInfo.cDims > 0 Then
' Fill the SAFEARRAYBOUND structures with the array info
CopyMemory .rgsabound(1), ByVal lp + 16, _
ArrayInfo.cDims * Len(.rgsabound(1))
' So caller knows there is information available for the array in
' output SAFEARRAY
GetArrayInfo = ArrayInfo.cDims
End
If
End
With
End
Function
Sub XXX()
Dim A(1, 2, 3, 4, 5, 6, 7, 100)
Dim INFO As SAFEARRAY
GetArrayInfo A, INFO
MsgBox INFO.cDims
End
Sub | 
楼主: Dj_soo
IP卡
狗仔卡
发表于 2010-3-30 10:37
显身卡
楼主
发表于 2010-3-30 11:16
