|
|
|
Предположим, что у Вас в одной папке находятся офисные файлы, как правило, это .xls и .doc , созданные разными людьми и Вам необходимо, в зависимости от авторства, переместить эти файлы в соответствующие папки, т.е. все файлы, автором которых числится, к примеру, Иванов переместить в папку Иванов, и т.д. (см. скриншоты), то для этого можно воспользоваться нижеприведённым макросом.   Только не забудьте правильно указать папку - с обязательным завершающим слэшем \ , а также перечислить всех пользователей-авторов, причём так, как это указано в свойствах файла, т.е. если в фирме приветствуется панибратство и автором является, допустим, Андрей, то не нужно приписывать ему отчество, если же, напротив, всё слишком официозно, например, Орлова Наталья Сергеевна или Беляев И.И. , то не нужно оставлять только фамилию. |
Private Sub FilesMoveToAuthorFolder()
Dim iFolder As Object, iFolderItem As Object
Dim iFileName$, iNewFileName$, iPropertie$ '
Dim iCount%, iPath, iAuthor, iArrList 'As Variant
iPath = "C:\Мои документы\": iCount = Len(iPath) - 1
Set iFolder = CreateObject("Shell.Application").NameSpace(iPath)
If Not iFolder Is Nothing Then
iArrList = Array("Климов П.Ю.", "Беляев И.И.", "Орлова Н.С.")
For Each iAuthor In iArrList
If Dir(iPath & iAuthor, vbDirectory) = "" _
Then MkDir Path:=iPath & iAuthor
Next
'iPropertie = "Author" 'Win98/Me/2000
iPropertie = "DocAuthor" 'WinXP
For Each iFolderItem In iFolder.Items
If iFolderItem.IsFileSystem = True Then
iAuthor = iFolderItem.ExtendedProperty(iPropertie)
If Not IsError(Application.Match(iAuthor, iArrList, 0)) Then
iFileName = iFolderItem.Path
iNewFileName = Application.Replace( _
iFileName, 1, iCount, iPath & iAuthor)
Name iFileName As iNewFileName
End If
End If
Next
Else
MsgBox "Необходимо правильно указать папку", ,""
End If
End Sub |
| Комментарий : Данный макрос игнорирует скрытые файлы, кроме того, он перемещает любой офисный файл, вне зависимости от типа и если подобный расклад Вас не устраивает, то в Windows XP (Shell.dll version 6.0) появилась возможность фильтрации, которая и демонстрируется в следующем примере : |
Private Sub FilesMoveToAuthorFolder2() 'Windows XP
Dim iFolder As Object, iFolderItems As Object, iOfficeFile As Object
Dim iFileName$, iNewFileName$, iPropertie$, iCount%
Dim iPath, iAuthor, iArrList 'As Variant
iPath = "C:\Мои документы\": iCount = Len(iPath) + 1
Set iFolder = CreateObject("Shell.Application").NameSpace(iPath)
If Not iFolder Is Nothing Then
iArrList = Array("Климов П.Ю.", "Беляев И.И.", "Орлова Н.С.")
For Each iAuthor In iArrList
If Dir(iPath & iAuthor, vbDirectory) = "" _
Then MkDir Path:=iPath & iAuthor
Next
Set iFolderItems = iFolder.Items
iFolderItems.Filter 64 + 128, "*.xls"
'64 - не перебирать папки
'128 - учитывать скрытые файлы
'"*.xls" - оставить только файлы с расширением .xls
'"*.doc" - оставить только файлы с расширением .doc
'"*.xls;*.doc" - оставить только файлы с расширением .xls и .doc
'iPropertie = "Author" 'Win98/Me/2000
iPropertie = "DocAuthor" 'WinXP
For Each iOfficeFile In iFolderItems
iAuthor = iOfficeFile.ExtendedProperty(iPropertie)
If Not IsError(Application.Match(iAuthor, iArrList, 0)) Then
iFileName = iOfficeFile.Path
iNewFileName = Application.Replace( _
iFileName, iCount, 0, iAuthor & "\")
Name iFileName As iNewFileName
End If
Next
Else
MsgBox "Необходимо правильно указать папку", , ""
End If
End Sub |
|
Примечание : Если в папке, куда нам необходимо переместить
офисный файл, окажется файл с таким же именем, в таком случае
возникнет ошибка, которую можно избежать, если выбрать любой
из трёх нижеприведённых вариантов :
1) Удалить старый файл, если он не представляет больше интереса, проще говоря, не нужен. 2) Если старый файл всё таки необходим, то добавить к имени нового файла некий постфикс, т.е. изменить имя "Отчёт_январь.xls" , к примеру, на "Отчёт_январь(2).xls" 3) Или возложить обязанности по перемещению файла на Shell, т.е. просто использовать метод MoveHere об'екта Folder. Это, кстати, позволит ещё и избежать проверки на наличие файла и генерации нового имени, т.к. в случае наличия файла "Отчёт_январь.xls" в папке автоматически появится "Копия Отчёт_январь.xls" |
Private Sub FilesMoveToAuthorFolder3()
iPath = "C:\Мои документы\"
If Dir(iPath, vbDirectory) = "" Then
MsgBox "Необходимо правильно указать папку", , ""
Exit Sub
End If
iArrList = Array("Андрей", "Татьяна", "Сергей")
For Each iAuthor In iArrList
If Dir(iPath & iAuthor, vbDirectory) = "" _
Then MkDir Path:=iPath & iAuthor
Next
Dim iFolder As Object, iFolderItem As Object
Set iFolder = CreateObject("Shell.Application").NameSpace(iPath)
For Each iFolderItem In iFolder.Items
Application.StatusBar = iFolderItem.Path
If iFolderItem.IsFileSystem = True Then '
iAuthor = iFolderItem.ExtendedProperty("DocAuthor")
If Not IsError(Application.Match(iAuthor, iArrList, 0)) Then
iFolder.ParseName( _
iAuthor).GetFolder.MoveHere iFolderItem.Path, 8 + 16
End If
End If
Next
Application.StatusBar = False
End Sub |
| В принципе тоже самое, но добавлена фильтрация, аналогичная той, что была использована во втором примере. |
Private Sub FilesMoveToAuthorFolder4() 'Windows XP
iPath = "C:\Мои документы\"
If Dir(iPath, vbDirectory) = "" Then
MsgBox "Необходимо правильно указать папку", , ""
Exit Sub
End If
Dim iShell As Object, iFolderItems As Object, iOfficeFile As Object
Set iShell = CreateObject("Shell.Application")
Set iFolderItems = iShell.NameSpace(iPath).Items
iFolderItems.Filter 64 + 128 ', "*.xls;*.doc"
'64 - не перебирать папки
'128 - учитывать скрытые файлы
'"*.xls" - оставить только файлы с расширением .xls
iArrList = Array("Алексеев", "Никольский", "Шустриков")
'Фамилии перечислены в отсортированном виде (по возрастанию)
For Each iAuthor In iArrList
If Dir(iPath & iAuthor, vbDirectory) = "" _
Then iFolder.NewFolder iAuthor 'MkDir iPath & iAuthor
Next
For Each iOfficeFile In iFolderItems
iAuthor = iOfficeFile.ExtendedProperty("DocAuthor")
If IsNumeric(Application.Match(iAuthor, iArrList)) Then
iShell.NameSpace(iPath & _
iAuthor).MoveHere iOfficeFile.Path, 8 + 16
End If
Next
End Sub |
|
Совет : Если файлов, которые требуется рассортировать по
папкам, довольно много, то имеет смысл использовать либо статус-бар
(см. третий пример), либо прогресс-бар, благо количество элементов
в папке известно = iFolder.Items.Count или iFolderItems.Count
Если же самостоятельно составить список пользователей-авторов не представляется возможным, то эту задачу также можно решить с помощью VBA, например : |
Private Sub FilesMoveToAllAuthorFolder() 'Windows XP
Dim iFolder As Object, iFolderItems As Object
Dim iOfficeFile As Object, iArchive As Object
Dim iPath, iAuthor, iFileName ' As Variant
iPath = "C:\Мои документы\"
Set iFolder = _
CreateObject("Shell.Application").NameSpace(iPath)
If Not iFolder Is Nothing Then
Set iFolderItems = iFolder.Items
iFolderItems.Filter 64 + 128, "*.xls;*.doc"
If iFolderItems.Count > 0 Then
Set iArchive = CreateObject("Scripting.Dictionary")
iArchive.CompareMode = 1 'TextCompare
For Each iOfficeFile In iFolderItems
iAuthor = iOfficeFile.ExtendedProperty("DocAuthor")
If IsEmpty(iAuthor) = True _
Then iAuthor = "Автор_неизвестен"
If Not iArchive.Exists(iAuthor) Then _
iArchive.Add iAuthor, New Collection
iArchive(iAuthor).Add iOfficeFile.Path
Next
For Each iAuthor In iArchive.Keys
If Dir(iPath & iAuthor, vbDirectory) = "" _
Then MkDir Path:=iPath & iAuthor
For Each iFileName In iArchive(iAuthor)
iFolder.ParseName( _
iAuthor).GetFolder.MoveHere iFileName, 8 + 16
Next
Next
Else
MsgBox "Рабочие книги в папке отсутствуют", , ""
End If
Else
MsgBox "Необходимо правильно указать папку", , ""
End If
End Sub |
Private Sub FilesMoveToAllAuthorFolder2() 'Windows XP
Dim iFolder As Object, iFolderItems As Object
Dim iOfficeFile As Object, iAuthorFolder As Object
Dim iArchive As Object, iPath, iAuthor, iFileName 'As Variant
iPath = "C:\Мои документы\"
If Dir(iPath, vbDirectory) = "" Then
MsgBox "Необходимо правильно указать папку", , ""
Exit Sub
End If
Set iFolder = _
CreateObject("Shell.Application").NameSpace(iPath)
Set iFolderItems = iFolder.Items
iFolderItems.Filter 64 + 128, "*.xls;*.doc"
If iFolderItems.Count = 0 Then
MsgBox "Рабочие книги в папке отсутствуют", , ""
Exit Sub
End If
Set iArchive = CreateObject("Scripting.Dictionary")
iArchive.CompareMode = 1 'TextCompare
For Each iOfficeFile In iFolderItems
iAuthor = iOfficeFile.ExtendedProperty("DocAuthor")
If IsEmpty(iAuthor) = True _
Then iAuthor = "Автор_неизвестен"
If Not iArchive.Exists(iAuthor) Then _
iArchive.Add iAuthor, New Collection
iArchive(iAuthor).Add iOfficeFile.Path
Next
For Each iAuthor In iArchive.Keys
If Dir(iPath & iAuthor, vbDirectory) = "" Then _
iFolder.NewFolder iAuthor 'MkDir iPath & iAuthor
Set iAuthorFolder = iFolder.ParseName(iAuthor).GetFolder
For Each iFileName In iArchive(iAuthor)
iAuthorFolder.MoveHere iFileName, 8 + 16
Next
Next
End Sub |
Если же Вы принципиально не хотите использовать переменные, типа
Variant или просто предпочитаете раннее связывание, то в таком
случае обязательно добавьте ссылки на необходимые библиотеки
(см. далее) и воспользуйтесь нижеопубликованным макросом :
 |
