Microsoft Excel:

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


Rambler's Top100


Counter CO.KZ


  1. Как используя об'ект Shell отобразить диалоговое окно, позволяющее выбрать нужную папку ? 13.01.2008
  2. Как используя об'ект Shell переименовать папку и закрытый файл ? 03.01.2008
  3. Как используя об'ект Shell получить доступ к специальной папке Windows ? 01.01.2008
  4. Как используя об'ект Shell получить список всех принтеров ? 22.10.2010
  5. Как используя об'ект Shell получить список всех файлов и папок, которые были удалены и находятся в корзине ? 01.12.2010
  6. Как используя об'ект Shell получить доступ к файлам и подпапкам нужной папки, а также получить основные сведения о этих об'ектах ? 01.01.2008
  7. Как используя об'ект Shell получить следующую информацию о нужном файле : имя, размер, тип, дата создания и последнего изменения ? 01.01.2008
  8. Как используя об'ект Shell получить список всех файлов и папок рабочего стола (а в случае нахождения ярлыка, узнать также местонахождение исходного файла/папки) ? 19.05.2014
  9. Как используя об'ект Shell получить список всех .XL файлов из папки Недавние документы ? 25.07.2016
  10. Как используя об'ект Shell узнать ширину и высоту изображения графического файла JPG, GIF, PNG, BMP ? 26.03.2012
  11. Как импортировать все(или только определённого типа) картинки из выбранной папки ? 01.11.2014
  12. Как используя об'ект Shell получить доступ к некоторым свойствам закрытого офисного документа ? 02.02.2011
  13. Как используя об'ект Shell получить тэги mp3 файла ? 01.03.2011
  14. Как рассортировать по папкам офисные документы, в зависимости от их авторства ? 02.02.2011
  15. Как используя об'ект Shell определить имя родительской папки ? 01.01.2008
  16. Как используя об'ект Shell получить длинное имя файла/папки из короткого ? 25.01.2011
  17. Как используя об'ект Shell распечатать текстовый, графический файл и т.д. ? 02.05.2016
  18. Как используя об'ект Shell создать ярлык ? 08.01.2008
  19. Как используя об'ект Shell создать URL ярлык ? 24.06.2014
  20. Как используя об'ект Shell узнать некоторые свойства папки ? 25.07.2016
  21. Как сделать так, чтобы после включения компьютера, Excel запускался автоматически ? 08.01.2008
  22. Как открыть в проводнике папку, где расположена нужная рабочая книга ? 01.01.2008
  23. Как закрыть все открытые в проводнике папки ? 10.10.2014
  24. Как свернуть или развернуть все окна, или же расположить их каскадом, сверху вниз или слева направо ? 01.01.2008
  25. Как отобразить стандартное диалоговое окно Windows, предназначенное для поиска файлов ? 01.01.2008
  26. Как отобразить стандартное диалоговое окно Windows, предназначенное для выключения или перезагрузки компьютера ? 03.01.2008
  27. Как используя Internet Explorer открыть нужную html страницу ? 04.01.2008
  28. Как используя Internet Explorer получить текст страницы, исходный код нужной страницы, а также все ссылки ? 15.04.2014
  29. Как имея html код получить текст ? NEW 01.10.2017

  • Ответ :
  • Set wshell = CreateObject("Shell.Application")
    'игнорируем ошибку, если нажата Cancel
    On Error Resume Next
    Set iPath = wshell.BrowseForFolder(&H0, " Выберите папку....", &H1, 17)
    If Not iPath Is Nothing Then
      'FolderPath = iPath.Self.Path 'вариант для WINNT
      FolderPath = iPath.Items.Item.Path 'универсальный вариант для WIN9х/NT
    Else
    'нажата Cancel
    End If
    Источник : Sources.ru | FAQ
  • Ответ :
  • iPath = "C:\Мои документы\"
    iFileName = "Годовой_отчёт.xls"
    
    iNewFileName = "Годовой_отчёт_2007" 'расширение отсутствует
    
    With CreateObject("Shell.Application")
         If Not .NameSpace(iPath & iFileName) Is Nothing Then
            .NameSpace(iPath).ParseName(iFileName).Name = iNewFileName
         Else
            MsgBox "Переименование файла невозможно", , ""
         End If
    End With
    Если файл, который требуется переименовать, существует, а файла с новым именем, наоборот, не существует, то переименование может выглядить следующим образом :
    CreateObject("Shell.Application").NameSpace("C:\Мои документы").ParseName("Годовой_отчёт.xls").Name = "Годовой_отчёт_2007"

    iOldName = "C:\Мои документы" '"C:\Мои документы\"
    iNewName = "Мои документы 2007"
    
    Dim iFolder As Object
    Set iFolder = CreateObject("Shell.Application").NameSpace(iOldName)
    
    If Not iFolder Is Nothing Then
       iFolder.Items.Item.Name = iNewName
    Else
       MsgBox "Переименование папки невозможно", , ""
    End If
    Если папка, которую требуется переименовать, существует, а папка с новым именем, наоборот, не существует, то переименование может выглядить следующим образом :
    CreateObject("Shell.Application").NameSpace("C:\Мои документы").Items.Item.Name = "Мои документы 2007"
    Комментарий : Подобный способ переименований, имеет смысл, если Вы собираетесь использовать и другие возможности об'екта Shell, в противном случае, лучше обойтись встроенными средствами, т.е. функцией Dir() [FAQ44] и инструкцией Name [FAQ68], [FAQ352]
  • Ответ :

    Пример получения доступа к папке "Мои документы", а также определение заголовка и полного пути к этой папке.
  • With CreateObject("Shell.Application").NameSpace(5)
         MsgBox _
         "Заголовок : " & .Title & vbCrLf & _
         "Путь : " & .Items.Item.Path, , ""
    End With
    Ниже приведён список констант, а также их значений, которые необходимо использовать для получения доступа к нужной папке, в том случае, если Вы используете позднее связывание (см. вышеопубликованный пример)

  • ssfDESKTOP '0
  • ssfPROGRAMS '2
  • ssfCONTROLS '3
  • ssfPRINTERS '4
  • ssfPERSONAL '5
  • ssfFAVORITES '6
  • ssfSTARTUP '7
  • ssfRECENT '8
  • ssfSENDTO '9
  • ssfBITBUCKET '10
  • ssfSTARTMENU '11
  • ssfDRIVES '17
  • ssfDESKTOPDIRECTORY '16
  • ssfNETWORK '18
  • ssfNETHOOD '19
  • ssfFONTS '20
  • ssfTEMPLATES '21
  • ssfCOMMONSTARTMENU '22
  • ssfCOMMONPROGRAMS '23
  • ssfCOMMONSTARTUP '24
  • ssfCOMMONDESKTOPDIR '25
  • ssfAPPDATA '26
  • ssfPRINTHOOD '27
  • ssfLOCALAPPDATA '28
  • ssfALTSTARTUP '29
  • ssfCOMMONALTSTARTUP '30
  • ssfCOMMONFAVORITES '31
  • ssfINTERNETCACHE '32
  • ssfCOOKIES '33
  • ssfHISTORY '34
  • ssfCOMMONAPPDATA '35
  • ssfWINDOWS '36
  • ssfSYSTEM '37
  • ssfPROGRAMFILES '38
  • ssfMYPICTURES '39
  • ssfPROFILE '40

  • Ответ : Скачать первый пример , Скачать второй пример

    Для того, чтобы получить коллекцию или массив, содержащий все принтеры, можно просто получить доступ к специальной папке Windows, а именно ssfPRINTERS
  • Dim iPrinters As New Collection ', iCount As Variant
    With CreateObject("Shell.Application").NameSpace(4).Items
         For iCount = 1 To .Count - 1
             iPrinters.Add .Item(iCount).Name 'Path
         Next
    End With
    With CreateObject("Shell.Application").NameSpace(4).Items
         ReDim iPrinters$(1 To .Count - 1)
         For iCount = 1 To .Count - 1
             iPrinters$(iCount) = .Item(iCount).Name 'Path
         Next
    End With
    Дополнение : скачав этот пример Вы сможете не только добраться до принтеров, но и сменить активный принтер, т.е. установить нужный принтер = принтером по умолчанию, а скачав другой пример Вы получите также информацию о состоянии принтера, количестве документов отправленных на печать и главное, это порт принтера.
  • Ответ : Скачать пример

    Для того, чтобы получить список всех файлов и папок, которые были удалены и находятся в корзине, а также некоторые свойства этих элементов, можно получить доступ к специальной папке Windows, т.е.
  • With CreateObject("Shell.Application").NameSpace(10)
         Dim iFolderItem As Object, iDate2 As Date
         For Each iFolderItem In .Items
             iFileName1$ = .GetDetailsOf(iFolderItem, 0)
             iPath$ = .GetDetailsOf(iFolderItem, 1)
             iDate1$ = .GetDetailsOf(iFolderItem, 2)
             iType1$ = .GetDetailsOf(iFolderItem, 3)
             iSize1$ = .GetDetailsOf(iFolderItem, 4)
             
             iFileName2$ = iFolderItem.Name
             iRecycledName$ = iFolderItem.Path
             iDate2 = iFolderItem.ModifyDate
             iType2$ = iFolderItem.Type
             iSize2& = iFolderItem.Size
         Next
    End With

  • Ответ :
  • With CreateObject("Shell.Application")
         Dim iFolder As Object, iFolderItem As Object
         Set iFolder = .NameSpace("C:\Windows\")
         If Not iFolder Is Nothing Then
            For Each iFolderItem In iFolder.Items
                With iFolderItem
                     iIsFolder = .IsFolder
                     iType = .Type
                     iName = .Name
                     iFullName = .Path
                     iSize = .Size
                     iModifyDate = .ModifyDate
                End With
            Next
         Else
            MsgBox "Указанная папка изволит отсутствовать", , ""
         End If
    End With
    Dim iFolder As Object, iFolderItem As Object
    Set iFolder = CreateObject("Shell.Application").NameSpace("C:\Windows")
    
    If Not iFolder Is Nothing Then
       For Each iFolderItem In iFolder.Items
           With iFolderItem
                iIsFolder = .IsFolder
                iType = .Type
                iName = .Name
                iFullName = .Path
                iSize = .Size
                iModifyDate = .ModifyDate
           End With
       Next
    Else
       MsgBox "Указанная папка изволит отсутствовать", , ""
    End If
    Примечание : Указанная папка не обязательно должна реально существовать, т.к. в случае её отсутствии, ошибки не возникнет, однако, если предварительно проверить наличие папки, то можно использовать немного более простой вариант.
    With CreateObject("Shell.Application").NameSpace(5)
         For Each iFolderItem In .Items
             With iFolderItem
                  'см. предыдущий пример
             End With
         Next
    End With

  • Ответ :
  • With CreateObject("Shell.Application")
         Dim iFolder As Object, iFile As Object
         Set iFolder = .NameSpace("C:\Windows")
         If Not iFolder Is Nothing Then
            With iFolder
                 On Error Resume Next
                 Set iFile = .ParseName("Notepad.exe")
                 If Not iFile Is Nothing Then
                    iFileName$ = .GetDetailsOf(iFile, 0)
                    iFileSize$ = .GetDetailsOf(iFile, 1)
                    iFileType$ = .GetDetailsOf(iFile, 2)
                    iDateModify$ = .GetDetailsOf(iFile, 3)
                    iDateCreate$ = .GetDetailsOf(iFile, 4) 'Win98, Me
                    'iDateCreate$ = .GetDetailsOf(iFile, 7) 'Win2000, XP
                    'Здесь можно использовать полученную информацию
                 Else
                    MsgBox "Можеть быть в следующий раз ...", , ""
                 End If
            End With
         Else
            MsgBox "Папка, а стало быть и файл, отсутствуют", , ""
         End If
    End With
    Dim iFolder As Object, iFile As Object
    Set iFolder = CreateObject("Shell.Application").NameSpace("C:\Windows\")
    
    If Not iFolder Is Nothing Then
       On Error Resume Next
       Set iFile = iFolder.ParseName("Notepad.exe")
       If Not iFile Is Nothing Then
          With iFolder        
               iFileName$ = .GetDetailsOf(iFile, 0)
               iFileSize$ = .GetDetailsOf(iFile, 1)
               iFileType$ = .GetDetailsOf(iFile, 2)
               iDateModify$ = .GetDetailsOf(iFile, 3)
               iDateCreate$ = .GetDetailsOf(iFile, 4) 'Win98, Me
               'iDateCreate$ = .GetDetailsOf(iFile, 7) 'Win2000, XP
               'Здесь можно использовать полученную информацию
          End With
       Else
          MsgBox "Можеть быть в следующий раз ...", , ""
       End If   
    Else
       MsgBox "Папка, а стало быть и файл, отсутствуют", , ""
    End If
    Примечание : Функция GetDetailsOf возвращает значение типа String (это особенно актуально для даты, и тем более размера файла, т.к. вместо 57344 эта функция возвратит "56 КБ") Если подобный расклад Вас не устраивает, то используйте свойство Size (см. предыдущий вопрос)
  • Ответ :

    Для того, чтобы получить список всех файлов и папок, которые находятся на рабочем столе, а также узнать некоторые свойства этих элементов, достаточно получить доступ к специальной папке Windows, т.е. просто воспользоваться [FAQ402] указав значение нужной константы - 0 (если речь идёт о позднем связывании) или саму константу - ssfDESKTOP (если Вы предпочитаете использовать раннее связывание, что, кстати, потребует небольшого изменения исходника)

    Примеров перебора всех элементов папки уже опубликовано достаточно, поэтому в этом совете, будет код получения массива, содержащего информацию о всех элементах Рабочего Стола, включая исходное месторасположение файлов/папок, чьи ярлыки будут найдены на десктопе. А в качестве бонуса, заполнение элемента управления ListBox (без цикла) и программная установка нужного количества столбцов (два способа)
  • Private Sub UserForm_Initialize()
         With CreateObject("Shell.Application").NameSpace(0).Items
              ReDim iGetDetails$(0 To .Count - 1, 0 To 5)
              For iCount = 0 To .Count - 1
                  With .Item(iCount)
                  iGetDetails(iCount, 0) = .Name
                  iGetDetails(iCount, 1) = .IsFolder
                  iGetDetails(iCount, 2) = .IsLink
                  iGetDetails(iCount, 3) = .IsFileSystem
                  iGetDetails(iCount, 4) = .Type
                  If .IsLink Then iGetDetails(iCount, 5) = .GetLink.Path
                  End With
              Next
         End With
         With Me.ListBox1
              .ColumnCount = -1 'UBound(iGetDetails, 2) + 1
              .List = iGetDetails
         End With
    End Sub

  • Ответ :

    Для того, чтобы получить список всех .XL книг из скрытой папки Недавние документы, достаточно получить доступ к специальной папке Windows, т.е. просто воспользоваться [FAQ402] указав значение нужной константы - 8 (если речь идёт о позднем связывании) или саму константу - ssfRECENT (если Вы предпочитаете использовать раннее связывание, что, кстати, потребует небольшого изменения исходника) A затем, просто перебрать все элементы этой папки, и оставить только файлы с расширением .xls , .xla , .xlt
  • Private Sub CreateList_RecentXLFiles()
        Dim iShell As Object, iFolder As Object, iFile As Object
        
        Set iShell = CreateObject("Shell.Application")
        Set iFolder = iShell.NameSpace(8)
        
        Application.ScreenUpdating = False
        Workbooks.Add xlWBATWorksheet
    
        For Each iFile In iFolder.Items
            iFileName$ = iFile.GetLink.Path
            If UCase(iFileName$) Like "*.XL?" Then 'Like "*.XL*"
               iRow& = iRow& + 1
               Cells(iRow&, 1) = iFileName$ 'iFile.Path
               Cells(iRow&, 2) = iFile.GetLink.WorkingDirectory
               Cells(iRow&, 3) = iFile.ModifyDate
            End If
        Next
    
        Columns("A:C").AutoFit
        Application.ScreenUpdating = True
    End Sub
    Комментарий : Обратите внимание на то, что наличие книги в полученном списке, вовсе не означает её наличие в указанной папке, т.к. она(книга) вполне могла быть перемещена или даже удалена.

    Совет :
  • Если хотите получить список всех недавно открытых документов, то уберите единственную проверку.
  • А если Вы являетесь обладателем Excel2007 и хотите, чтобы в список попали также файлы с расширением .xlsx , .xlsm , .xlsb и т.д., то вместо символа подстановки ? используйте *
  • Ответ :

    Для того, чтобы определить ширину (Width) и высоту (Height) изображения графического файла .JPG, .GIF, .PNG, .BMP и т.д., можно использовать следующий вариант, естественно, указав нужную папку (обязательно с завершающем слэшем) и файл.

    Примечание : Обратите внимание на то, что минимально допустимая версия ОС это Windows XP, т.к. в более ранних версиях, функция .ExtendedProperty("Dimensions") возвращает ""
  • Private Sub getPictureSize()
        Dim iPath$, iFileName$, iWidth%, iHeight%
        Dim iFolder As Object, iFile As Object, tempArr 'As Variant
        
        iPath = "C:\Мои документы\"
        iFileName = "Мой_рисунок.gif"
    
        Set iFolder = _
        CreateObject("Shell.Application").NameSpace((iPath))
        
        If Not iFolder Is Nothing Then
           On Error Resume Next
           Set iFile = iFolder.ParseName(iFileName)
           If Not iFile Is Nothing Then
              tempArr = Split(Replace( _
              iFile.ExtendedProperty("Dimensions"), "?", ""), "x")
              iWidth = Val(tempArr(0)): iHeight = Val(tempArr(1))
    
              MsgBox _
              "Ширина : " & iWidth & vbCrlf & _
              "Высота : " & iHeight, vbInformation, ""
           Else
              MsgBox "Файл не найден", vbCritical, ""
           End If
        Else
           MsgBox "Папка не найдена", vbCritical, ""
        End If
    End Sub
    Private Sub getPictureSize2()
        Dim iPath$, iFileName$, iPictureSize$, iWidth%, iHeight%
        Dim iShell As Object, iFolder As Object, iFile As Object
    
        iPath = "C:\Мои документы\Мои рисунки\"
        iFileName = "Кот Васька.jpg"
    
        If Dir(iPath & iFileName) <> "" Then
           Set iShell = CreateObject("Shell.Application")
           Set iFolder = iShell.NameSpace(CVar(iPath))
           Set iFile = iFolder.ParseName(iFileName)
    
           iPictureSize = iFile.ExtendedProperty("Dimensions")
           iPictureSize = Replace(iPictureSize, "?", "")
           iWidth = Val(iPictureSize)
           iHeight = Val(Mid(iPictureSize, InStr(iPictureSize, "x") + 1))
    
           MsgBox _
           "Ширина : " & iWidth & vbCrlf & _
           "Высота : " & iHeight, vbInformation, ""
        Else
           MsgBox "Указанный файл изволит отсутствовать", vbCritical, ""
        End If
    End Sub

    Обратите внимание на то, что наличествует ещё один вариант применения метода ExtendedProperty. Более подробную информацию об этом способе, можно найти на официальном сайте, а пример можно лицезреть ниже, только не забудьте указать свою папку и графический файл.
    Private Sub getPictureSize3()
        Dim iFolder As Object, iFile As Object
        Dim iPath As Variant, iFileName As Variant, iWidth%, iHeight%
    
        iPath = "C:\Мои документы\Мои рисунки"
        iFileName = "Кот Васька2.jpg"
    
        If Dir(iPath & "\" & iFileName) <> "" Then
           Set iFolder = CreateObject("Shell.Application").NameSpace(iPath)
           Set iFile = iFolder.ParseName(iFileName)
    
           iWidth = iFile.ExtendedProperty("{6444048F-4C8B-11D1-8B70-080036B11A03} 3")
           iHeight = iFile.ExtendedProperty("{6444048F-4C8B-11D1-8B70-080036B11A03} 4")
    
           MsgBox _
           "Ширина : " & iWidth & vbCrLf & _
           "Высота : " & iHeight, vbInformation, ""
        Else
           MsgBox "Указанный файл изволит отсутствовать", vbCritical, ""
        End If
    End Sub
    И, разумеется, если Вы не собираетесь использовать об'ектные переменные iShell, iFolder и iFile, то можно обойтись и без них, т.е.
    Private Sub getPictureSize3v2()
        Dim iPath, iFileName, iWidth%, iHeight%
    
        iPath = "C:\Мои документы\Мои рисунки"
        iFileName = "Кот Васька2.jpg"
    
        If Dir(iPath & "\" & iFileName) <> "" Then
           With CreateObject("Shell.Application").NameSpace(iPath).ParseName(iFileName)
                iWidth = .ExtendedProperty("{6444048F-4C8B-11D1-8B70-080036B11A03} 3")
                iHeight = .ExtendedProperty("{6444048F-4C8B-11D1-8B70-080036B11A03} 4")
           End With
    
           MsgBox _
           "Ширина : " & iWidth & vbCrLf & _
           "Высота : " & iHeight, vbInformation, ""
        Else
           MsgBox "Указанный файл изволит отсутствовать", vbCritical, ""
        End If
    End Sub

  • Ответ :

    Для того, чтобы программно импортировать все графические файлы указанного типа из выбранной папки, и вставить их в нужный рабочий лист, достаточно использовать нижеопубликованный макрос ImportPicturesFromFolder

    Примечание : Обратите внимание на то, что минимально допустимая версия ОС это Windows XP
  • Private Sub ImportPicturesFromFolder() 'WinXP
        Dim iTop!, iLeft!, iCount&, iList As Worksheet
        Dim iFolder As Object, iFile As Object, iFiles As Object
    
        Set iFolder = CreateObject("Shell.Application"). _
        BrowseForFolder(&H0, " Выберите папку c графикой ...", &H1, 17)
    
        If Not iFolder Is Nothing Then
           Set iList = ThisWorkbook.Worksheets(1)
           iList.DrawingObjects.Delete
           
           iLeft = iList.[B2].Left
           iTop = iList.[B2].Top + 5
    
           Set iFiles = iFolder.Items
           iFiles.Filter 64 + 128, "*.bmp;*.gif;*.jpg;*.jpeg;*.tiff;*.png;*.emf;*.wmf"
          
           iCount = iFiles.Count
           [B1].Font.Bold = True
           [B1] = iFolder.Self.Path & " (найдено " & iCount & " картинок)"
    
           If iCount > 0 Then
              Application.ScreenUpdating = False
              For Each iFile In iFiles
                  With iList.Pictures.Insert(iFile.Path)
                       .Top = iTop: iTop = iTop + .Height + 5
                       .Left = iLeft
                  End With
              Next
              Application.ScreenUpdating = True
           End If
          
        Else
           MsgBox "Папка не выбрана", vbCritical, ""
        End If
    End Sub
    Примечание : при создании макроса были использованы следующие материалы - Диалог выбора папки

    Если же Вы используете Microsoft Excel 2000(или старше), то :
  • при импорте графики, можно сразу указывать месторасположение на листе
  • при желании, можно сохранить имя исходного файла, в примере для этого, используется замещающий текст (выделить рисунок, меню Формат, команда Рисунок и закладка Web)

    Кроме того, в обеих версиях макроса, Вы вправе изменить перечень графических файлов, ибо здесь указаны только наиболее часто используемые.
  • Private Sub ImportPicturesFromFolder2() 'WinXP/Excel2000
        Dim iPath$, iTop!, iLeft!, iCount&, iList As Worksheet
        Dim iFolder As Object, iFile As Object, iFiles As Object
    
        iPath = "C:\ООО Рога и копыта\Товар\Фото"
        Set iFolder = CreateObject("Shell.Application").NameSpace((iPath))
    
        If Not iFolder Is Nothing Then
           Set iList = ThisWorkbook.Worksheets(1)
           iList.DrawingObjects.Delete
    
           iTop = iList.[B2].Top: iLeft = iList.[B2].Left
    
           Set iFiles = iFolder.Items
           iFiles.Filter 64 + 128, "*.bmp;*.gif;*.jpg;*.jpeg;*.tiff;*.png;*.emf;*.wmf"
    
           iCount = iFiles.Count
           [B1].Font.Bold = True
           [B1] = iFiles.Item.Path & " (найдено " & iCount & " картинок)"
    
           If iCount > 0 Then
              Application.ScreenUpdating = False
              For Each iFile In iFiles
                  With iList.Shapes.AddPicture( _
                       iFile.Path, False, True, iLeft, iTop, -1, -1)
                       iTop = iTop + .Height + 5: .AlternativeText = iFile.Name
                  End With
              Next
              Application.ScreenUpdating = True
           End If
           
        Else
           MsgBox "Указанная папка не найдена", vbCritical, iPath
        End If
    End Sub

  • Ответ :

    Для того, чтобы получить доступ к некоторым свойствам закрытого офисного документа, а именно Автор, Название, Тема, Категория можно использовать нижеопубликованный макрос, естественно, указав полное имя своего файла и обратив внимание на различия в версиях OC.
  • Private Sub getFileProperties() 'Win2000
        Dim iAuthor$, iTitle$, iSubject$, iCategory$
        Dim iFileName$, iFolder As Object
    
        iFileName = "C:\Мои документы\Отчёт_о_продажах2009.xls"
    
        Set iFolder = _
        CreateObject("Shell.Application").NameSpace(CVar(iFileName))
    
        If Not iFolder Is Nothing Then
           With iFolder.Items.Item 'iFolder.Self
                iAuthor = .ExtendedProperty("Author")
                iTitle = .ExtendedProperty("Title")
                iSubject = .ExtendedProperty("Subject")
                iCategory = .ExtendedProperty("Category")
           End With
        Else
           MsgBox "Рабочая книга не найдена", , ""
        End If
    End Sub
    Private Sub getFileProperties2() 'WinXP
        Dim iAuthor$, iTitle$, iSubject$, iCategory$
        Dim iPath, iFileName 'As Variant
     
        iPath = "C:\Мои документы\"
        iFileName = "Отчёт_о_продажах2010.xls"
        
        If Dir(iPath & iFileName) <> "" Then
           With CreateObject("Shell.Application"). _
                NameSpace(iPath).ParseName(iFileName)
                iAuthor = .ExtendedProperty("DocAuthor")
                iTitle = .ExtendedProperty("DocTitle")
                iSubject = .ExtendedProperty("DocSubject")
                iCategory = .ExtendedProperty("DocCategory")
           End With
        Else
           MsgBox "Рабочая книга не найдена", , ""
        End If
    End Sub

  • Ответ :

    Если использование стандартных средств [FAQ180], по каким-то причинам невозможно или нежелательно, то для того, чтобы открыть в проводнике нужную папку, например, папку с текущей рабочей книгой, можно воспользоваться методами Explore, Open об'екта Shell
  • CreateObject("Shell.Application").Explore ThisWorkbook.Path

    CreateObject("Shell.Application").Explore "C:\Мои документы\"

  • Ответ :

    Для того, чтобы закрыть все папки, которые были открыты в проводнике, можно воспользоваться нижеопубликованным макросом CloseWinFolder. Если же Вам понадобится также закрыть все WEB странички, загруженные с помощью браузера Internet Explorer, то закомментируйте/удалите единственную проверку.
  • Private Sub CloseWinFolder()
        Dim iWin As Object
        For Each iWin In CreateObject("Shell.Application").Windows
            If TypeName(iWin.Document) <> "HTMLDocument" Then
               iWin.Quit 'MsgBox iWin.LocationURL
            End If
        Next
    End Sub
    Private Sub CloseWinFolder2()
        Dim iWin As Object
        For Each iWin In CreateObject("Shell.Application").Windows
            If TypeName(iWin.Document) Like "*Folder*" Then iWin.Quit
        Next
    End Sub

  • Ответ :
  • iPath = Application.TemplatesPath '"C:\Мои документы\Продажи\2007"

    iParentPath = CreateObject("Shell.Application").NameSpace(iPath).ParentFolder.Items.Item.Path

    MsgBox "Родительская папка : " & iParentPath, , ""
    Примечание : Указанная папка должна реально существовать, т.к. в случае её отсутствия, Вы получите ошибку, которую можно избежать, если предварительно проверить наличие папки, причём, это также можно осуществить с помощью об'екта Shell (см. предыдущие примеры)
  • Ответ :

    Для того, чтобы с помощью об'екта Shell, получить длинное имя файла/папки из короткого, достаточно воспользоваться нижеопубликованной функцией getLongPath
  • Private Function getLongPath$(iShortPath$) 'WinMe/Win2000
        Dim iFolderItem As Object
    
        Set iFolderItem = _
        CreateObject("Shell.Application").NameSpace(CVar(iShortPath))
        If Not iFolderItem Is Nothing Then
           getLongPath = iFolderItem.Items.Item.Path
        End If
    End Function
    Примечание : Данная функция возвращает полное имя файла или папки, только если они существуют, в противном же случае, функция возвратит пустую строку "" , но это можно изменить в соответствии с Вашими требованиями.

    Совет : Если необходимо получить длинное имя файла или папки из короткого, только с помощью VB функций, то смотрите [FAQ590] , если же допустимо использование WinAPI, то смотрите следующий совет [FAQ640]
  • Ответ :

    Для того, чтобы с помощью об'екта Shell распечатать текстовый файл, можно воспользоваться следующим вариантом :
  • Private Sub Shell_PrintTextFile()
        CreateObject("Shell.Application").ShellExecute _
        "C:\Мои документы\Баланс2009.txt", "", "", "Print", 0
    
        CreateObject("Shell.Application").ShellExecute _
        "Баланс2010.txt", "", "C:\Мои документы\", "Print", 0
    End Sub
    Примечание : Указанный файл должен реально существовать, т.к. в случае его отсутствия, Вы получите ошибку, которую можно избежать, если предварительно проверить наличие файла, причём, это также можно осуществить с помощью об'екта Shell (см. предыдущие примеры)

    Если же текстовый файл необходимо предварительно выбрать с помощью стандартного диалогового окна, то можно обойтись и без проверки, ибо маловероятно, что в интервале между его выбором и печатью, он будет удалён.
    Private Sub Shell_PrintTextFile2()
       Dim iFileName As Variant
       
       iFileName = Application.GetOpenFileName( _
       FileFilter:="Text Files (*.txt),*.txt", Title:="Выберите файл")   
       If iFileName <> False Then
          CreateObject("Shell.Application").ShellExecute iFileName, "", "", "Print", 0
       Else
          MsgBox "Для печати необходимо выбрать нужный файл", , ""
       End If
    End Sub
    Комментарий : Подобным образом можно отправить на печать и файлы других типов, в т.ч. и графические, правда для этого, они должны быть связаны с определённой программой.
  • Ответ :

    Пример создания ярлыка для текущей книги. Обратите внимание на то, что в данном примере, предполагается, что текущая книга уже была сохранена и речь идёт о руссифицированной версии Windows.
  • iPath = ThisWorkbook.Path & "\"
    iFileName = ThisWorkbook.Name

    CreateObject("Shell.Application").NameSpace(iPath).ParseName(iFileName).InvokeVerb "Создать &ярлык"

  • Ответ :

    Пример создания URL ярлыка, который будет находиться в папке Избранное и ссылаться на этот сайт
  • Private Sub Shell_CreateURLShortcut()
        Dim iFileName1$, iFileName2$, iPath$
        iFileName1 = "www.msoffice.nm.url"
        iFileName2 = "Microsoft Excel Вопросы и Ответы Советы Примеры.url"
        
        With CreateObject("Shell.Application").NameSpace(6)
             iPath = .Items.Item.Path & "\" '.Self.Path & "\"
             DeleteFile iPath & iFileName1: .CopyHere "http://www.msoffice.nm.ru"
             DeleteFile iPath & iFileName2: .ParseName(iFileName1).Name = iFileName2
        End With
    End Sub
    
    Private Sub DeleteFile(FileName$)
        If Dir(FileName) <> "" Then
           Kill PathName:=FileName
        End If
    End Sub
    Комментарий : Здесь можно найти аналогичный пример, который я и рекомендую использовать для решения поставленной задачи. Да, и не забывайте, что папку Избранное, гарантировано использует только браузер Internet Explorer.
  • Ответ :

    Для того, чтобы с помощью об'екта Shell, получить некоторые свойства папки, например, узнать показываются или нет скрытые файлы, или скрыты ли расширения для зарегистрированных файлов, можно использовать свойство GetSetting
  • Private Const SFVVO_SHOWALLOBJECTS = 1
    'Показывать скрытые файлы и папки
    Private Const SFVVO_SHOWEXTENSIONS = 2
    'Скрывать расширения для зарегистрированных файлов
    Private Const SFVVO_SHOWCOMPCOLOR = 8
    'Отображать сжатые или зашифрованные файлы NTFS другим цветом
    Private Const SFVVO_SHOWSYSFILES = 32
    'Скрывать защищённые системные файлы
    Private Const SFVVO_WIN95CLASSIC = 64
    'Use Windows 95 UI settings
    Private Const SFVVO_DOUBLECLICKINWEBVIEW = 128
    'Щелчки мышью - открывать двойным, а выделять одним щелчком
    Private Const SFVVO_DESKTOPHTML = 512
    'Is Desktop HTML enabled
    
    Private Sub Shell_GetSetting()
        If CreateObject("Shell.Application").GetSetting(SFVVO_SHOWCOMPCOLOR) = True Then
           MsgBox "Cжатые или зашифрованные файлы - выделены другим цветом"
        Else
           MsgBox "Cжатые или зашифрованные файлы не выделяются"
        End If
    End Sub
    
    Private Sub Shell_GetSetting2()
        Dim iShell As Object
        Set iShell = CreateObject("Shell.Application")
        
        If iShell.GetSetting(SFVVO_SHOWALLOBJECTS) = True Then
           MsgBox "Показывать скрытые файлы и папки"
        Else
           MsgBox "Не показывать скрытые файлы и папки"
        End If
    End Sub
    Комментарий : Дополнительные сведения, а также полный список настроек (правда, без перевода, пусть и частичного) можно найти на официальном сайте.
  • Ответ :

    Подобную задачу вполне можно решить и без использования макросов [FAQ], однако, если это действительно необходимо, то об'единив ответы на два предыдущих вопроса, можно получить следующий вариант :
  • Private Sub Excel_AutoExecute()
        With CreateObject("Shell.Application")
             With .NameSpace(Application.Path)
                  .ParseName("Excel.exe").InvokeVerb "Создать &ярлык"
                  .Application.NameSpace(7) _
                  .MoveHere .Items.Item("Ярлык для excel.lnk"), 16
             End With
        End With
    End Sub
    Комментарий : Здесь можно найти аналогичный пример, который я и рекомендую использовать для решения поставленной задачи.
  • Ответ :
  • With CreateObject("Shell.Application")
         .MinimizeAll '.ToggleDesktop
         .UndoMinimizeALL
    
         .CascadeWindows
         .TileHorizontally
         .TileVertically
    End With
    Примечание : Все вышеперечисленные методы используются исключительно для демонстрации, т.к. их последовательное применение (без использования других инструкций) не имеет особого смысла.
  • Ответ :
  • CreateObject("Shell.Application").FindFiles

  • Ответ :
  • CreateObject("Shell.Application").ShutDownWindows

  • Ответ :

    Если использование стандартных средств [FAQ412] нежелательно, например, из-за их особенностей, то открыть нужную html страницу, можно напрямую воспользовавшись InternetExplorer (конечно, если он установлен на Вашем компьютере)
  • With CreateObject("InternetExplorer.Application")
         .Navigate "http://www.msoffice.nm.ru"
         .Visible = True
    End With
    Примечание : Вы можете использовать и другие свойства IE, например, можно скрыть адресную строку AddressBar, строку состояния StatusBar и меню MenuBar, а также панель инструментов, содержащую кнопки Toolbar. Кроме того, можно установить нужную ширину Width и высоту Height, управлять месторасположением окна, используя свойства Top и Left, а при необходимости, запретить изменение размеров созданного окна Resizable и даже отобразить окно во весь экран FullScreen.
    With CreateObject("InternetExplorer.Application")
         .Navigate "http://www.msoffice.nm.ru"
         .MenuBar = False
         .Toolbar = False
         .Resizable = False
         .StatusBar = False
         .AddressBar = False
         '.FullScreen = True
         .Visible = True
    End With

  • Ответ :

    Если необходимо получить текст или html код нужной страницы, и/или же Вам нужно перебрать все ссылки, то для решения поставленной задачи, также можно воспользоваться InternetExplorer (конечно, если он установлен на Вашем компьютере)

    Обратите внимание на то, что в нижеопубликованном примере перебираются все ссылки, но в ячейки рабочего листа выводятся только те, что соответствуют "HyperText Transfer Protocol" Это сделано, разумеется, только для демонстрации дополнительных возможностей.

    Вариант I. (Позднее связывание)
  • Private Sub getInfoHTMLDoc()
        Dim iShellDocView As Object
        Dim iHTMLDoc As Object
        Dim iURLink  As Object
        Dim iSourceURL$, iHTMLText$, iLink$, iText$, iRow&
        
        iSourceURL = "http://www.avito.ru/novosibirsk/vakansii/it_internet_telekom"
        
        Set iShellDocView = CreateObject("InternetExplorer.Application")
        iShellDocView.Navigate iSourceURL
        
        While iShellDocView.ReadyState <> 4 ' iShellDocView.Busy
              DoEvents
        Wend
        
        Set iHTMLDoc = iShellDocView.Document
        iHTMLText = iHTMLDoc.Body.InnerHTML 'HTML код страницы
        'iHTMLText = iHTMLDoc.Body.InnerText 'просто текст страницы
        
        Workbooks.Add xlWBATWorksheet
        
        For Each iURLink In iHTMLDoc.Links
            iLink = iURLink.ToString
            iText = iURLink.InnerText
    
            If iURLink.Protocol = "http:" Then 'iLink Like "http:*"
               iRow = iRow + 1
               
               Cells(iRow, 1) = iText
               Cells(iRow, 2) = iLink
            End If
        Next
        
        iShellDocView.Quit
    End Sub
    Вариант II. (Ранее связывание)

    Перед использованием данного совета Вам необходимо, в редакторе VBA [ALT+F11], в меню Tools/Сервис выбрать команду References/Ссылки, в появившемся стандартном диалоговом окне найти и установить "флажок" напротив Microsoft Internet Controls (SHDOCVW.DLL) и нажать кнопку Ok.

    Затем, в модуле книги ThisWorkbook/ЭтаКнига, необходимо разместить следующий код, естественно, указав свою страничку и сохранив эти изменения. И теперь, после следующего открытия этой книги *, Вы сможете воспользоваться событием DocumentComplete для обработки загруженной страницы.

    * на самом деле, ждать следующего открытия книги, вовсе не обязательно, ибо достаточно просто выполнить процедуру=событие Workbook_Open
    Private WithEvents iShellDocView As InternetExplorer
    
    Private Sub Workbook_Open()
        Set iShellDocView = New InternetExplorer
        iShellDocView.Navigate "http://www.yandex.ru/"
    End Sub
    
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
        If Not iShellDocView Is Nothing Then iShellDocView.Quit
    End Sub
    
    Private Sub iShellDocView_DocumentComplete(ByVal pDisp As Object, URL As Variant)
        If iShellDocView.ReadyState = READYSTATE_COMPLETE Then
           MsgBox "Страница загружена полностью", , URL
        End If
    End Sub

  • Ответ :

    Если необходимо получить текст, имея в наличии только html код, то для решения поставленной задачи, также можно воспользоваться InternetExplorer (конечно, если он установлен на Вашем компьютере)

    Вариант I.
  • Private Sub HTMLCodeToText()
        Dim iHTMLText$, iText$
        iHTMLText = [A1] 'Здесь должен быть Ваш HTML код
        With CreateObject("InternetExplorer.Application")
             .Navigate "about:blank" '.Navigate ""
             .Document.Write iHTMLText
             iText = .Document.Body.InnerText
             .Quit
        End With
        MsgBox iText, , ""
    End Sub
    Вариант II.
    Private Sub HTMLCodeToText2()
        Dim iHTMLText$, iText$
        iHTMLText = [A1] 'Здесь должен быть Ваш HTML код
        With CreateObject("HTMLFile")
             .Write iHTMLText
             iText = .Body.InnerText
        End With
        MsgBox iText, , ""
    End Sub

    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

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