' 撰寫人：Devil(璉璉)  E-Mail: qvb3377@ms5.hinet.net  僅供學術測試使用，引用請註明原出處
' --------------------------------------------------------------------------------------
Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Sub CopyPointerToMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)

' 自定宣告 SafeArray
Private Declare Function SafeArrayGetDim Lib "oleaut32" (ByVal lpSafeArray As Long) As Long
Private Declare Function SafeArrayGetElemsize Lib "oleaut32" (ByVal lpSafeArray As Long) As Long
Private Declare Function SafeArrayRedim Lib "oleaut32" (ByVal lpSafeArray As Long, lpSafeArrayBound As typSafeArrayBound) As Long

Public Type typArrayVariant
   uVarType As Integer
   unUsed1 As Integer
   unUsed2 As Long
   Pointer As Long
   unUsed3 As Long
End Type

Public Type typSafeArrayBound
   cElements As Long
   lowerBound As Long
End Type

Public Type typSafeArray
   nDimension As Integer
   fFeatures As Integer
   cbElements As Long
   cLocks As Long
   Pointer As Long
End Type

Private Enum enuSafeArrayMessage
   S_OK = &H0
End Enum

Private Const Lenth_Variant = 16
Private Const Offset_Variant = 8

Public Function myArray(ParamArray hVariant() As Variant)

myArray = mySafeArrayRedim(hVariant, , 1)

End Function

Public Function mySafeArrayRedim(ByVal hVariant As Variant, Optional ByVal ArrayElements, Optional ByVal ArrayLowerBound)

Dim lpArrayBound As typSafeArrayBound

nDim = mySafeArrayGetDim(hVariant)

If IsMissing(ArrayLowerBound) Then
   ArrayLowerBound = LBound(hVariant, nDim)
End If

If IsMissing(ArrayElements) Then
   ArrayElements = UBound(hVariant, nDim) - LBound(hVariant, nDim) + 1
End If

lpArrayBound.cElements = ArrayElements
lpArrayBound.LowerBound = ArrayLowerBound

summy = SafeArrayRedim(GetArrayStructPtr(hVariant), lpArrayBound)

If summy = S_OK Then
   mySafeArrayRedim = hVariant
End If

End Function

Public Function IsArrayInit(ByVal SourceArray As Variant) As Boolean

IsArrayInit = False

Select Case VarType(SourceArray)
Case vbVariant, Is >= vbArray
   nDim = mySafeArrayGetDim(SourceArray)

   If nDim > 0 Then
      IsArrayInit = True
   End If
End Select

End Function

Public Function ArrayGetSize(ByVal SourceArray As Variant) As Long

ArrayGetSize = mySafeArrayGetElemSize(SourceArray) * ArrayGetElements(SourceArray)

End Function

Public Function ArrayGetElements(ByVal SourceArray As Variant) As Long

Dim TargetArray As Variant
Dim tPointer As Long
Dim tSA As typSafeArray

TargetArray = SourceArray
tPointer = GetArrayStructPtr(TargetArray)
CopyMemory tSA, ByVal tPointer, Len(tSA)

With tSA
   If .nDimension > 0 Then
      ReDim BoundItem(1 To .nDimension) As typSafeArrayBound
      
      tPointer = tPointer + Len(tSA)
      CopyMemory BoundItem(1), ByVal tPointer, Len(BoundItem(1)) * .nDimension
   
      nCount = BoundItem(1).cElements
      For i = 2 To .nDimension
         nCount = nCount * BoundItem(i).cElements
      Next i
      
      ArrayGetElements = nCount
   Else
      ArrayGetElements = 0
   End If
End With

End Function

Public Function myArrayGetElemSize(ByVal hVariantArray As Variant) As Long

Dim elemSize As Long
CopyPointerToMemory elemSize, GetArrayStructPtr(hVariantArray) + 4, 4
myArrayGetElemSize = elemSize

End Function

Public Function mySafeArrayGetElemSize(ByVal hVariant As Variant) As Long

mySafeArrayGetElemSize = SafeArrayGetElemsize(GetArrayStructPtr(hVariant))

End Function

Public Function myArrayGetDim(ByVal hVariantArray As Variant) As Long

Dim tDimension As Integer
CopyPointerToMemory tDimension, GetArrayStructPtr(hVariantArray), 2
myArrayGetDim = tDimension

End Function

Public Function mySafeArrayGetDim(ByVal hVariant As Variant) As Long

mySafeArrayGetDim = SafeArrayGetDim(GetArrayStructPtr(hVariant))

End Function

Public Function TransformArrayToOneDimension(ByVal SourceArray As Variant) As Variant

Dim TargetArray As Variant
Dim tPointer As Long
Dim tSA As typSafeArray

TargetArray = SourceArray
tPointer = GetArrayStructPtr(TargetArray)
CopyMemory tSA, ByVal tPointer, Len(tSA)