Private Sub FilesMoveToAllAuthorFolder2v2() 'Windows XP
'Следующие библиотеки обязательно должны быть подключены :
'Microsoft Scripting RunTime
'Microsoft Shell Controls And Automation
Dim iShell As New Shell32.Shell
Dim iOfficeFile As Shell32.FolderItem
Dim iFolderItems As Shell32.FolderItems3
Dim iArchive As New Scripting.Dictionary
Dim iCountAuthor&, iCountFile&
Dim iAuthor$, iFileName$, iPath$
iPath = "C:\Мои документы\"
If Len(Dir(iPath, vbDirectory)) = 0 Then
MsgBox "Необходимо правильно указать папку", , ""
Exit Sub
End If
Set iFolderItems = iShell.NameSpace(iPath).Items
iFolderItems.Filter 64 + 128, "*.xls;*.doc"
If iFolderItems.Count = 0 Then
MsgBox "Рабочие книги в папке отсутствуют", , ""
Exit Sub
End If
iArchive.CompareMode = 1 'TextCompare
For Each iOfficeFile In iFolderItems
iAuthor = iOfficeFile.ExtendedProperty("DocAuthor")
If Len(iAuthor) = 0 Then iAuthor = "Автор_неизвестен"
If Not iArchive.Exists(iAuthor) Then _
iArchive.Add iAuthor, New Collection
iArchive(iAuthor).Add iOfficeFile.Path
Next
For iCountAuthor = 0 To iArchive.Count - 1
iAuthor = iArchive.Keys(iCountAuthor)
If Len(Dir(iPath & iAuthor,vbDirectory)) = 0 _
Then MkDir iPath & iAuthor
For iCountFile = 1 To iArchive(iAuthor).Count
iFileName = iArchive(iAuthor)(iCountFile)
iShell.NameSpace(iPath & iAuthor).MoveHere iFileName, 8 + 16
Next
Next
End Sub |
Private Sub FilesMoveToAllAuthorFolder2v3() 'Windows XP
'Следующие библиотеки обязательно должны быть подключены :
'Microsoft Scripting RunTime
'Microsoft Shell Controls And Automation
Dim iShell As New Shell32.Shell
Dim iOfficeFile As Shell32.FolderItem
Dim iFolderItems As Shell32.FolderItems3
Dim iArchive As New Scripting.Dictionary
Dim iCollection As Collection
Dim iCountAuthor&, iCountFile&
Dim iAuthor$, iFileName$, iPath$
iPath = "C:\Мои документы\"
If Len(Dir(iPath, vbDirectory)) = 0 Then
MsgBox "Необходимо правильно указать папку", , ""
Exit Sub
End If
Set iFolderItems = iShell.NameSpace(iPath).Items
iFolderItems.Filter 64 + 128, "*.xls;*.doc"
If iFolderItems.Count = 0 Then
MsgBox "Рабочие книги в папке отсутствуют", , ""
Exit Sub
End If
iArchive.CompareMode = 1 'TextCompare
For Each iOfficeFile In iFolderItems
iAuthor = iOfficeFile.ExtendedProperty("DocAuthor")
iAuthor = iPath & _
IIf(Len(iAuthor) = 0, "Автор_неизвестен", iAuthor)
If Not iArchive.Exists(iAuthor) Then _
iArchive.Add iAuthor, New Collection
iArchive(iAuthor).Add iOfficeFile.Path
Next
For iCountAuthor = 0 To iArchive.Count - 1
iAuthor = iArchive.Keys(iCountAuthor)
If Len(Dir(iAuthor, vbDirectory)) = 0 Then MkDir iAuthor
Set iCollection = iArchive(iAuthor)
For iCountFile = 1 To iCollection.Count
iFileName = iCollection(iCountFile)
iShell.NameSpace(iAuthor).MoveHere iFileName, 8 + 16
Next
Next
End Sub |
Автор : Климов Павел Юрьевич
|
Вопросы, связанные с этой темой| © 2004-2016 Климов П.Ю. Все права защищены. | WebDesign & Error's Klimoff |