VBA, MS Access MS Access в примерах

FSO - Список имен файлов из указанной папки в списке (ListBox) (+ Пример)

Основной код из примера:

Private Sub cmdOpenExcelFile_Click() 'Кнопка открытия (выбранного в списке) файла
Dim sVal$

'Проверка что значение в списке выбрано
    If Me.ListFiles.ListIndex = -1 Then 'Ничего не выбрано
        MsgBox "Не выбран элемент из списка!", vbExclamation, "Внимание!"
        Exit Sub
    End If
    
'Элемент списка выбран - продолжаем:
    sVal = Me.TextFolder & "\" & Me.ListFiles ' полный путь к файлу
    
'Открытие файла программой по умолчанию (см. процедуру ниже)
    WScriptFollowHyperLink sVal
    
End Sub

Private Sub cmdOpenFolder_Click() 'Кнопка выбора папки
Dim sVal As String
'Запуск отображения диалога открытия папки
    With Application.FileDialog(4) '4 = msoFileDialogFolderPicker
       .Filters.Clear                          ' Очичтка возможных прошлых фильтров (опционально)
       .Title = "Please Select a Folder"       ' Заголовок диаллога (опционально и произвольно)
       .InitialFileName = Me.TextFolder & "\"  ' Папка с которой начать просмотр файловой структуры
       'Прверка что пользователь сделал выбор (не нажал кнопку "Отмена")
        If .Show Then
            sVal = .SelectedItems(1)
            If Len(sVal) > 3 Then Me.TextFolder = .SelectedItems(1)
        End If
    End With
'Заполнение списка:
    FilesInFolder Me.TextFolder, "*.xl*"
End Sub

Private Sub Form_Load() 'Событие формы "Загрузка"
'Заполняем поле "Папка" = Путь к папке приложения
    Me.TextFolder = CurrentProject.Path
'Заполнение списка:
    FilesInFolder Me.TextFolder, "*.xl*" '(см. процедуру ниже)
End Sub

Private Sub FilesInFolder(sFolderPath$, Optional sFilesMask = "*.*")
' Процедура заполнения поля списка (ListBox) названиями файлов из указанной папки
' Используется библиотека FSO (FileSystemObject) через "позднее связывание"
'----------------------------------------------------------------------------------------------
' Аргументы:
'   sFolderPath  = Путь к папке - в которой ищем файлы
'   sFilesMask   = Маска поиска файлов (опционально), по умолчанию "*.*" = все файлы
'----------------------------------------------------------------------------------------------
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim sFName$, sVal$
'----------------------------------------------------------------------------------------------
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(sFolderPath)

'Собираем строку для .RowSource списка файлов через точку с запятой, _
    типа: "ИмяФайла01;ИмяФайла02;ИмяФайла03;ИмяФайла04; ..."
    For Each objFile In objFolder.Files  ' Перебор всех файлов в папке
        sFName = objFile.Name            ' Имя файла
        If sFName Like sFilesMask Then   ' Подходит по маске
            'Debug.Print objFolder.Path & "\" & sFName
            sVal = sVal & ";" & sFName   ' Добавляем в конец строки
        End If
    Next objFile

'Обрезка первой точки с запятой (";") из строки
    If Len(sVal) > 2 Then sVal = Mid(sVal, 2)
'Назаначение строки как .RowSource поля списка (ListBox) "ListFiles"
    Me.ListFiles.RowSource = sVal

'Если в поле списка естьзначение то выделяем первое из них
    If Me.ListFiles.ListCount > 0 Then
        Me.ListFiles = Me.ListFiles.Column(0, 0) ' устанавливаем первое значение
    End If
    
'Очистка использованных объектных переменных:
    Set objFile = Nothing
    Set objFolder = Nothing
    Set objFSO = Nothing

End Sub

Private Sub ListFiles_DblClick(Cancel As Integer)
' Повтор действий по: Кнопка открытия (выбранного в списке) файла
    Call cmdOpenExcelFile_Click
End Sub

Private Sub WScriptFollowHyperLink(vLinkOrFilePath)
' Открытие ссылки или файла программой по умолчанию
'----------------------------------------------------------------------------------------------
'Пример эксплуотации:
'   WScriptFollowHyperLink "d:\Temp\Book1.xlsx"
'----------------------------------------------------------------------------------------------

Dim wsShell As Object
Dim sVal As String
On Error GoTo WScriptFollowHyperlink_Err

' Проверка (частичная) переданного значения
    sVal = vLinkOrFilePath & ""
    If Len(sVal) & "" < 5 Then Exit Sub
    
'Обрамляем аргумент двойными кавычками
    sVal = Chr(34) & sVal & Chr(34)

'Открытие файла программой по умолчанию
    Set wsShell = CreateObject("WScript.Shell")
    wsShell.Run sVal
    DoEvents

WScriptFollowHyperlink_End:
    On Error Resume Next
    Set wsShell = Nothing
    Err.Clear
    Exit Sub

WScriptFollowHyperlink_Err:
    MsgBox "Cannot open document:" & vbCrLf & sVal & vbCrLf & _
    "Contact database administrator.  Err: " & Err.Number, vbExclamation, "Error!"
    'Debug.Print "WScriptFollowHyperlink_Line: " & Erl & "."
    Err.Clear
    Resume WScriptFollowHyperlink_End
End Sub


Picture




Скачать

MSA-2007 и выше ( 68 kB) Пример


Назад ToTop
L.E. 04.02.2024
Рейтинг@Mail.ru