interface.ru

Объект Collection(VBA) как альтернатива динамическому массиву - Программные продукты

4-5 минут

Приведенная ниже функция формирует отсортированный список файлов или  вложенных папок согласно указанного шаблона. Здесь применяется метод быстрой сортировки. Новое значение сравнивается со значением из середины  диапазона, затем одна половина диапазона исключается и цикл повторяется.  Когда новое значение становится меньше первого или больше последнего в интервале, оно добавляется в семейство.

Объест Collection объявляется как Dim col As New Collection.
Использование New в данном случае обязательно.

В вызывающей процедуре можно применить 2 варианта:
Dim col As New Collection Здесь col - пустое семейство.
Set col = GetFilesList(......)
или
Dim col As Collection Здесь col - пустая ссылка на семейство.
Set col = GetFilesList(......)
Во втором варианте переменная может быть в состоянии Nothing, и обращение к свойству Count или любому методу семейства сгенерирует ошибку.
Специалисты настоятельно советуют использовать первый вариант всегда.
Другие возможности Collection:
Можно использовать конструкцию For Each ..... Next.
При добавлении нового элемента можно указать уникальный строковый ключ и затем использовать его при обращении к элементу. Например:
col.Add 100, "New"
MsgBox col("New") ( или col!New )
col.Remove "New"
К сожалению, прочитать значение ключа нельзя.

 Function GetFilesList(Optional PathName As String, _

Optional FoldersOnly As Boolean) As Collection
' Функция возвращает отсортированное семейство имен файлов или
'вложенных папок (если установлен FoldersOnly).
' Аргумент PathName может принимать значение, распознаваемое
'функцией Dir().
On Error GoTo GetFilesList_err
Dim col As New Collection
Dim strFileName As String, strCompareFileName As String, _
i As Integer, j As Integer, MidPos As Integer

If FoldersOnly Then
strFileName = Dir$(PathName, vbDirectory)
Else
strFileName = Dir$(PathName)
End If

Do Until Len(strFileName) = 0
' В режиме поиска вложенных папок игнорирует папки ".",".." и

'файлы.
If FoldersOnly Then
'Если первый символ - "."(код 46), игнорируется.
If Asc(strFileName) = 46 Then GoTo NextFile
'Если отсутствует аттрибут vbDirectory, игнорируется.
If Not (GetAttr(PathName & strFileName) And vbDirectory) = _
vbDirectory Then GoTo NextFile
End If

i = 1
j = col.Count
'Если коллекция пуста - добавляет значение.
If j = 0 Then
col.Add strFileName
GoTo NextFile
End If

SearchBlock:
' Вычисляется средний индекс в диапазоне и извлекается
'соответствующее значение.
MidPos = (i + j) 2
strCompareFileName = col(MidPos)

' Имя нового файла сравнивается с текущим значением.
Select Case StrComp(strFileName, strCompareFileName, _
vbTextCompare)
Case -1 'strFileName < strCompareFileName
'Новое значение меньше текущего.
If MidPos <= i Then
' Если текущий индекс совпадает с начальным(< - для надежности),
'добавляется перед первым значением в диапазоне.
col.Add strFileName, , i
Else
'Диапазон ограничивается первой половиной и цикл повторяется.
j = MidPos - 1
GoTo SearchBlock
End If

Case 1 'strFileName > strCompareFileName
'Новое значение больше текущего.
If MidPos >= j Then
' Если текущий индекс совпадает с конечным(> - для надежности),
'добавляется после конечного значения в диапазоне.
col.Add strFileName, , , j
Else
'Диапазон ограничивается второй половиной и цикл повторяется.
i = MidPos + 1
GoTo SearchBlock
End If

' Case 0 strFileName = strCompareFileName
End Select
NextFile:
strFileName = Dir$(, vbDirectory)
Loop

Set GetFilesList = col

GetFilesList_exit:
Exit Function

GetFilesList_err:
Select Case Err.Number
Case 52
MsgBox "Путь к файлу(папке) указан неправильно.", vbCritical
Case 68
MsgBox "Устройство недоступно.", vbCritical
Case 76
MsgBox "Путь не найден.", vbCritical
Case Else
MsgBox Err & " - " & Err.Description, vbCritical, _
"GetFilesList"
End Select
Resume GetFilesList_exit
End Function