Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню FAQ | Макросы | FileSystemObject


Rambler's Top100


Counter CO.KZ


    [1] [2]

  1. Как определить наличие файла средствами FSO ? 18.07.2007
  2. Как определить наличие папки, каталога средствами FSO ? 30.06.2007
  3. Как определить имя родительской папки средствами FSO ? 18.07.2007
  4. Как определить размер всех файлов в указанной папке, средствами FSO ? 30.06.2007
  5. Как создать папку, каталог средствами FSO ? 28.08.2007
  6. Как создать папку, каталог, даже в случае отсутствия родительской папки, с помощью FSO ? 27.12.2010
  7. Как переименовать папку, каталог средствами FSO ? 29.08.2007
  8. Как скопировать всю папку (т.е. вместе со всеми файлами) средствами FSO ? 30.06.2007
  9. Как переместить всю папку (т.е. вместе со всеми файлами) средствами FSO ? 30.06.2007
  10. Как переименовать закрытый файл средствами FSO ? 31.08.2007
  11. Как удалить один или несколько файлов, средствами FSO ? 04.08.2007
  12. Как удалить папку, включая все вложенные подпапки, средствами FSO ? 30.06.2007
  13. Как найти папку с самой ранней датой создания и удалить её ?
    Как удалить самую старую папку, средствами FSO ?
    NEW 04.02.2018
  14. Как создать путь, используя имеющийся путь и имя файла ? 26.08.2007
  15. Как извлечь имя файла из полного пути, средствами FSO ? 11.08.2007
  16. Как извлечь имя файла, не содержащее расширение, средствами FSO ? 14.10.2007
  17. Как получить расширение указанного файла, средствами FSO ? 07.10.2007
  18. Как определить версию exe, dll файлов, средствами FSO ? 11.08.2007
  19. Как определить является ли папка корневой ? 16.12.2007
  20. Как средствами FSO получить список всех вложенных подпапок и вывести их в виде отдельного списка ? 30.06.2007
  21. Как средствами FSO и с помощью элемента управления TreeView построить дерево, содержащее все вложенные подпапки ? 25.12.2010
  22. Как средствами FSO осуществить поиск всех папок с нужным именем ? 09.03.2011
  23. Как создать гиперссылки на все папки (включая вложенные) и файлы, причём, учитывая их иерархию ? 31.07.2016
  24. Как извлечь случайные файлы из указанной папки (включая вложенные) и программно создать гиперссылки на полученные файлы ? NEW 18.02.2018
  25. Как получить имена всех дисков компьютера ? 30.06.2007
  26. Как определить серийный номер и метку тома (имя диска) ? 08.06.2008
  27. Как определить наличие указанного диска средствами FSO ? 18.07.2007
  28. Как определить тип каждого из дисков, проверить доступен ли диск, а также получить полный размер диска и размер свободного места ? 30.06.2007
  29. Как получить содержимое текстового файла средствами FSO (без построчного чтения) ? 18.07.2007
  30. Как используя словарь получить список уникальных, т.е. неповторяющихся значений нужного диапазона ? 30.06.2007
    [1] [2]


  • Ответ :
  • iFileName = "C:\Archive\Report.xls"

    With CreateObject("Scripting.FileSystemObject")
         If .FileExists(iFileName) = True Then
            MsgBox "Файл : " & .GetFileName(iFileName) & " найден", , ""
         Else
            MsgBox "Файл : " & .GetFileName(iFileName) & " не найден", , ""
         End If
    End With
    Комментарий : Подобный способ определения существования файла имеет смысл, если Вы собираетесь использовать и другие возможности FSO, в противном случае, лучше обойтись встроенными средствами, например, функцией Dir() [FAQ44]
  • Ответ :
  • iPath = "C:\Archive\" ' "C:\Archive"

    With CreateObject("Scripting.FileSystemObject")
         If .FolderExists(iPath) = True Then
            MsgBox "Папка : " & iPath & " найдена", , ""
         Else
            MsgBox "Папка : " & iPath & " не найдена", , ""
         End If
    End With
    Комментарий : Подобный способ определения существования папки имеет смысл, если Вы собираетесь использовать и другие возможности FSO, в противном случае, лучше обойтись встроенными средствами, например, функцией Dir() [FAQ65]
  • Ответ :
  • iPath = "C:\Мои документы\Продажи\2007"

    iParentPath = CreateObject("Scripting.FileSystemObject").GetParentFolderName(iPath)

    MsgBox "Родительская папка : " & iParentPath, , ""
    Комментарий : Метод GetParentFolderName не проверяет наличие указанной папки и не вызывает ошибки в случае её отсутствия, он просто "отбрасывает" последнюю часть пути, в данном случае - последнюю папку.
  • Ответ :
  • iPath = Application.TemplatesPath

    iSize = CreateObject("Scripting.FileSystemObject").GetFolder(iPath).Size

    MsgBox "Общий размер всех файлов, включая подпапки, составляет : " & _
    vbNewLine & iSize & " байт", vbInformation + vbSystemModal, ""

  • Ответ :

    Вариант I.
  • iPath = "C:\Мои документы\Продажи"

    With CreateObject("Scripting.FileSystemObject")
         If Not .FolderExists(iPath) Then
            .CreateFolder iPath
         Else
            MsgBox "Создание папки невозможно, ввиду её наличия", , ""
         End If
    End With
    Вариант II.
    iPath = "C:\Мои документы"
    iNewPath = "Продажи"

    With CreateObject("Scripting.FileSystemObject")
         If .FolderExists(iPath) = True And _
            .FolderExists(iPath & "\" & iNewPath) = False Then
            .GetFolder(iPath).SubFolders.Add iNewPath
         Else
            MsgBox "Создание папки невозможно", vbExclamation, ""
         End If
    End With
    Примечание : Методы CreateFolder, Add, равно как и инструкция MkDir [FAQ152] позволяют создать только последнюю папку для указанного пути, но эта папка будет создана только при условии существования родительской папки.

    Если же родительская папка отсутствует, то Вы получите ошибку (вариант #1), которую можно избежать, если проверить наличие родительской папки (вариант #2), но для создания такой папки Вам придётся воспользоваться (на выбор) :

    - процедурой [My_MkDir]
    - процедурой [MkDirFSO]
    - функцией WinAPI [FAQ349]

    Комментарий : Подобный способ определения существования папки и её создания, имеет смысл, если Вы собираетесь использовать и другие возможности FSO, в противном случае, лучше обойтись встроенными средствами, т.е. инструкцией MkDir [FAQ152]
  • Ответ :
  • Private Sub MkDirFSO(iPath$) 'MS Excel 2000
        vPath = Split(iPath, "\"): iPath = vPath(0)

        With CreateObject("Scripting.FileSystemObject")
             If Not .DriveExists(iPath) Then Exit Sub '
             For iCount% = 1 To UBound(vPath)
                 iPath = iPath & "\" & vPath(iCount%)
                 If Not .FolderExists(iPath) Then .CreateFolder iPath
             Next
        End With
    End Sub
    Пример вызова вышеопубликованной авторской процедуры :
    Private Sub Call_MkDirFSO()
        MkDirFSO "C:\Мои документы\Архив\Документы\Счета" 'Or
        'MkDirFSO "C:\Мои документы\Архив\Документы\Счета\"
    End Sub
    Комментарий : Путь может содержать несуществующий диск, однако в этом случае папка создана, конечно же, не будет.
  • Ответ :
  • iOldName = "C:\Мои документы\Excel_files"
    iNewName = "Word_files"

    With CreateObject("Scripting.FileSystemObject")
         If .FolderExists(iOldName) = True Then
            .GetFolder(iOldName).Name = iNewName
         Else
            MsgBox "Переименование папки невозможно", , ""
         End If
    End With
    Комментарий : Подобный способ определения существования папки и её переименования, имеет смысл, если Вы собираетесь использовать и другие возможности FSO, в противном случае, лучше обойтись встроенными средствами, т.е. инструкцией Name [FAQ352]

    Примечание : Если папка с новым именем (iNewName) уже существует, то при переименовании Вы получите ошибку, которую можно избежать, если предварительно проверить также и наличие "новой" папки.
  • Ответ :

    Вариант I.
  • iSource = "C:\Sales"
    iDestination = "C:\Archive2006"

    On Error GoTo ErrHandler

    With CreateObject("Scripting.FileSystemObject")
         If .FolderExists(iSource) = True Then
            .CopyFolder iSource, iDestination ', True
         Else
            MsgBox "Копирование невозможно, ввиду отсутствия папки", , ""
         End If
    End With

    ErrHandler:
    If Err.Number <> 0 Then
       MsgBox Err.Description, vbCritical, ""
    End If
    Вариант II.
    iSource = "C:\Sales"
    iDestination = "C:\Archive2006"

    On Error GoTo ErrHandler

    With CreateObject("Scripting.FileSystemObject")
         If .FolderExists(iSource) = True Then
            .GetFolder(iSource).Copy iDestination 'True
         Else
            MsgBox "Копирование невозможно, ввиду отсутствия папки", , ""
         End If
    End With

    ErrHandler:
    If Err.Number <> 0 Then
       MsgBox Err.Description, vbCritical, ""
    End If
    Примечание :
  • Если в папке "Archive2006" уже имеется файл(ы) с аналогичным именем, то при копировании произойдёт его перезапись.
  • Если хотя бы один из перезаписываемых файлов имеет атрибут скрытый/только для чтения, то возникнет ошибка.
  • Путь к новой папке должен быть указан верно, т.е. если путь указан, например, как "C:\Office\Archive2006" то папка "C:\Office" должна реально существовать, в противном случае, также возникнет ошибка. Избежать этой ошибки можно, если проверить существование родительской папки, используя метод GetParentFolderName об'екта FileSystemObject (см. ниже)
  • With CreateObject("Scripting.FileSystemObject")
         If Application.And(Not .FolderExists(iDestination), _
            .FolderExists(.GetParentFolderName(iDestination)), _
            .FolderExists(iSource)) = True Then
            'Копирование или перемещение папки'
         Else
            'Сообщение о невозможности выполнения операции
         End If
    End With

  • Ответ :

    Вариант I.
  • iSource = "C:\Мои документы\Продажи"
    iDestination = "C:\Архив\Продажи_2006"

    On Error GoTo ErrHandler

    With CreateObject("Scripting.FileSystemObject")
         If .FolderExists(iSource) = True And _
            .FolderExists(iDestination) = False Then
            .MoveFolder iSource, iDestination
         Else
            MsgBox "Перемещение невозможно", , ""
         End If
    End With

    ErrHandler:
    If Err.Number <> 0 Then
       MsgBox Err.Description, vbCritical, ""
    End If
    Вариант II.
    iSource = "C:\Мои документы\Продажи"
    iDestination = "C:\Архив\Продажи_2006"

    On Error GoTo ErrHandler

    With CreateObject("Scripting.FileSystemObject")
         If .FolderExists(iSource) = True And _
            .FolderExists(iDestination) = False Then
            .GetFolder(iSource).Move iDestination
         Else
            MsgBox "Перемещение невозможно", , ""
         End If
    End With

    ErrHandler:
    If Err.Number <> 0 Then
       MsgBox Err.Description, vbCritical, ""
    End If
    Примечание :
  • Новый путь должен быть указан верно, т.е. если путь указан, например, как "C:\Архив\Продажи_2006" то папка "C:\Архив" должна реально существовать, в противном случае, также возникнет ошибка. Избежать этой ошибки можно, если проверить существование родительской папки, используя ещё и метод GetParentFolderName (см. выше)
  • При перемещении можно переименовать новую папку, просто указав новое имя (см. выше)
  • Ответ :
  • iOldName = "C:\Мои документы\Книга.xls"
    iNewName = "Продажи_2007.xls"

    With CreateObject("Scripting.FileSystemObject")
         If .FileExists(iOldName) = True Then
            .GetFile(iOldName).Name = iNewName
         Else
            MsgBox "Переименование файла невозможно", , ""
         End If
    End With
    Комментарий : Подобный способ определения существования файла и его переименования, имеет смысл, если Вы собираетесь использовать и другие возможности FSO, в противном случае, лучше обойтись встроенными средствами, т.е. инструкцией Name [FAQ68]

    Примечание : Если файл с новым именем (iNewName) уже существует, то при переименовании Вы получите ошибку, которую можно избежать, если предварительно проверить также и наличие "нового" файла. Кроме того, ошибка возникнет, если файл, который требуется переименовать, будет открыт.
  • Ответ :

    Вариант I.
  • iFileName = "C:\Excel\Workbook.xls"

    On Error GoTo ErrHandler

    With CreateObject("Scripting.FileSystemObject")
         If .FileExists(iFileName) = True Then
            .DeleteFile iFileName, True
         Else
            MsgBox "Удаление невозможно, ввиду отсутствия файла", , ""
         End If
    End With: Exit Sub 'Function

    ErrHandler: MsgBox Err.Description, vbCritical, ""
    Вариант II.
    iFileName = "C:\Word\Document.doc"

    On Error GoTo ErrHandler

    With CreateObject("Scripting.FileSystemObject")
         If .FileExists(iFileName) = True Then
            .GetFile(iFileName).Delete True
         Else
            MsgBox "Удаление невозможно, ввиду отсутствия файла", , ""
         End If
    End With: Exit Sub 'Function

    ErrHandler: MsgBox Err.Description, vbCritical, ""
    Примечание : Первый способ позволяет использовать символы подстановки и удалять сразу несколько файлов, так например, выполнив следующий код, Вы удалите все файлы с расширением .XLS из определённой(существующей) папки на диске C:
    iPath = "C:\Мусор\"
    CreateObject("Scripting.FileSystemObject").DeleteFile iPath & "*.XLS", True
    Комментарий : Подобный способ определения удаления файла имеет смысл, если Вы собираетесь использовать и другие возможности FSO, в противном случае, лучше воспользоваться инструкцией Kill [FAQ15]
  • Ответ :

    Вариант I.
  • iPath = "C:\Archive\" ' "C:\Archive"

    With CreateObject("Scripting.FileSystemObject")
         If .FolderExists(iPath) = True Then
            .DeleteFolder iPath, True
         Else
            MsgBox "Удаление невозможно, ввиду отсутствия папки", , ""
         End If
    End With
    Вариант II.
    iPath = "C:\Archive" ' "C:\Archive\"

    With CreateObject("Scripting.FileSystemObject")
         If .FolderExists(iPath) = True Then
            .GetFolder(iPath).Delete True
         Else
            MsgBox "Удаление невозможно, ввиду отсутствия папки", , ""
         End If
    End With

  • Ответ :

    Если перед нами поставлена задача - найти в указанном месте папку с самой ранней датой создания, а проще говоря, самую старую папку, а затем удалить её, то для этого можно использовать нижеопубликованный макрос DeleteOldFolder.
  • Private Sub DeleteOldFolder()
        Dim iPath$, oldPath$, iFolder As Object, oldDate As Date: oldDate = Now
        
        iPath = "C:\Мои документы\Архив2017" '\ Слэш может наличествовать, но не обязателен
        
        With CreateObject("Scripting.FileSystemObject")
             For Each iFolder In .GetFolder(iPath).SubFolders
                 If iFolder.DateCreated < oldDate Then
                    oldDate = iFolder.DateCreated
                    oldPath = iFolder.Path
                 End If
             Next
             If MsgBox("Вы уверены ? что хотите удалить папку «" & _
                oldPath & "»", vbYesNo, "") = vbYes Then
                .DeleteFolder oldPath, True ' .GetFolder(oldPath).Delete True
             End If
        End With
    End Sub
    Комментарий :
  • Если Вы укажите несуществующую папку, то получите ошибку, которую можно избежать, если непосредственно перед перебором папок, просто проверить наличие исходной папки [FAQ287]
  • Если же в исходной папке будут отсутствовать вложенные папки, то Вы также получите ошибку. Для того, чтобы её избежать, либо проверяйте наличие вложенных папок, например, использовав свойство Count об'екта SubFolders, либо просто проверяйте значение переменной oldPath. И если oldPath = "" , значит удалять нечего.
  • Private Sub DeleteOldFolder2v1()
        Dim iPath$, oldPath$, iFolder As Object, oldDate As Date: oldDate = Now
        
        iPath = "C:\Мои документы\Архив2017" '\ Слэш может наличествовать, но не обязателен
        
        With CreateObject("Scripting.FileSystemObject")
             If Not .FolderExists(iPath) Then Exit Sub
             
             For Each iFolder In .GetFolder(iPath).SubFolders
                 If iFolder.DateCreated < oldDate Then
                    oldDate = iFolder.DateCreated
                    oldPath = iFolder.Path
                 End If
             Next
             If oldPath = "" Then Exit Sub
             
             If MsgBox("Вы уверены ? что хотите удалить папку «" & _
                oldPath & "»", vbYesNo, "") = vbYes Then
                .DeleteFolder oldPath, True ' .GetFolder(oldPath).Delete True
             End If
        End With
    End Sub
    Private Sub DeleteOldFolder2v2()
        Dim iPath$, oldPath$, iFolder As Object, oldDate As Date: oldDate = Now
        
        iPath = "C:\Мои документы\Архив2017\" 'Слэш не обязателен
        
        With CreateObject("Scripting.FileSystemObject")
             If Not .FolderExists(iPath) Then Exit Sub         
             If .GetFolder(iPath).SubFolders.Count = 0 Then Exit Sub
             
             For Each iFolder In .GetFolder(iPath).SubFolders
                 If iFolder.DateCreated < oldDate Then
                    oldDate = iFolder.DateCreated
                    oldPath = iFolder.Path
                 End If
             Next
             If MsgBox("Вы уверены ? что хотите удалить папку «" & _
                oldPath & "»", vbYesNo, "") = vbYes Then
                .GetFolder(oldPath).Delete True ' .DeleteFolder oldPath, True
             End If
        End With
    End Sub

  • Ответ :
  • iPath = "D:\Папка с документами" 'Or "D:\Папка с документами\"
    iFile = "Продажи_2007.xls"       'Or "\Продажи_2007.xls"

    iNewPath = CreateObject("Scripting.FileSystemObject").BuildPath(iPath, iFile)

    MsgBox "Новый путь составлен : " & _
    vbNewLine & iNewPath, vbInformation + vbSystemModal, ""
    Примечание : Метод BuildPath не проверяет наличие указанной папки и файла и не вызывает ошибки в случае их отсутствия. Он только создаёт новую строку, содержащую указанный путь и имя файла, при этом, при необходимости, добавляется нужный или удаляется ненужный символ, который является разделителем папок \
  • Ответ :
  • Private Sub IsRootFolder()
        iPath$ = Application.TemplatesPath
        'iPath$ = "C:\Мои документы"           'тест2
        'iPath$ = "C:\Мои документы\Архив2007" 'тест3
        
        With CreateObject("Scripting.FileSystemObject")
             If Not .FolderExists(iPath$) Then
                MsgBox "Проверяемая папка изволит отсутствовать", , ""
                Exit Sub
             End If
             Dim iFolder As Object
             Set iFolder = .GetFolder(iPath$)
             If iFolder.IsRootFolder = True Then
                MsgBox "Папка " & iPath$ & " является корневой", , ""
             Else
                Do Until iFolder.IsRootFolder = True
                   Set iFolder = iFolder.ParentFolder
                Loop
                MsgBox "Папка " & iPath$ & vbNewLine & _
                "не является корневой, в отличии от " & iFolder.Path, , ""
             End If
        End With
    End Sub
    Примечание : Указанная папка должна реально существовать, в противном случае, возникнет ошибка, которую можно избежать, если предварительно проверить наличие папки.
  • Ответ : Скачать пример
  • Private Sub GetFolder(iMyFolder$, iRow&)
        Dim iSubFolder As Object
        For Each iSubFolder In CreateObject _
        ("Scripting.FileSystemObject").GetFolder(iMyFolder$).SubFolders
            With iSubFolder
                 iRow& = iRow& + 1
                 Cells(iRow&, 2).Value = .Name
                 Cells(iRow&, 3).Value = .Type
                 Cells(iRow&, 4).Value = .Size
                 Cells(iRow&, 1).Value = .ParentFolder
                 Cells(iRow&, 7).Value = .DateCreated '
                 Cells(iRow&, 8).Value = .DateLastModified
                 Cells(iRow&, 5).Value = .SubFolders.Count
                 Cells(iRow&, 6).Value = .Files.Count
                 If .SubFolders.Count <> 0 Then _
                    GetFolder .ParentFolder & "\" & .Name, iRow&
            End With
        Next
    End Sub

    Private Sub CreateFolderList()
        With Application
            .ScreenUpdating = False
            .Workbooks.Add xlWBATWorksheet
            GetFolder "C:\Мои документы", 1
            With Range("A1:H1") 'Range(Cells(1, 1), Cells(1, 8))
                 .Value = Array("Родительская папка", _
                 "Имя папки", "Тип", "Размер (байт)", _
                 "Кол-во папок", "Кол-во файлов", _
                 "Дата создания", "Дата последн. изменения")
                 .Font.Bold = True : .EntireColumn.AutoFit
                 .CurrentRegion.Sort _
                 Key1:=.Item(2, 1), Order1:=xlAscending, _
                 Key2:=.Item(2, 2), Order2:=xlAscending, _
                 Header:=xlYes, Orientation:=xlTopToBottom
            End With
            .ScreenUpdating = True
        End With
    End Sub
    Примечание : Указанная папка должна реально существовать, в противном случае, возникнет ошибка, поэтому, перед вызовом GetFolder() не забудьте проверить наличие нужной папки.
  • Ответ : Скачать пример

    Если Вы хотите создать дерево, которое будет отображать все вложенные подпапки, примерно такое как на этом скриншоте, то воспользуйтесь контролом Microsoft TreeView Control (более подробно о использовании дополнительных элементов управления можно прочитать здесь)
    Затем, найдите свойство Style и измените его значение на 6 - tvwTreelinesPlusMinusText или 7 - tvwTreelinesPlusMinusPictureText (если кроме текста необходима ещё и картинка), а значение свойства LineStyle установите как 1 - tvwRootLines
    Теперь, Вы можете использовать нижеприведённый код, естественно, указав свою родительскую папку
  • Private Sub UserForm_Initialize()
        Dim iFileSystemObj As Object, iFolder As Object    
        iPath$ = "C:\Мои документы"  ' Application.Path
        
        Set iFileSystemObj = CreateObject("Scripting.FileSystemObject")
        Set iFolder = iFileSystemObj.GetFolder(iPath$)
    
        Me.TreeView1.Nodes.Add , , iFolder.Path, iFolder.Name
    
        GetSubFolder iFolder
    End Sub
    
    Private Sub GetSubFolder(iFolder As Object)
        On Error Resume Next ' Windows XP
        For Each iFolder In iFolder.SubFolders
            Me.TreeView1.Nodes.Add _
            iFolder.ParentFolder.Path, 4, iFolder.Path, iFolder.Name
    
            GetSubFolder iFolder
        Next
    End Sub
    Примечание : Указанная папка должна реально существовать, в противном случае, возникнет ошибка, поэтому, перед вызовом GetFolder() не забудьте проверить наличие нужной папки.
  • Ответ : Скачать пример

    Если Вы хотите найти все папки с определённым именем (точное соответствие), либо папки, имена которых частично содержат искомый текст (к примеру, начинаются или заканчиваются на этот текст), то для подобного поиска можно также использовать об'ект FileSystemObject и оператор Like. Готовый пример поиска папок на выбранном Вами диске, можно скачать здесь
  • Ответ :

    Если, используя ячейки активного рабочего листа, необходимо создать гиперссылки, которые будут ссылаться на все вложенные папки и их файлы, то Вы можете использовать нижеприведённый код, естественно, указав свою родительскую папку. Обратите внимание на то, что все рюшечки и бантики, как-то выделения текста жирным и увеличение размера шрифта у папок, не являются обязательным условиям. И используются, только для визуального выделения папок.
  • Private Sub CreateHyperlinkToFolderItems()
        Dim iFileSystemObj As Object, iFolder As Object, iPath$
        iPath = Application.Path 'Укажите свою папку
        
        Set iFileSystemObj = CreateObject("Scripting.FileSystemObject")
        Set iFolder = iFileSystemObj.GetFolder(iPath)
    
        Cells.Clear
        With Cells(1, 1)
             .Hyperlinks.Add .Item(1), iFolder.Path
             .Font.Bold = True
             .Font.Size = .Font.Size + 2
        End With
        hIErarchyFolderItems iFolder, 1, 2
    End Sub
    
    Private Sub hIErarchyFolderItems(iFolder As Object, iRow&, iColumn&)
        'On Error Resume Next ' Windows XP
        
        Dim iFile As Object
        For Each iFile In iFolder.Files
            iRow = iRow + 1
            Cells(iRow, iColumn).Hyperlinks.Add Cells(iRow, iColumn), iFile.Path
        Next
        
        For Each iFolder In iFolder.SubFolders
            iRow = iRow + 1
            With Cells(iRow, iColumn)
                 .Hyperlinks.Add .Item(1), iFolder.Path
                 .Font.Bold = True
                 .Font.Size = .Font.Size + 1
            End With
            hIErarchyFolderItems iFolder, iRow, iColumn + 1
        Next
    End Sub
    Примечание : Указанная папка должна реально существовать, иначе, возникнет ошибка, поэтому, перед вызовом hIErarchyFolderItems() не забудьте проверить наличие нужной папки. Разумеется, это не касается Application.Path, т.к. эта папка 100% существует, однако она используется только в качестве примера.
  • Ответ :

    Если, используя ячейки активного рабочего листа, необходимо создать гиперссылки, которые будут ссылаться на случайно выбранные файлы, то Вы можете использовать нижеприведённый код, естественно, указав свою исходную папку. Обратите внимание на то, что количество случайно найденных файлов, указано непосредственно в макросе (переменная iCount)
  • Private Sub getRandomFiles()
        Dim iCollection As New Collection
        Dim iPath$, iRow&, iRnd&, iCount&: iCount = 3
        
        iPath = "C:\Мои документы\Рисунки" 'Укажите свою папку
        
        Range("A1") = iPath
        Range("A3").Resize(iCount).ClearContents
        
        With CreateObject("Scripting.FileSystemObject")
             If Not .FolderExists(iPath) Then
                MsgBox "Нет указанной папки", vbCritical, "": Exit Sub
             End If
             getAllFiles .GetFolder(iPath), iCollection
        End With
        
        Randomize 'Timer
        For iRow = 1 To Application.Min(iCount, iCollection.Count)
            iRnd = Int((iCollection.Count * Rnd) + 1)
            ActiveSheet.Hyperlinks.Add Range("A3")(iRow), iCollection(iRnd)
            iCollection.Remove iRnd
        Next
    End Sub
     
    Private Sub getAllFiles(iFolder As Object, iCollection As Collection)
        Dim iFile As Object
        For Each iFile In iFolder.Files
            iCollection.Add iFile.Path
        Next
        For Each iFolder In iFolder.SubFolders
            getAllFiles iFolder, iCollection
        Next
    End Sub
    Примечание : Обладатели Excel2007(или старше), для генерации случайного значения, могут использовать стандартную функцию рабочего листа СЛУЧМЕЖДУ (см. далее) Но в этом случае, они лишатся совместимости с более ранними версиями, т.е. Excel97-2003
    iRnd = Application.RandBetween(1, iCollection.Count)

  • Ответ :
  • Dim iDrive As Object
    For Each iDrive In CreateObject("Scripting.FileSystemObject").Drives 
        MsgBox "Имя диска : " & iDrive.DriveLetter, ,""
    Next

  • Ответ :

    Вариант I.
  • iDrive$ = "C" '"C:", "C:\"
    
    With CreateObject("Scripting.FileSystemObject").GetDrive(iDrive$)
         iVolumeName$ = .VolumeName
         iSerialNumber& = .SerialNumber
        
         MsgBox "Имя тома : " & iVolumeName$, , ""
         MsgBox "Серийный номер : " & iSerialNumber&, , ""
    End With
    Вариант II.
    iDrive$ = "C:\" '"C:", "C"
    
    With CreateObject("Scripting.FileSystemObject").Drives(CVar(iDrive$))
         iVolumeName$ = .VolumeName
         iSerialNumber& = .SerialNumber
        
         MsgBox "Имя тома : " & iVolumeName$, , ""
         MsgBox "Серийный номер : " & iSerialNumber&, , ""
    End With

  • Ответ :
  • iDrive = "A:" '"A" такой синтаксис также допустим, но в этом случае GetDriveName возвратит ""

    With CreateObject("Scripting.FileSystemObject")
         If .DriveExists(iDrive) = True Then
            MsgBox "Диск : " & .GetDriveName(iDrive) & " найден", , ""
         Else
            MsgBox "Диск : " & .GetDriveName(iDrive) & " не найден", , ""
         End If
    End With
    Примечание : DriveExists не проверяет наличие дискеты и т.п., поэтому, если проверка необходима для дальнейшей работы с носителем, то имеет смысл воспользоваться ещё и свойством IsReady об'екта Drive (см. следующий ответ)
  • Ответ :
  • Dim iDrive As Object
    For Each iDrive In CreateObject("Scripting.FileSystemObject").Drives
        Select Case iDrive.DriveType
            Case 0: iType$ = " : Неопознано"
            Case 1: iType$ = " : С'ёмный диск"
            Case 2: iType$ = " : Жёсткий диск"
            Case 3: iType$ = " : Сетевой диск"
            Case 4: iType$ = " : CD-ROM"
            Case 5: iType$ = " : RAM"
        End Select
        MsgBox iDrive.DriveLetter & iType$, , ""

        If iDrive.IsReady = True Then
           iTotalSize# = iDrive.TotalSize
           iFreeSpace# = iDrive.FreeSpace

           MsgBox "Полный размер диска : " & iTotalSize# & " байт", , ""
           MsgBox "Свободное место на диске : " & iFreeSpace# & " байт", , ""
        End If
    Next

  • Ответ :
  • iEXCEL_EXE$ = Application.Path & "\Excel.exe"

    MsgBox "Версия файла : " & _
    CreateObject("Scripting.FileSystemObject").GetFileVersion(iEXCEL_EXE$)

  • Ответ :
  • iFullName$ = "C:\PROGRAM FILES\OFFICE_97\EXCEL.EXE"

    iFileName$ = CreateObject("Scripting.FileSystemObject").GetFileName(iFullName$)

    MsgBox "Имя файла : " & iFileName$, vbExclamation, ""
    Комментарий : Метод GetFileName не проверяет наличие указанного файла и не вызывает ошибки в случае его отсутствия.
  • Ответ :
  • iFileName$ = ThisWorkbook.Name
    'ThisWorkbook.FullName '"C:\Мои документы\VBA_Excel.txt"

    iBaseName$ = CreateObject("Scripting.FileSystemObject").GetBaseName(iFileName$)

    MsgBox "Имя файла (без расширения) : " & iBaseName$, vbExclamation, ""
    Комментарий : Метод GetBaseName не проверяет наличие указанного файла и не вызывает ошибки в случае его отсутствия.
  • Ответ :
  • iFileName$ = ThisWorkbook.Name
    'ThisWorkbook.FullName '"C:\Мои документы\VBA_Excel.txt"

    iExtension$ = CreateObject("Scripting.FileSystemObject").GetExtensionName(iFileName$)

    MsgBox "Расширение файла : " & iExtension$, vbExclamation, ""
    Комментарий : Метод GetExtensionName не проверяет наличие указанного файла и не вызывает ошибки в случае его отсутствия, он просто возвращает все символы, которые находятся после последней точки. Если же расширение отсутствует, то возвращается пустая строка ""
  • Ответ :

    Вариант I.
  • iTextFile$ = "C:\WINDOWS\TIPS.TXT" '''

    With CreateObject("Scripting.FileSystemObject")
         If .FileExists(iTextFile$) = True Then
             With .OpenTextFile(iTextFile$)
                  iText$ = .ReadAll: .Close
             End With
             MsgBox iText$, , "Текстовый файл содержит"
         Else
             MsgBox "Текстовый файл изволит отсутствовать", vbCritical, ""
         End If
    End With
    Вариант II.
    iTextFile$ = "C:\WINDOWS\TIPS.TXT" '''

    With CreateObject("Scripting.FileSystemObject")
         If .FileExists(iTextFile$) = True Then
             With .GetFile(iTextFile$).OpenAsTextStream
                  iText$ = .ReadAll: .Close
             End With
             MsgBox iText$, , "Текстовый файл содержит"
         Else
             MsgBox "Текстовый файл изволит отсутствовать", vbCritical, ""
         End If
    End With
    Комментарий : Если текстовый файл будет "пустой", то Вы получите ошибку, которую можно избежать, если добавить проверку, использовав для этого свойство AtEndOfStream (см. далее)
    Private Sub Example_FSO_and_Dir()
         Dim iPath$, iFileName$, iText$
         Dim iFSO As Object, iTextFile As Object
         
         iPath = Environ("WinDir") & "\" 'Укажите свою папку
         iFileName = Dir(iPath & "*.txt")
         
         If iFileName <> "" Then
            Set iFSO = CreateObject("Scripting.FileSystemObject")
            
            Do
               iFileName = iPath & iFileName
               
               Set iTextFile = iFSO.OpenTextFile(iFileName)
               If Not iTextFile.AtEndOfStream Then
                  iText = iTextFile.ReadAll
                  MsgBox iText, , iFileName
               Else
                  MsgBox "Нет данных", vbCritical, iFileName
               End If
               
               iTextFile.Close: iFileName = Dir
            Loop Until iFileName = ""
         Else
            MsgBox "В папке " & iPath & " нет текстовых файлов", vbCritical, ""
         End If
    End Sub

  • Ответ : Скачать пример
  • Private Sub GetUniqueValue()
        With ThisWorkbook.Worksheets(1)
             Dim iSource As Range, iCell As Range
             Set iSource = .Range("A2:A100")
             With CreateObject("Scripting.Dictionary")
                  .CompareMode = 1 'TextCompare
                  For Each iCell In iSource
                      iText$ = CStr(iCell.Value)
                      If Not .Exists(iText$) Then .Add iText$, iText$
                  Next
                  iItems = Application.Transpose(.Items)
             End With
             With .Range("B2").Resize(UBound(iItems))
                  'Ячейки этого диапазона + рабочий лист
                  'не должны быть защищены, иначе возникнет ошибка
                  .EntireColumn.Clear 'использовать при необходимости
                  .Value = iItems
             End With
        End With
    End Sub
    Примечание : Если при составлении списка уникальных (т.е. неповторяющихся) значений, необходимо учитывать регистр, т.е. "текст" и "Текст" не должны считаться повторами, то просто уберите/закомментируйте строку .CompareMode = 1 'TextCompare или явно укажите метод сравнения, т.е. замените 1 'TextCompare на 0 'BinaryCompare
    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

    © 2004-2018 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff