Страницы: 1
RSS
Путь к папке через диалоговое окно (работа с папкой и ее подпапками).
 
Ребятки, добрый вечер!  
Вынужден обратиться к вам за помощью.    
При помощи поиска я нашел необходимый мне код (он в модуле прилагаемого файла). Склеить сложные макросы не под силу.  
 
Мне необходимо, чтобы путь который указывается в следующем виде  
 
Const FLDR = "C:\Users\Евгеша\Desktop\Макросы\" ' указать путь  
 
был заменен на возможность выбора нужной папки через ДИАЛОГОВОЕ ОКНО.  
 
Ниже привожу часть кода, о котором веду речь (автор господин Казанский http://www.planetaexcel.ru/forum.php?thread_id=39904&page_forum=1&allnum_forum=16&useraction=login):  
 
Sub Удаление_макросов()  
Const FLDR = "C:\Users\Евгеша\Desktop\Макросы\" ' указать путь  
Dim w, q  
If MsgBox("Внимание!!!" & vbLf & _  
"Будут удалены ВСЕ компоненты VBA (макросы, формы, пользовательские функции) из ВСЕХ файлов Excel в папке " _  
& FLDR & vbLf & "Продолжить?", vbCritical + vbYesNoCancel + vbDefaultButton2) <> vbYes Then Exit Sub  
Application.EnableEvents = False 'для запрещения макросов Workbook_Open в открываемых книгах  
w = Dir(FLDR & "*.xls*") 'фактически *.xls*  
Do While w <> ""  
With Workbooks.Open(FLDR & w)  
 
'ActiveWorkbook.CheckCompatibility = False ' отключает проверку совместимости при сохранении этой книги  
 
.Close DeleteAllVBA 'если компонентов VBA не было, закрыть без сохранения  
End With  
w = Dir  
Loop  
Application.EnableEvents = True  
End Sub  
 
Самый лучший вариант, если этот макрос будет работать не только с файлами, размещенными в этой папке, а и с файлами, которые находятся в подпапках.  
 
Прошу вашей помощи ...
 
А что с поиском?  http://yandex.ru/sitesearch?text=%E2%FB%E1%F0%E0%F2%FC+%EF%E0%EF%EA%F3&searchid=84804&web=0
 
With Application.FileDialog(msoFileDialogFolderPicker)  
      .Show  
Const FLDR = .SelectedItems(1)  
End With
 
Спасибо за скорый ответ, я заменил строку  
 
Const FLDR = "C:\Users\Евгеша\Desktop\Макросы\" ' указать путь  
 
на код предложенный вами, однако VBA ругается и выделяет ".SelectedItems"  
 
Уважаемый Юрий М, пробовал и поиском, уже голова не соображает ... все смешалось в винегрет, однако решить данную задачу у меня не получается ... но я стараюсь ... читаю вашу ссылку на поиск
 
Ну конечно же не Const FLDR :(  
Просто FLDR.  
Пробел прозевал и принял Const FLDR за одно слово (имя переменной).
 
А точнее  
FLDR = .SelectedItems(1) & "\"
 
Большое спасибо, теперь заработало !!  
 
Осталась вторая проблема, он не обрабатывает файлы в подпапках ... попробую использовать подсказку Юрия М ... читаю
 
:-)) Чуть меняем запрос:  http://yandex.ru/sitesearch?text=%D0%BF%D0%B5%D1%80%D0%B5%D0%B1%D1%80%D0%B0%D1%82%D1%8C+­%D0%BF%D0%B0%D0%BF%D0%BA%D0%B8+%D0%B8+%D0%BF%D0%BE%D0%B4%D0%­BF%D0%B0%D0%BF%D0%BA%D0%B8&searchid=84804&lr=22&web=0
 
Ребятки, продолжаю просить помощи ...  
Спасибо за переадресацию в поиск, мне удалось многое прочитать, однако решить свою задачу не по силам ... Ниже привожу мое произведение, понимаю, стыдно, но ...  
На сколько я понял перебор папок происходит, однако макрос не выполняет своего стратегического предназначения ...  
При чем перебор осуществляется почему-то в папке на уровень выше, нежели чем в папках которые содержаться внутри папки ... а может даже и несколько иначе ...  
Сложно понять ...  
Надеюсь на вашу помощь!  
 
То, над чем ломаю голову не первый день:  
 
Public k As Byte  
Public mmm As Byte  
Public zzz As Byte  
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _  
Optional ByVal SearchDeep As Long = 999) As Collection  
' Получает в качестве параметра путь к папке FolderPath,  
' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)  
' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).  
' Возвращает коллекцию, содержащую полные пути найденных файлов  
' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)  
 
Set FilenamesCollection = New Collection ' создаём пустую коллекцию  
Set FSO = CreateObject("Scripting.FileSystemObject") ' создаём экземпляр FileSystemObject  
GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск  
Set FSO = Nothing: Application.StatusBar = False ' очистка строки состояния Excel  
End Function  
 
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _  
ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)  
' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO  
' перебор папок осуществляется в том случае, если SearchDeep > 1  
' добавляет пути найденных файлов в коллекцию FileNamesColl  
On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)  
If Not curfold Is Nothing Then ' если удалось получить доступ к папке  
 
' раскомментируйте эту строку для вывода пути к просматриваемой  
' в текущий момент папке в строку состояния Excel  
' Application.StatusBar = "Поиск в папке: " & FolderPath  
 
For Each fil In curfold.Files ' перебираем все файлы в папке FolderPath  
 
If UCase(fil.Name) Like "*" & UCase(Mask) Then FileNamesColl.Add fil.Path  
 
'If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path  
Next  
SearchDeep = SearchDeep - 1 ' уменьшаем глубину поиска в подпапках  
If SearchDeep Then ' если надо искать глубже  
For Each sfol In curfold.SubFolders ' перебираем все подпапки в папке FolderPath  
GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep  
Next  
End If  
Set fil = Nothing: Set curfold = Nothing ' очищаем переменные  
End If  
End Function  
 
Function DeleteAllVBA() As Boolean  
'удаляет все компоненты VBA в текущей книге и возвращает True, если они были  
Dim i&, j&  
With ActiveWorkbook.VBProject  
For i = .VBComponents.Count To 1 Step -1  
If .VBComponents(i).Type = 100 Then 'vbext_ComponentType.vbext_ct_Document, т.е. модуль книги, листа  
With .VBComponents(i).CodeModule  
j = .CountOfLines - .CountOfDeclarationLines  
If j Then .DeleteLines 1, .CountOfLines: DeleteAllVBA = True  
End With  
Else 'остальные типы: модуль, модуль класса, форма  
.VBComponents.Remove .VBComponents(i): DeleteAllVBA = True  
End If  
Next  
End With  
End Function  
 
 
Sub Удаление_макросов_2()  
' Ищем на рабочем столе все файлы TXT, и выводим на лист список их имён.  
' Просматриваются папки с глубиной вложения не более трёх.  
Application.ScreenUpdating = False  
Dim coll As Collection, ПутьКПапке As String  
' получаем путь к папке РАБОЧИЙ СТОЛ  
'ПутьКПапке = "Y:\Otdel\1.ПОКУПКА\X-files\на списание\АСКУЭ\йОПТ\80020\На отправку\2010 год\08 август\с потеряшками" 'CreateObject("WScript.Shell").SpecialFolders("Desktop")  
With Application.FileDialog(msoFileDialogFolderPicker)  
.InitialFileName = Application.DefaultFilePath & "\"  
.Title = "Укажите папку с файлами"  
If .Show = False Then Exit Sub  
Folder = .SelectedItems.Item(1)  
End With  
ПутьКПапке = Folder  
 
' считываем в колекцию coll нужные имена файлов  
'Set coll = FilenamesCollection(ПутьКПапке, ".xml", 3) 'ВОТ В ЭТОМ МЕСТЕ И ПРОИСХОДИТ ЗАГВОЗДКА  
 
 
Dim w, q  
If MsgBox("Внимание!!!" & vbLf & _  
"Будут удалены ВСЕ компоненты VBA (макросы, формы, пользовательские функции) из ВСЕХ файлов Excel в папке " _  
& FLDR & vbLf & "Продолжить?", vbCritical + vbYesNoCancel + vbDefaultButton2) <> vbYes Then Exit Sub  
Application.EnableEvents = False 'для запрещения макросов Workbook_Open в открываемых книгах  
w = Dir(FLDR & "*.xls*") 'фактически *.xls*  
Do While w <> ""  
With Workbooks.Open(FLDR & w)  
 
ActiveWorkbook.CheckCompatibility = False ' отключает проверку совместимости при сохранении этой книги  
 
.Close DeleteAllVBA 'если компонентов VBA не было, закрыть без сохранения  
End With  
w = Dir  
Loop  
Application.EnableEvents = True  
End Sub
 
Прошу помочь хотя бы наводящими вопросами !?  
В каком направлении работать ??
 
Пример из книги Билла Джелена вам в помощь  
 
Поиск файлов, в имени которых встречается заданная строка,  
в указанной папке и ее подпапках. По результатам поиска  
создается список, в котором для каждого найденного файла  
выводится ссылка на файл, размер файла и дата его последнего изменения.  
Список помещается на рабочий лист "Результат поиска файлов".  
После выполнения макроса этот лист станет первым листом в рабочей книге.
 
Посмотрите еще здесь  
http://excelvba.ru/code/FilenamesCollection  
http://sql.ru/forum/actualthread.aspx?tid=456013  
Удачи!
 
Kuzmich, большое спасибо !!  
Изучаю ...
Страницы: 1
Наверх