Option Explicit
Call TestFilesCollection(ThisObject)
'==============================================================================
' Выполнить одно из выбранных пользователем действий над коллекцией файлов объекта
'==============================================================================
Sub TestFilesCollection(Obj)
Dim ArActions, FCol, SelDlg, RetVal, strAction
'Получить ссылку на коллецию файлов объекта
Set FCol = Obj.Files
'Если коллекция пустая, выйти из процедуры
If FCol.Count=0 Then
MsgBox "Объект не имеет файлового состава.", vbInformation
Exit Sub
End If
'Предоставить пользователю выбрать действие над коллекцией
ArActions = Array("Найти файл в коллекции", "Добавить копии файлов другого объекта",_
"Удалить файлы из коллекции", "Отобрать файлы по типу")
'Инициализировать и открыть диалог выбора
Set SelDlg = ThisApplication.Dialogs.SelectDlg
SelDlg.SelectFrom = ArActions
SelDlg.Prompt = "Выберите действие:"
RetVal = SelDlg.Show
'Если пользователь отменил диалог или ничего не выбрал, закончить работу.
'Диалог вернул массив, поскольку был инициализирован строковым массивом
If (RetVal <> TRUE) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
'Выполнить все заданные действия
For Each strAction In SelDlg.Objects
If StrComp(strAction, ArActions(0))=0 Then
Call FindFile(FCol)
ElseIf StrComp(strAction, ArActions(1))=0 Then
Call AddFileCopy(FCol, SelDlg)
ElseIf StrComp(strAction, ArActions(2))=0 Then
Call RemoveFile(FCol, SelDlg)
ElseIf StrComp(strAction, ArActions(3))=0 Then
Call GetFilesByType(FCol)
End If
Next
End Sub
'==============================================================================
'==============================================================================
'Найти файл (имя запрашивается у пользователя)
'==============================================================================
Sub FindFile(FCol)
Dim strRet, strInfo, index, file
'Получить имя файла для поиска
strRet = InputBox("Введите имя файла для поиска" & vbCrLf & "(в коротком формате):")
'Если пользователь отменил диалог или ничего не ввел, закончить работу.
If strRet="" Then
MsgBox "Поиск отменен.", vbInformation
Exit Sub
End If
'Получить индекс файла (-1, если не найден)
index = FCol.Index(strRet)
'Сообщить результат
If index <>-1 Then
strInfo = "Файл найден в коллекции; его индекс: " & index & "."
Else
strInfo = "Файл не найден в коллекции."
End If
MsgBox strInfo, vbInformation
End Sub
'==============================================================================
'==============================================================================
'Добавить копии файлов объекта, выбранного пользователем, в коллекцию
'==============================================================================
Sub AddFileCopy(FCol, SelDlg)
Dim obj, ObjFiles, f, RetVal
' Инициализировать диалог коллекцией объектов, лежащих на Рабочем столе
SelDlg.SelectFrom = ThisApplication.Desktop.Objects
SelDlg.Prompt = "Выберите объект, файлы которого будут скопированы:"
RetVal = SelDlg.Show
'Если пользователь отменил диалог или ничего не выбрал, закончить работу.
If (RetVal <> TRUE) Or (SelDlg.Objects.Count=0) Then Exit Sub
'Для всех выбранных в диалоге объектов...
For Each obj In SelDlg.Objects
'Получить ссылку на коллекцию файлов
Set ObjFiles = obj.Files
'Если объект не содержит файлов в составе, сообщить
If ObjFiles.Count=0 Then
Msgbox "Объект """ & obj.Description & """ не содержит файлов в составе.", vbExclamation
'Иначе - скопировать все файлы объекта в нашу коллекцию
Else
On Error Resume Next 'включить перехват ошибок
For Each f In ObjFiles
'поэлементное копирование
FCol.AddCopy f, f.FileName
'Если ошибка была (напр., совпадает имя файла), сообщить и обнулить Err
If Err<>0 Then
Msgbox "Ошибка копирования файла " & f.FileName & ".", vbExclamation
Err = 0
End If
Next
End If
Next
End Sub
'==============================================================================
'==============================================================================
'Удалить файлы, выбранные пользователем, из файлового состава объекта
'==============================================================================
Sub RemoveFile(FCol, SelDlg)
Dim RetVal, file
SelDlg.SelectFrom = FCol
SelDlg.Prompt = "Выберите файлы для удаления:"
RetVal = SelDlg.Show
'Если пользователь отменил диалог или ничего не выбрал, закончить работу.
'В данном случае диалог возвращает коллекцию, поэтому проверяем свойство Count
If (RetVal <> TRUE) Or (SelDlg.Objects.Count=0) Then Exit Sub
For Each file In SelDlg.Objects
FCol.Remove file
Next
'Вызов метода FCol.Remove приводит к генерации пары событий FileBeforeErase, FileErased
End Sub
'==============================================================================
'==============================================================================
'Вывести описание файлов заданного типа (если они есть в составе объекта)
'==============================================================================
Sub GetFilesByType(FCol)
Dim StrDef, FDefs, FColByDef, f, RetVal, i, count, ArFDef, SelDlg, StrMsg
'Инициализировать диалог выбора массивом имен типов файлов
Set SelDlg = ThisApplication.Dialogs.SelectDlg
Set FDefs = ThisApplication.FileDefs
count = FDefs.Count
ReDim ArFDefs(count)
For i=0 To count-1
ArFDefs(i) = FDefs(i).Description
Next
'Показать диалог
SelDlg.SelectFrom = ArFDefs
RetVal = SelDlg.Show
'Если пользователь отменил диалог или ничего не выбрал, закончить работу.
'Диалог вернул массив, поскольку был инициализирован строковым массивом
If (RetVal <> TRUE) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
'Для каждого наименования типа файла: если у объекта в составе есть файлы такого типа -
'перечислить их, иначе сообщить что файлов не найдено
For Each StrDef In SelDlg.Objects
'ПОлучить ссылку на суб-коллекцию файлов выбранного типа
Set FColByDef = FCol.FilesByDef(ThisApplication.FileDefs(StrDef))
'Обработать коллекцию: если файлов не найдено - сообщить, иначе сформировать
'строку с именами найденных файлов.
If FColByDef.Count=0 Then
StrMsg = "Файлов типа """ & StrDef & """ не найдено."
Else
StrMsg = "Найдено " & FColByDef.Count & " файлов типа """ & StrDef & """:" & Chr(13)
For Each f In FColByDef
StrMsg = StrMsg & Chr(13) & f.FileName
Next
End If
'Сообщить результат
MsgBox StrMsg, vbInformation
Next
End Sub
'==============================================================================
Исходный текст