Как вернуть количество измерений переменной (Variant), переданной ей в VBA - PullRequest
26 голосов
/ 01 августа 2011

Кто-нибудь знает, как вернуть количество измерений переменной (Variant), переданной ей в VBA?

Ответы [ 9 ]

27 голосов
/ 01 августа 2011
Function getDimension(var As Variant) As Long
    On Error GoTo Err
    Dim i As Long
    Dim tmp As Long
    i = 0
    Do While True
        i = i + 1
        tmp = UBound(var, i)
    Loop
Err:
    getDimension = i - 1
End Function

Это единственный способ, которым я мог придумать.Не красиво ...

11 голосов
/ 08 февраля 2016

Чтобы вернуть количество измерений без ошибок глотания:

Private Declare PtrSafe Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" ( _
  ByRef dest As Any, ByVal src As LongPtr, ByVal size As LongPtr)


Public Function GetDimensions(source As Variant) As Integer
  Dim vt As Long, ptr As LongPtr
  memcpy vt, VarPtr(source), 2                       ' read the variant type (2 bytes)                     '
  If (vt And &H2000) = 0 Then Exit Function          ' return 0 if not an array                            '
  memcpy ptr, VarPtr(source) + 8, Len(ptr)           ' read the variant data at offset 8                   '
  If (vt And &H4000) Then memcpy ptr, ptr, Len(ptr)  ' read by reference if the data is a reference        '
  If ptr Then memcpy GetDimensions, ptr, 2           ' read the number of dimensions at offset 0 (2 bytes) '
End Function

Использование:

Sub Examples()

  Dim list1
  Debug.Print GetDimensions(list1)    ' >> 0  '

  list1 = Array(1, 2, 3, 4)
  Debug.Print GetDimensions(list1)    ' >> 1  '

  Dim list2()
  Debug.Print GetDimensions(list2)    ' >> 0  '

  ReDim list2(2)
  Debug.Print GetDimensions(list2)    ' >> 1  '

  ReDim list2(2, 2)
  Debug.Print GetDimensions(list2)    ' >> 2  '

End Sub
9 голосов
/ 02 августа 2011

@ cularis и @Issun имеют совершенно адекватные ответы на поставленный вопрос. Я собираюсь поставить под сомнение ваш вопрос, хотя. У вас действительно есть куча массивов с неизвестным количеством измерений? Если вы работаете в Excel, единственная ситуация, в которой это должно происходить, - это UDF, где вы можете передать либо 1-D массив, либо 2-D массив (или не массив), но ничего больше.

У вас почти никогда не должно быть рутины, которая ожидает чего-то произвольного. И поэтому у вас, вероятно, не должно быть общей подпрограммы «поиск # измерений массива».

Итак, имея в виду, вот процедуры, которые я использую:

Global Const ERR_VBA_NONE& = 0
Global Const ERR_VBA_SUBSCRIPT_OUT_OF_RANGE& = 9

'Tests an array to see if it extends to a given dimension
Public Function arrHasDim(arr, dimNum As Long) As Boolean
    Debug.Assert IsArray(arr)
    Debug.Assert dimNum > 0

    'Note that it is possible for a VBA array to have no dimensions (i.e.
    ''LBound' raises an error even on the first dimension). This happens
    'with "unallocated" (borrowing Chip Pearson's terminology; see
    'http://www.cpearson.com/excel/VBAArrays.htm) dynamic arrays -
    'essentially arrays that have been declared with 'Dim arr()' but never
    'sized with 'ReDim', or arrays that have been deallocated with 'Erase'.

    On Error Resume Next
        Dim lb As Long
        lb = LBound(arr, dimNum)

        'No error (0) - array has given dimension
        'Subscript out of range (9) - array doesn't have given dimension
        arrHasDim = (Err.Number = ERR_VBA_NONE)

        Debug.Assert (Err.Number = ERR_VBA_NONE Or Err.Number = ERR_VBA_SUBSCRIPT_OUT_OF_RANGE)
    On Error GoTo 0
End Function

'"vect" = array of one and only one dimension
Public Function isVect(arg) As Boolean
    If IsObject(arg) Then
        Exit Function
    End If

    If Not IsArray(arg) Then
        Exit Function
    End If

    If arrHasDim(arg, 1) Then
        isVect = Not arrHasDim(arg, 2)
    End If
End Function

'"mat" = array of two and only two dimensions
Public Function isMat(arg) As Boolean
    If IsObject(arg) Then
        Exit Function
    End If

    If Not IsArray(arg) Then
        Exit Function
    End If

    If arrHasDim(arg, 2) Then
        isMat = Not arrHasDim(arg, 3)
    End If
End Function

Обратите внимание на ссылку на отличный сайт Чипа Пирсона: http://www.cpearson.com/excel/VBAArrays.htm

См. Также: Как определить, инициализирован ли массив в VB6? . Лично мне не нравится недокументированное поведение, на которое оно опирается, а производительность редко пишется в коде Excel VBA, который я пишу, но, тем не менее, это интересно.

9 голосов
/ 01 августа 2011

