Нахожу другое решение вопроса
Option Base 0
Option Compare Binary
Option Explicit
Private Const VT_BYREF = &H4000
Private Const VARIANT_DATA_OFFSET As Long = 8
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" _
(ByVal pSA As Long) _
As Long
Private Declare Function SafeArrayGetLBound Lib "oleaut32.dll" _
(ByVal pSA As Long, _
ByVal nDim As Long, _
ByRef plLbound As Long) _
As Long
Private Declare Function SafeArrayGetUBound Lib "oleaut32.dll" _
(ByVal pSA As Long, _
ByVal nDim As Long, _
ByRef plUbound As Long) _
As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(ByRef lpDest As Any, _
ByRef lpSource As Any, _
ByVal lByteLen As Long)
'
Public Function LBoundEx(ByRef vArray As Variant, _
Optional ByVal lDimension As Long = 1) As Long
Dim iDataType As Integer
Dim pSA As Long
'Make sure an array was passed in:
If IsArray(vArray) Then
'Try to get the pointer:
CopyMemory pSA, ByVal VarPtr(vArray) + VARIANT_DATA_OFFSET, 4
If pSA Then
'If byref then deref the pointer to get the actual pointer:
CopyMemory iDataType, vArray, 2
If iDataType And VT_BYREF Then
CopyMemory pSA, ByVal pSA, 4
End If
If pSA Then
If lDimension > 0 Then
'Make sure this is a valid array dimension:
If lDimension <= SafeArrayGetDim(pSA) Then
'Get the LBound:
SafeArrayGetLBound pSA, lDimension, LBoundEx
Else
LBoundEx = -1
End If
Else
Err.Raise vbObjectError Or 10000, "LBoundEx", "Invalid Dimension"
End If
Else
LBoundEx = -1
End If
Else
LBoundEx = -1
End If
Else
Err.Raise vbObjectError Or 10000, "LBoundEx", "Not an array"
End If
End Function
Public Function UBoundEx(ByRef vArray As Variant, _
Optional ByVal lDimension As Long = 1) As Long
Dim iDataType As Integer
Dim pSA As Long
'Make sure an array was passed in:
If IsArray(vArray) Then
'Try to get the pointer:
CopyMemory pSA, ByVal VarPtr(vArray) + VARIANT_DATA_OFFSET, 4
If pSA Then
'If byref then deref the pointer to get the actual pointer:
CopyMemory iDataType, vArray, 2
If iDataType And VT_BYREF Then
CopyMemory pSA, ByVal pSA, 4
End If
If pSA Then
If lDimension > 0 Then
'Make sure this is a valid array dimension:
If lDimension <= SafeArrayGetDim(pSA) Then
'Get the UBound:
SafeArrayGetUBound pSA, lDimension, UBoundEx
Else
UBoundEx = -1
End If
Else
Err.Raise vbObjectError Or 10000, "UBoundEx", "Invalid Dimension"
End If
Else
UBoundEx = -1
End If
Else
UBoundEx = -1
End If
Else
Err.Raise vbObjectError Or 10000, "UBoundEx", "Not an array"
End If
End Function
Private Function test()
Dim Cdo() As Variant
Dim a() As String
Dim b() As String
ReDim Cdo(1 To 5, 1 To 2)
ReDim a(1 To 2)
ReDim b(1 To 3, 1 To 2)
Cdo(1, 2) = a
Cdo(2, 2) = b
'- test
Dim x As Long
Dim y As Long
Dim z As Long
Dim q As Long
Dim ok As Boolean
x = 2
y = 2
z = 2
q = 2 '- set to -1 for Cdo(x, y)(z) and to >=0 for Cdo(x, y)(z,q)
ok = False
If (UBoundEx(Cdo, 1) >= x) Then
If (UBoundEx(Cdo, 2) >= y) Then
If (Not IsEmpty(Cdo(x, y))) Then
If (UBoundEx(Cdo(x, y), 1) >= z) Then
If (q >= 0) Then
If (UBoundEx(Cdo(x, y), 2) >= q) Then
Debug.Print Cdo(x, y)(z, q)
ok = True
End If
Else
If (UBoundEx(Cdo(x, y), 2) = -1) Then
Debug.Print Cdo(x, y)(z)
ok = True
End If
End If
End If
End If
End If
End If
if (ok) then
debug.print "OK"
end it
End Function