Microsoft Excel:

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


Rambler's Top100


Counter CO.KZ


  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. Как создать путь, используя имеющийся путь и имя файла ? 26.08.2007
  14. Как извлечь имя файла из полного пути, средствами FSO ? 11.08.2007
  15. Как извлечь имя файла, не содержащее расширение, средствами FSO ? 14.10.2007
  16. Как получить расширение указанного файла, средствами FSO ? 07.10.2007
  17. Как определить версию exe, dll файлов, средствами FSO ? 11.08.2007
  18. Как определить является ли папка корневой ? 16.12.2007
  19. Как средствами FSO получить список всех вложенных подпапок и вывести их в виде отдельного списка ? 30.06.2007
  20. Как средствами FSO и с помощью элемента управления TreeView построить дерево, содержащее все вложенные подпапки ? 25.12.2010
  21. Как средствами FSO осуществить поиск всех папок с нужным именем ? 09.03.2011
  22. Как создать гиперссылки на все папки (включая вложенные) и файлы, причём, учитывая их иерархию ? NEW 31.07.2016
  23. Как получить имена всех дисков компьютера ? 30.06.2007
  24. Как определить серийный номер и метку тома (имя диска) ? 08.06.2008
  25. Как определить наличие указанного диска средствами FSO ? 18.07.2007
  26. Как определить тип каждого из дисков, проверить доступен ли диск, а также получить полный размер диска и размер свободного места ? 30.06.2007
  27. Как получить содержимое текстового файла средствами FSO (без построчного чтения) ? 18.07.2007
  28. Как средствами WSH получить значение нужной записи из раздела в реестре Windows ? 28.10.2010
  29. Как средствами WSH получить список последних файлов и/или электронной почты, которые были использованы при создании гиперссылок ? NEW 15.05.2016
  30. Как средствами WSH вывести на экран диалоговое окно, которое автоматически скроется через указанное время ? 01.07.2007
  31. Как средствами WSH получить путь к текущему каталогу ? 06.01.2008
  32. Как средствами WSH получить путь к специальной папке Windows ? 01.07.2007
  33. Как средствами WSH получить значение переменной среды, а также получить список всех переменных OC ? 30.03.2011
  34. Как средствами WSH получить имя компьютера ? 01.07.2007
  35. Как средствами WSH получить имя пользователя ? 04.08.2007
  36. Как средствами WSH получить список всех принтеров ? 30.10.2010
  37. Как средствами WSH создать ярлык ? 17.07.2007
  38. Как средствами WSH создать URL ярлык ? 20.07.2007
  39. Как средствами WSH определить файл, на который указывает ярлык, а также узнать существует ли этот файл ? NEW 20.06.2016
  40. Как найти в определённой папке все ярлыки .lnk, а затем, проверить их корректность (WSH) ? NEW 20.06.2016
  41. Как средствами WSH запустить нужное приложение и дождаться его завершения ? 01.05.2008
  42. Как сделать так, чтобы после включения компьютера, Excel запускался автоматически ? 08.01.2008
  43. Как используя словарь получить список уникальных, т.е. неповторяющихся значений нужного диапазона ? 30.06.2007

  • Ответ :
  • 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

  • Ответ :
  • 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% существует, однако она используется только в качестве примера.
  • Ответ :
  • 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

  • Ответ : Скачать файл

    Для того, чтобы получить значение нужной записи из раздела в реестре Windows, можно воспользоваться методом RegRead, учитывая, что в случае неправильного указания раздела, Вы получите ошибку (пример получения шрифта, используемого в VBE прилагается)
  • iFontFace = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Software\Microsoft\VBA\Office\FontFace")

    MsgBox "В редакторе VBA используется шрифт : " & iFontFace

  • Ответ :
  • CreateObject("WScript.Shell").Popup _
    "Это окно скроется через пять секунд", 5, "Microsoft Excel", 48
    При необходимости, можно указать необходимый тип значка и кнопок, а также определить какая из кнопок была нажата, например :
    Select Case CreateObject("WScript.Shell").Popup( _
        "Вы хотите продолжить работу ?", 10, _
        "Сделайте свой выбор за 10 секунд", 3 + 32)
        Case 6: MsgBox "Вы выбрали Да", , ""
        Case 7: MsgBox "Вы выбрали Нет", , ""
        Case 2: MsgBox "Вы выбрали Отмена/Закрыть", , ""
        Case Else: MsgBox "Вы отказались от выбора", , ""
    End Select

  • Ответ :
  • iCurDir = CreateObject("WScript.Shell").CurrentDirectory
    Комментарий : Обратите внимание на то, что существует, как минимум, два способа определения текущего каталога, причём, используя только средства Excel.
  • Ответ :
  • For Each iFolder In CreateObject("WScript.Shell").SpecialFolders
        MsgBox "Путь : " & iFolder, vbExclamation, ""
    Next
    Ниже приведён список имён, позволяющих получить путь к нужной папке, а также пример получения пути к папке "Рабочий стол". Список составлен на основании материалов изложенных в MSDN : SpecialFolders Property

  • AllUsersDesktop
  • AllUsersStartMenu
  • AllUsersPrograms
  • AllUsersStartup
  • Desktop
  • Favorites
  • Fonts
  • MyDocuments
  • NetHood
  • PrintHood
  • Programs
  • Recent
  • SendTo
  • StartMenu
  • Startup
  • Templates
  • iPathDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")

  • Ответ :

    Для того, чтобы средствами WSH получить значение переменной среды можно использовать либо свойство Environment (вариант I), либо метод ExpandEnvironmentStrings (вариант II)

    Вариант I.
  • Dim iWshShell As Object
    Set iWshShell = CreateObject("WScript.Shell")

    iTemp = iWshShell.Environment.Item("TEMP")
    iOS = iWshShell.Environment("System")("OS") 'WinNT/2000/XP
    iProgramFile = iWshShell.Environment("Process")("ProgramFiles")
    Комментарий : Обратите внимание на то, что у свойства Environment есть необязательный аргумент Type, который, собственно, и позволяет указать необходимый тип, например, "Process", "System", "User", "Volatile". Если же Вы проигнорируете этот аргумент (см. самый первый пример), то в таком случае тип будет определяться исходя из версии Windows (в Win95/98/Me - "Process", а в WinNT/2000/XP - "System")

    Для получения списка всех доступных переменных среды Вашей операционной системы, можно воспользоваться нижеопубликованным макросом, только учтите, что пример предназначен для WinNT/2000/XP, т.к. согласно MSDN : Environment Property в Win95/98/Me единственно возможный тип, это "Process"
    Dim iWshShell As Object
    Set iWshShell = CreateObject("WScript.Shell")
    For Each iWshEnviron In Array("Process", "System", "User", "Volatile")
        For Each iVariable In iWshShell.Environment(iWshEnviron)
            iRow& = iRow& + 1
            Cells(iRow&, 1) = iWshEnviron
            Cells(iRow&, 2) = "'" & iVariable
        Next
    Next
    Вариант II.
    Dim iWshShell As Object
    Set iWshShell = CreateObject("WScript.Shell")

    iTemp = iWshShell.ExpandEnvironmentStrings("%TEMP%")
    iOS = iWshShell.ExpandEnvironmentStrings("%OS%")
    iProgramFile = iWshShell.ExpandEnvironmentStrings("%ProgramFiles%")
    Комментарий : Обратите внимание на то, имя переменной обязательно должно быть заключено между двумя % , если же Вы забудете добавить эти символы, то в результате просто получите имя переменной.
  • Ответ :
  • MsgBox "Имя компьютера : " & CreateObject("WScript.Network").ComputerName
    MsgBox "Имя компьютера : " & _
    CreateObject("WScript.Shell").Environment("Process")("ComputerName")

  • Ответ :
  • MsgBox "Имя пользователя : " & CreateObject("WScript.Network").UserName
    MsgBox "Имя пользователя : " & _
    CreateObject("WScript.Shell").Environment("Process")("UserName")

  • Ответ :

    Для того, чтобы получить следующие сведения (имя и порт) о всех принтерах можно воспользоваться следующим примером :
  • With CreateObject("WScript.Network").EnumPrinterConnections
         For i = 0 To .Length - 1 Step 2
             MsgBox _
             "Имя принтера : " & .Item(i) & vbNewLine & _
             "Порт принтера : " & .Item(i + 1), , ""
         Next
    End With
    Важно : Данный способ предназначен для WinXP, в предыдущих версиях он позволяет получить список только сетевых принтеров.

    Источник : Sources.ru | FAQ
  • Ответ :

    Пример создания ярлыка на рабочем столе - для Microsoft Excel
  • With CreateObject("WScript.Shell")
         With .CreateShortcut(.SpecialFolders("Desktop") & "\Excel.lnk")
              .TargetPath = Application.Path & "\EXCEL.EXE"
              .Description = "Проба пера" 'необязательно
              .Save
         End With
    End With

  • Ответ :

    Пример создания URL ярлыка, который будет находиться в папке Избранное и ссылаться на этот сайт
  • Private Sub WSH_CreateURLShortcut()
        With CreateObject("WScript.Shell")
             With .CreateShortcut(.SpecialFolders("Favorites") & _
             "\Microsoft Excel Вопросы и Ответы Советы Примеры.url")
                  .TargetPath = "http://www.msoffice.nm.ru"
                  .Save
             End With
        End With
    End Sub
    Комментарий : Обратите внимание на то, что папку Избранное, гарантировано использует только браузер Internet Explorer
  • Ответ :

    Пример того, как средствами WSH определить имя файла, на который указывает ярлык. А также узнать, не был ли этот файл удалён/перемещён/переименован.
  • Private Sub WSH_GetTargetFileName()
        Dim iFileName$
        iFileName = "C:\Мои документы\Ярлык.xls.lnk"
    
        iFileName = CreateObject("WScript.Shell").CreateShortcut(iFileName).TargetPath
        If Dir(iFileName) <> "" Then
           MsgBox iFileName, , "Местонахождение файла"
        Else
           MsgBox "Об'ект был удалён/переименован/перемещён", vbCritical , ""
        End If
    End Sub
    Комментарий : В данном примере, ярлык необходимо указывать реально существующий, однако, это может быть и URL ярлык.
  • Ответ :

    Пример того, как в указанной папке, можно найти все ярлыки .lnk, а затем, проверить не были ли удалены/перемещены/переименованы файлы, на который указывают найденные ярлыки.
  • Private Sub FindInvalidShortCut()
        Dim iPath$, iFileName$, iCount&
        Dim iCollection As New Collection
    
        iPath = "C:\Имя_папки_с_ярлыками\" 'Укажите свою папку
        iFileName = Dir(iPath & "*.lnk")
    
        Do Until iFileName = ""
           iCollection.Add iPath & iFileName
           iFileName = Dir
        Loop
        
        With CreateObject("WScript.Shell")
             For iCount = 1 To iCollection.Count
                 iFileName = .CreateShortcut(iCollection(iCount)).TargetPath
                 If Dir(iFileName) = "" Then
                    MsgBox iFileName, vbCritical, "Битый ярлык"
                 Else
                    MsgBox iFileName, vbInformation, "Нормально"
                 End If
             Next
        End With
    End Sub
    Private Sub FindInvalidShortCut2()
        Dim iPath$, iFileName As Variant
        Dim iCollection As New Collection
    
        iPath = "C:\Имя_папки_с_ярлыками\" 'Укажите свою папку
        iFileName = Dir(iPath & "*.lnk")
    
        If Len(iFileName) = 0 Then MsgBox _
        "Ни одного ярлыка не обнаружено", vbCritical, "": Exit Sub
    
        Do
             iCollection.Add iPath & iFileName
             iFileName = Dir
        Loop Until Len(iFileName) = 0 
        
        With CreateObject("WScript.Shell")
             For Each iFileName In iCollection
                 iFileName = .CreateShortcut(iFileName).TargetPath
                 If Len(Dir(iFileName)) = 0 Then
                    MsgBox iFileName, vbCritical, "Битый ярлык"
                 Else
                    MsgBox iFileName, vbInformation, "Нормально"
                 End If
             Next
        End With
    End Sub

  • Ответ :

    Пример запуска стандартного калькулятора Windows, активации окна, и отслеживание состояния запущенного приложения.
  • Private Sub WSH_ExecuteApp()    
        Dim iWshShell As Object, iWshExec As Object
        
        Set iWshShell = CreateObject("WScript.Shell")
        Set iWshExec = iWshShell.Exec("Calc.exe")
        
        iProcessID& = iWshExec.ProcessID
        If iProcessID& = 0 Then
           MsgBox "Не удалось выполнить планируемое", , ""
        Else
           iWshShell.AppActivate iProcessID&
           Do
                'iWshExec.Terminate
                'Если понадобится завершить работу с запущенным приложением
           Loop While iWshExec.Status = 0
           MsgBox "Вы закончили работу с калькулятором", , ""
        End If    
    End Sub
    Private Sub WSH_ExecuteApp2()
        CreateObject("WScript.Shell").Run "Calc.exe", 1, True
        
        MsgBox "Вы закончили работу с калькулятором", , ""
    End Sub

  • Ответ :

    Подобную задачу вполне можно решить и без использования макросов [], однако, если это действительно необходимо, то об'единив ответы на два предыдущих вопроса, можно получить :
  • Private Sub Excel_AutoExecute()
        With CreateObject("WScript.Shell")
             With .CreateShortcut(.SpecialFolders("StartUp") & "\Excel.lnk")
                  .TargetPath = Application.Path & "\EXCEL.EXE"
                  .Save
             End With
        End With
    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-2016 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff