Results 1 to 2 of 2

Thread: VB6 modArrInfo (Array-introspection without Error-Handlers)

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    VB6 modArrInfo (Array-introspection without Error-Handlers)

    Since there's so many often badly written (or incomplete) Array-check-routines floating around,
    here's a Drop-In-Module (you might name it e.g. modArrInfo.bas).

    With that, you can then perform complete Array-instrospection, like shown in the Test-Formcode below:
    Code:
    Option Explicit
     
    Private Sub Form_Load()
      Dim Arr() As String
          Arr = Split("") 'check with an intialized, but not yet redimmed Array (comment out to test an un-initialized case)
          'ReDim Arr(1 To 5, 0 To 0) 'to re-check the calls below with a 2D-redimmed array
          
      Debug.Print "TypeName:", " "; TypeName(Arr)
      Debug.Print "ArrPtrSym:", ArrPtrSym(Arr)
      Debug.Print "ArrPtrSaf:", ArrPtrSaf(Arr)
      Debug.Print "ArrPtrDat:", ArrPtrDat(Arr)
      Debug.Print "ArrDimens:", ArrDimens(Arr)
      Debug.Print "ArrLBound:", ArrLBound(Arr)
      Debug.Print "ArrUBound:", ArrUBound(Arr)
      Debug.Print "ArrLength:", ArrLength(Arr) '<- this is the recommended call, when you check for the necessity of redimensioning
      Debug.Print "ArrElemSz:", ArrElemSz(Arr)
      Debug.Print "ArrMemory:", ArrMemory(Arr); ", ...and the Struct itself:"; ArrMemory(Arr, True) - ArrMemory(Arr)
    End Sub
    Ok, and here the Code for the Drop-In-Module
    Code:
    Option Explicit 'SafeArray-Helpers O. Schmidt
    
    'UDT-Arrays have to use the following call for symbol-ptr retrieval
    '(one should pass the return-value of this function, and not the UDT-array directly)
    Public Declare Function ArrPtrUdt& Lib "msvbvm60" Alias "VarPtr" (Arr() As Any)
    
    Private Declare Function ArrPtr& Lib "msvbvm60" Alias "__vbaRefVarAry" (Arr)
    Private Declare Function DeRef& Lib "msvbvm60" Alias "GetMem4" (ByVal pSrc&, pRes&)
    Private Declare Function SafeArrayGetDim% Lib "oleaut32" (ByVal pSA&)
    Private Declare Function SafeArrayGetElemsize% Lib "oleaut32" (ByVal pSA&)
    Private Declare Function SafeArrayGetLBound& Lib "oleaut32" (ByVal pSA&, ByVal nDim%, pRes&)
    Private Declare Function SafeArrayGetUBound& Lib "oleaut32" (ByVal pSA&, ByVal nDim%, pRes&)
    Private Declare Function SafeArrayAccessData& Lib "oleaut32" (ByVal pSA&, pData&)
    Private Declare Function SafeArrayUnaccessData& Lib "oleaut32" (ByVal pSA&)
    
    'All of the functions below will throw no Errors when used with normal-Arrays (which can be passed directly)
    'The same routine-behaviour is ensured also with UDT-Arrays, but then with one caveat:
    'You need one additional, indirect FuncCall (using the API-call which was defined Public above)
    'Example: Dim Points() As PointAPI
    '         If ArrLength(ArrPtrUdt(Points)) Then 'the UDT-Arr is already redimmed
    
    Function ArrPtrSym(Arr) As Long 'returns the Symbol-Ptr of the Arr-Variable (0 when not initialized)
      If IsArray(Arr) Then ArrPtrSym = ArrPtr(Arr) Else ArrPtrSym = Arr
    End Function
    
    Function ArrPtrSaf(Arr) As Long 'returns a Ptr to the SafeArray-Struct (0 when not initialized)
      If IsArray(Arr) Then DeRef ArrPtrSym(Arr), ArrPtrSaf Else DeRef Arr, ArrPtrSaf
    End Function
    
    Function ArrPtrDat(Arr) As Long 'returns a Ptr to the begin of the underlying data (0 when not initialized)
      SafeArrayAccessData ArrPtrSaf(Arr), ArrPtrDat: SafeArrayUnaccessData ArrPtrSaf(Arr)
    End Function
    
    Function ArrDimens(Arr) As Long 'returns the Arr-Dimensions (0 when not initialized)
      ArrDimens = SafeArrayGetDim(ArrPtrSaf(Arr))
    End Function
    
    Function ArrElemSz(Arr) As Long 'returns the size of an Array-Element in Bytes (0 when not initialized)
      ArrElemSz = SafeArrayGetElemsize(ArrPtrSaf(Arr))
    End Function
    
    Function ArrLBound(Arr, Optional ByVal DimIdx As Long = 1) As Long
      SafeArrayGetLBound ArrPtrSaf(Arr), DimIdx, ArrLBound
    End Function
    
    Function ArrUBound(Arr, Optional ByVal DimIdx As Long = 1) As Long
      If ArrPtrSaf(Arr) Then SafeArrayGetUBound ArrPtrSaf(Arr), DimIdx, ArrUBound Else ArrUBound = -1
    End Function
    
    Function ArrLength(Arr, Optional ByVal DimIdx As Long = 1) As Long 'returns the amount of Array-Slots (for a given dimension)
      ArrLength = ArrUBound(Arr, DimIdx) - ArrLBound(Arr, DimIdx) + 1
    End Function
    
    'returns the memory-size in Bytes, the Data-Allocation of the array currently occupies
    '(optionally adds the mem-size of the SafeArray-Struct itself)
    Function ArrMemory(Arr, Optional ByVal IncludeStructSize As Boolean) As Long
      Dim i As Long
      For i = 1 To ArrDimens(Arr): ArrMemory = IIf(ArrMemory, ArrMemory, 1) * ArrLength(Arr, i): Next
      ArrMemory = ArrMemory * ArrElemSz(Arr)
      If IncludeStructSize Then If ArrPtrSaf(Arr) Then ArrMemory = ArrMemory + ArrDimens(Arr) * 8 + 16
    End Function
    Have fun with it (plus safer ArrayHandling)

    Olaf
    Last edited by Schmidt; Oct 17th, 2021 at 01:36 PM.

  2. #2
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6 modArrInfo (Array-introspection without Error-Handlers)

    CAN'T RUN,ArrPtrSym NEED LONG ARG
    ArrMemory MISSING

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width