Для массивов у MS есть хороший метод, который включает в себя циклическое выполнение до появления ошибки.

"Эта подпрограмма проверяет массив с именем Xarray, проверяя LBound каждого измерения. Используя цикл For ... Nextпроцедура перебирает количество возможных измерений массива до 60000, пока не будет сгенерирована ошибка. Затем обработчик ошибок выполняет шаг счетчика, на котором произошел сбой цикла, вычитает один (потому что предыдущий был последним без ошибки) и отображает результат в окне сообщения .... "

http://support.microsoft.com/kb/152288

Уточненная версия кода (решено писать как функцию, а не как подпрограмму):

Function NumberOfDimensions(ByVal vArray As Variant) As Long

Dim dimnum As Long
On Error GoTo FinalDimension

For dimnum = 1 To 60000
    ErrorCheck = LBound(vArray, dimnum)
Next

FinalDimension:
    NumberOfDimensions = dimnum - 1

End Function
5 голосов
/ 11 декабря 2013

Microsoft документировала структуру VARIANT и SAFEARRAY, и используя их, вы можете анализировать двоичные данные, чтобы получить измерения.

Создать модуль нормального кода.Я называю мои "mdlDims".Вы могли бы использовать его, вызвав простую функцию GetDims и передав ей массив.

Option Compare Database
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (var() As Any) As Long

'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221482(v=vs.85).aspx
Private Type SAFEARRAY
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
End Type

'Variants are all 16 bytes, but they are split up differently based on the contained type
'VBA doesn't have the ability to Union, so a Type is limited to representing one layout
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221627(v=vs.85).aspx
Private Type ARRAY_VARIANT
    vt As Integer
    wReserved1 As Integer
    wReserved2 As Integer
    wReserved3 As Integer
    lpSAFEARRAY As Long
    data(4) As Byte
End Type

'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221170(v=vs.85).aspx
Private Enum VARENUM
    VT_EMPTY = &H0
    VT_NULL
    VT_I2
    VT_I4
    VT_R4
    VT_R8
    VT_CY
    VT_DATE
    VT_BSTR
    VT_DISPATCH
    VT_ERROR
    VT_BOOL
    VT_VARIANT
    VT_UNKNOWN
    VT_DECIMAL
    VT_I1 = &H10
    VT_UI1
    VT_UI2
    VT_I8
    VT_UI8
    VT_INT
    VT_VOID
    VT_HRESULT
    VT_PTR
    VT_SAFEARRAY
    VT_CARRAY
    VT_USERDEFINED
    VT_LPSTR
    VT_LPWSTR
    VT_RECORD = &H24
    VT_INT_PTR
    VT_UINT_PTR
    VT_ARRAY = &H2000
    VT_BYREF = &H4000
End Enum

Public Function GetDims(VarSafeArray As Variant) As Integer
    Dim varArray As ARRAY_VARIANT
    Dim lpSAFEARRAY As Long
    Dim sArr As SAFEARRAY

    'Inspect the Variant
    CopyMemory VarPtr(varArray.vt), VarPtr(VarSafeArray), 16&

    'If the Variant is pointing to an array...
    If varArray.vt And (VARENUM.VT_ARRAY Or VARENUM.VT_BYREF) Then

        'Get the pointer to the SAFEARRAY from the Variant
        CopyMemory VarPtr(lpSAFEARRAY), varArray.lpSAFEARRAY, 4&

        'If the pointer is not Null
        If Not lpSAFEARRAY = 0 Then
            'Read the array dimensions from the SAFEARRAY
            CopyMemory VarPtr(sArr), lpSAFEARRAY, LenB(sArr)

            'and return them
            GetDims = sArr.cDims
        Else
            'The array is uninitialized
            GetDims = 0
        End If
    Else
        'Not an array, you could choose to raise an error here
        GetDims = 0
    End If
End Function
0 голосов
/ 19 июня 2017
Function ArrayDimension(ByRef ArrayX As Variant) As Byte
    Dim i As Integer, a As String, arDim As Byte
    On Error Resume Next
    i = 0
    Do
        a = CStr(ArrayX(0, i))
        If Err.Number > 0 Then
            arDim = i
            On Error GoTo 0
            Exit Do
        Else
             i = i + 1
        End If
    Loop
    If arDim = 0 Then arDim = 1
    ArrayDimension = arDim
End Function
0 голосов
/ 04 августа 2016

Полагаю, вы имеете в виду, не используя On Error Resume Next, что не нравится большинству программистов, а также означает, что во время отладки вы не можете использовать «Break On All Errors», чтобы заставить код остановиться до смерти (Инструменты-> Параметры-> Общие-> Error Trapping-> Break on All Errors).

Для меня одно решение - похоронить любое On Resume Resume Next в скомпилированную DLL, в прежние времена это был VB6.Сегодня вы можете использовать VB.NET, но я предпочитаю использовать C #.

Если Visual Studio доступна для вас, то вот некоторый источник.Он вернет словарь, Dicitionary.Count вернет количество измерений.Элементы также будут содержать LBound и UBound в виде объединенной строки.Я всегда запрашиваю массив не только для его измерений, но также для LBound и UBound этих измерений, поэтому я собираю их вместе и возвращаю весь набор информации в словаре сценариев

