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. Как используя Internet Explorer получить скриншот сайта (страницы) ? NEW 10.12.2017
30. Как имея 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

Ответ :

Если необходимо создать скриншот нужной web страницы, то можно попробовать такой вариант (см. далее) Если же использование SendKeys не даст положительного результата, то, видимо, придётся применить WinAPI

Private Sub XLScreenSite2()

With CreateObject("InternetExplorer.Application")

.Visible = True

.Navigate "http://www.msoffice-nm.ru"

Do

DoEvents

Loop Until .ReadyState = 4 'READYSTATE_COMPLETE = 4

Application.SendKeys "{1068}", True: DoEvents: .Quit

End With

With ActiveSheet.Pictures.Paste

.Left = [A1].Left: .Top = [A1].Top

'.Width = 200: .Height = 200

End With

End Sub

Примечание : Вы можете использовать и другие свойства IE, например, можно скрыть адресную строку AddressBar, строку состояния StatusBar и меню MenuBar, а также панель инструментов, содержащую кнопки Toolbar. Кроме того, можно установить нужную ширину Width и высоту Height, управлять месторасположением окна, используя свойства Top и Left, а при необходимости, запретить изменение размеров созданного окна Resizable и даже отобразить окно во весь экран FullScreen [FAQ414 ]

Ответ :

Если необходимо получить текст, имея в наличии только 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