With tSA
   ReDim BoundItem(1 To .nDimension) As typSafeArrayBound
   
   tPointer = tPointer + Len(tSA)
   CopyMemory BoundItem(1), ByVal tPointer, Len(BoundItem(1)) * .nDimension

   nCount = BoundItem(1).cElements
   For i = 2 To .nDimension
      nCount = nCount * BoundItem(i).cElements
   Next i
   
   BoundItem(1).cElements = nCount
   BoundItem(1).lowerBound = 1
   
   CopyMemory ByVal tPointer, BoundItem(1), Len(BoundItem(1))
   
   .nDimension = 1
   
End With

CopyMemory ByVal tPointer - Len(tSA), tSA, Len(tSA)

TransformArrayToOneDimension = TargetArray

End Function

Public Function GetArrayStructPtr(hVariant As Variant) As Long

Dim ArrayStructPtr As typArrayVariant
CopyMemory ArrayStructPtr, hVariant, Len(ArrayStructPtr)
GetArrayStructPtr = ArrayStructPtr.Pointer

End Function

Public Function GetArrayPtr(hVariant As Variant) As Long

Dim tSA As typSafeArray
Dim tBytes(1 To 32) As Byte
Dim tLong As Long, tPointer As Long

tPointer = GetArrayStructPtr(hVariant)
CopyMemory tSA, ByVal tPointer, Len(tSA)

If tPointer = tSA.Pointer Then
   CopyMemory tLong, ByVal tPointer, Len(tLong)
   CopyMemory tSA, ByVal tLong, Len(tSA)   
End If

GetArrayPtr = tSA.Pointer

End Function

Public Function MyMax(ParamArray MaxMatrix())

lbm = LBound(MaxMatrix)
ubm = UBound(MaxMatrix)
nbm = ubm - lbm + 1

tMax = Empty

If nbm > 0 Then
   For i = lbm To ubm
      Select Case VarType(MaxMatrix(i))
      Case vbError, vbDataObject, vbObject
         tMaxValue = tMax
      Case Is >= vbArray
         MaxArray = MaxMatrix(i)
         nDim = mySafeArrayGetDim(MaxArray)
         If nDim > 1 Then
            MaxArray = TransformArrayToOneDimension(MaxArray)
         End If
         
         lba = LBound(MaxArray)
         uba = UBound(MaxArray)
         nba = uba - lba + 1
         
         tMaxArray = Empty
         
         If nba > 0 Then
            For j = lba To uba
               Select Case VarType(MaxArray(j))
               Case vbError, vbDataObject, vbObject
                  tMaxArrayValue = tMaxArray
               Case Is >= vbArray
                  tMaxArrayValue = MyMax(MaxArray(j))
               Case Else
                  tMaxArrayValue = MaxArray(j)
               End Select
               
               If IsEmpty(tMaxArray) Then
                  tMaxArray = tMaxArrayValue
               ElseIf tMaxArray < tMaxArrayValue And Not IsEmpty(tMaxArrayValue) Then
                  tMaxArray = tMaxArrayValue
               End If
            Next
            
            tMaxValue = tMaxArray
         
         Else
            tMaxValue = tMax
         End If
      Case Else
         tMaxValue = MaxMatrix(i)
      End Select
      
      If IsEmpty(tMax) Then
         tMax = tMaxValue
      ElseIf tMax < tMaxValue And Not IsEmpty(tMaxValue) Then
         tMax = tMaxValue
      End If
   Next
End If

MyMax = tMax

End Function

Public Function MyMin(ParamArray MinMatrix())

lbm = LBound(MinMatrix)
ubm = UBound(MinMatrix)
nbm = ubm - lbm + 1

tMin = Empty

If nbm > 0 Then
   For i = lbm To ubm
      Select Case VarType(MinMatrix(i))
      Case vbError, vbDataObject, vbObject
         tMinValue = tMin
      Case Is >= vbArray
         MinArray = MinMatrix(i)
         nDim = mySafeArrayGetDim(MinArray)
         If nDim > 1 Then
            MinArray = TransformArrayToOneDimension(MinArray)
         End If
         
         lba = LBound(MinArray)
         uba = UBound(MinArray)
         nba = uba - lba + 1
         
         tMinArray = Empty
         
         If nba > 0 Then
            For j = lba To uba
               Select Case VarType(MinArray(j))
               Case vbError, vbDataObject, vbObject
                  tMinArrayValue = tMinArray
               Case Is >= vbArray
                  tMinArrayValue = MyMin(MinArray(j))
               Case Else
                  tMinArrayValue = MinArray(j)
               End Select
               
               If IsEmpty(tMinArray) Then
                  tMinArray = tMinArrayValue
               ElseIf tMinArray > tMinArrayValue And Not IsEmpty(tMinArrayValue) Then
                  tMinArray = tMinArrayValue
               End If
            Next
            
            tMinValue = tMinArray
         
         Else
            tMinValue = tMin
         End If
      Case Else
         tMinValue = MinMatrix(i)
      End Select
      
      If IsEmpty(tMin) Then
         tMin = tMinValue
      ElseIf tMin > tMinValue And Not IsEmpty(tMinValue) Then
         tMin = tMinValue
      End If
   Next
End If

MyMin = tMin

End Function