Вот источник C #, начнитеБиблиотека классов, называющая ее BuryVBAErrorsCS, установите ComVisible (true), добавьте ссылку на библиотеку COM «Microsoft Scripting Runtime», зарегистрируйтесь для взаимодействия.

using Microsoft.VisualBasic;
using System;
using System.Runtime.InteropServices;

namespace BuryVBAErrorsCS
{
    // Requires adding a reference to COM library Microsoft Scripting Runtime
    // In AssemblyInfo.cs set ComVisible(true);
    // In Build tab check 'Register for Interop'
    public interface IDimensionsAndBounds
    {
        Scripting.Dictionary DimsAndBounds(Object v);
    }

    [ClassInterface(ClassInterfaceType.None)]
    [ComDefaultInterface(typeof(IDimensionsAndBounds))]
    public class CDimensionsAndBounds : IDimensionsAndBounds
    {
        public Scripting.Dictionary DimsAndBounds(Object v)
        {
            Scripting.Dictionary dicDimsAndBounds;
            dicDimsAndBounds = new Scripting.Dictionary();

            try
            {
                for (Int32 lDimensionLoop = 1; lDimensionLoop < 30; lDimensionLoop++)
                {
                    long vLBound = Information.LBound((Array)v, lDimensionLoop);
                    long vUBound = Information.UBound((Array)v, lDimensionLoop);
                    string concat = (string)vLBound.ToString() + " " + (string)vUBound.ToString();
                    dicDimsAndBounds.Add(lDimensionLoop, concat);
                }
            }
            catch (Exception)
            {

            }

            return dicDimsAndBounds;
        }
    }
}

Для кода клиента VBA для Excel здесь приведен некоторый источник

Sub TestCDimensionsAndBounds()
    '* requires Tools->References->BuryVBAErrorsCS.tlb
    Dim rng As Excel.Range
    Set rng = ThisWorkbook.Worksheets.Item(1).Range("B4:c7")

    Dim v As Variant
    v = rng.Value2

    Dim o As BuryVBAErrorsCS.CDimensionsAndBounds
    Set o = New BuryVBAErrorsCS.CDimensionsAndBounds

    Dim dic As Scripting.Dictionary
    Set dic = o.DimsAndBounds(v)

    Debug.Assert dic.Items()(0) = "1 4"
    Debug.Assert dic.Items()(1) = "1 2"


    Dim s(1 To 2, 2 To 3, 3 To 4, 4 To 5, 5 To 6)
    Set dic = o.DimsAndBounds(s)
    Debug.Assert dic.Items()(0) = "1 2"
    Debug.Assert dic.Items()(1) = "2 3"
    Debug.Assert dic.Items()(2) = "3 4"
    Debug.Assert dic.Items()(3) = "4 5"
    Debug.Assert dic.Items()(4) = "5 6"


    Stop
End Sub

NOTE WELL : Этот ответ обрабатывает варианты сетки, извлеченные из таблицы с Range.Value, а также массивы, созданные в коде с использованием Dim s (1) и т. Д.!Некоторые из других ответов не делают этого.

0 голосов
/ 02 июня 2016

Я нашел довольно простой способ проверки, возможно, загруженный множеством кодов, ложных слов и неверных методов, но тем не менее:

Dim i as Long
Dim VarCount as Long
Dim Var as Variant

'generate your variant here

i = 0
VarCount = 0
recheck1:
  If IsEmpty(Var(i)) = True Then GoTo VarCalc
    i = i + 1
    GoTo recheck1
VarCalc:
  VarCount= i - 1

Примечание: VarCount, очевидно, вернет отрицательное число, если Var (0) не существует. VarCount - это максимальный ссылочный номер для использования с Var (i), i - это количество вариантов, которые у вас есть.

0 голосов
/ 02 июля 2014

А как насчет использования ubound (var) + 1?Это должно дать вам последний элемент большинства переменных (если это не пользовательский диапазон, но в этом случае вы уже должны знать эту информацию).Диапазон обычной переменной (например, при использовании функции split) начинается с 0;Ubound дает вам последний элемент переменной.Так, если у вас есть переменная с 8 элементами, например, она изменится с 0 (lbound) до 7 (ubound), и вы можете узнать количество элементов, просто добавив ubound (var) + 1. Например:

Public Sub PrintQntElements()
    Dim str As String
    Dim var As Variant
    Dim i As Integer

    str = "Element1!Element2!Element3!Element4!Element5!Element6!Element7!Element8"
    var = Split(str, "!")
    i = UBound(var) + 1
    Debug.Print "First element: " & LBound(var)
    Debug.Print "Last element: " & UBound(var)
    Debug.Print "Quantity of elements: " & i
End Sub

Он выведет этот вывод в промежуточное окно:
Первый элемент: 0
Последний элемент: 7
Количество элементов: 8

Кроме того, если вы неубедитесь, что первый элемент (lbound) равен 0, вы можете просто использовать:

i = UBound (var) - LBound (var) + 1

...