С Новым годом! на дворе 9 января и голова плохо соображает Суть вопроса: в папке D:\картинки\ ну очень много картинок, есть и одинаковые, но .jpg .tif .png. нужно обнаружить одинаковые и удалить файлы .tif и .png если есть такой же .jpg Хотелось бы это макросом провернуть, ну или может кто подскажет где похожая тема обсуждалась, я что-то не нашёл. Спасибо
С Новым годом! на дворе 9 января и голова плохо соображает Суть вопроса: в папке D:\картинки\ ну очень много картинок, есть и одинаковые, но .jpg .tif .png. нужно обнаружить одинаковые и удалить файлы .tif и .png если есть такой же .jpg Хотелось бы это макросом провернуть, ну или может кто подскажет где похожая тема обсуждалась, я что-то не нашёл. СпасибоZamoK
[offtop]В нете полно различных киллеров дубликатов и чистильщиков для фото и пр. медиа - с какого боку вы хотите пристегнуть к этому XL?![/offtop]
[offtop]В нете полно различных киллеров дубликатов и чистильщиков для фото и пр. медиа - с какого боку вы хотите пристегнуть к этому XL?![/offtop]TimSha
ну как сказать с какого боку? Если мыслить более масштабно это могут быть не только картинки, а макрос потому что мне интересен алгоритм действия по конкретному условию работы с одним и тем же списком файлов, а это реальная задача и минимум объяснений, что хотелось бы получить в итоге. Вот как-то так.
ну как сказать с какого боку? Если мыслить более масштабно это могут быть не только картинки, а макрос потому что мне интересен алгоритм действия по конкретному условию работы с одним и тем же списком файлов, а это реальная задача и минимум объяснений, что хотелось бы получить в итоге. Вот как-то так.ZamoK
ZamoK, Все просто - перебор всех файлов в конкретном каталоге (или через DIR или Filesytem object) при этом в DIR можно сразу оставить фильтр *.JPEG. Далее берется имя и удаляется файл с таким именем но с расширением .tif и .png с отключением ошибки на эту операцию на случай если файла нет. ну тили с проверкой на то что он есть.
ZamoK, Все просто - перебор всех файлов в конкретном каталоге (или через DIR или Filesytem object) при этом в DIR можно сразу оставить фильтр *.JPEG. Далее берется имя и удаляется файл с таким именем но с расширением .tif и .png с отключением ошибки на эту операцию на случай если файла нет. ну тили с проверкой на то что он есть.bmv98rus
Замечательный Временно просто медведь , процентов на 20.
Далее берется имя и удаляется файл с таким именем но с расширением .tif и .png
Если критерий "одинаковости" именно в этом, то может быть. А вдруг, там жена сохранила фотку с именем Я.jpeg, муж сохранил я.tiff и сын - Я.png? Достаточено ли как критерий "одинаковости" имя файла?
Далее берется имя и удаляется файл с таким именем но с расширением .tif и .png
Если критерий "одинаковости" именно в этом, то может быть. А вдруг, там жена сохранила фотку с именем Я.jpeg, муж сохранил я.tiff и сын - Я.png? Достаточено ли как критерий "одинаковости" имя файла?anvg
Sub УБРАТЬ_ДУБЛИКАТЫ() On Error Resume Next Dim objCloseBook As Object Dim coll As Collection, folder$ Dim fPath$, fName$ Dim i& folder$ = "D:\Картинка" Set coll = FilenamesCollection(folder$, "*.*") ' получаем список файлов из папки n = coll.Count For i = 1 To coll.Count ' перебираем все элементы коллекции, содержащей пути к файлам
If ИмяФайла = fName & ".tif" Then MsgBox "КОПИЯ " & ИмяФайла Kill "D:\Работа\ЧКД\" & ИмяФайла End If If ИмяФайла = fName & ".png" Then MsgBox "КОПИЯ " & ИмяФайла Kill "D:\Картинка\" & ИмяФайла End If Next End Sub
[/vba]
попробовал вроде сработало, по грамотности написания поправьте, может что не так? Сработал мгновенно и плохо что удалил мимо мусорки, т.е. без возможности восстановить теперь репу чешу , а правильно ли отработал макрос? Нельзя работать 9 января..... Нельзя !....
Короче спасибо за помощь как-то так наверное да?
[vba]
Код
Sub УБРАТЬ_ДУБЛИКАТЫ() On Error Resume Next Dim objCloseBook As Object Dim coll As Collection, folder$ Dim fPath$, fName$ Dim i& folder$ = "D:\Картинка" Set coll = FilenamesCollection(folder$, "*.*") ' получаем список файлов из папки n = coll.Count For i = 1 To coll.Count ' перебираем все элементы коллекции, содержащей пути к файлам
If ИмяФайла = fName & ".tif" Then MsgBox "КОПИЯ " & ИмяФайла Kill "D:\Работа\ЧКД\" & ИмяФайла End If If ИмяФайла = fName & ".png" Then MsgBox "КОПИЯ " & ИмяФайла Kill "D:\Картинка\" & ИмяФайла End If Next End Sub
[/vba]
попробовал вроде сработало, по грамотности написания поправьте, может что не так? Сработал мгновенно и плохо что удалил мимо мусорки, т.е. без возможности восстановить теперь репу чешу , а правильно ли отработал макрос? Нельзя работать 9 января..... Нельзя !....ZamoK
Я не Гуру, но стремлюсь!
Сообщение отредактировал ZamoK - Вторник, 09.01.2018, 14:59
Sub УБРАТЬ_ДУБЛИКАТЫ() On Error Resume Next Dim objCloseBook As Object Dim coll As Collection, folder$ Dim fPath$, fName$ Dim i& 'открываем диалоговое окно выбора папки With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Выберите папку" .Show On Error Resume Next Err.Clear V = .SelectedItems(1) If Err.Number <> 0 Then MsgBox "Вы не выбрали папку!" Exit Sub End If End With folder$ = CStr(V)
Set coll = FilenamesCollection(folder$, "*.*") ' получаем список файлов из папки n = coll.Count For i = 1 To coll.Count ' перебираем все элементы коллекции, содержащей пути к файлам
If ИмяФайла = fName & ".tif" Then Kill folder$ & "\" & ИмяФайла End If If ИмяФайла = fName & ".png" Then Kill folder$ & "\" & ИмяФайла End If Next End Sub
[/vba]
В любом случае Нельзя работать 9 января..... Нельзя !....
Поправил так будет лучше:
[vba]
Код
Sub УБРАТЬ_ДУБЛИКАТЫ() On Error Resume Next Dim objCloseBook As Object Dim coll As Collection, folder$ Dim fPath$, fName$ Dim i& 'открываем диалоговое окно выбора папки With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Выберите папку" .Show On Error Resume Next Err.Clear V = .SelectedItems(1) If Err.Number <> 0 Then MsgBox "Вы не выбрали папку!" Exit Sub End If End With folder$ = CStr(V)
Set coll = FilenamesCollection(folder$, "*.*") ' получаем список файлов из папки n = coll.Count For i = 1 To coll.Count ' перебираем все элементы коллекции, содержащей пути к файлам
If ИмяФайла = fName & ".tif" Then Kill folder$ & "\" & ИмяФайла End If If ИмяФайла = fName & ".png" Then Kill folder$ & "\" & ИмяФайла End If Next End Sub
[/vba]
В любом случае Нельзя работать 9 января..... Нельзя !....ZamoK
Я не Гуру, но стремлюсь!
Сообщение отредактировал ZamoK - Вторник, 09.01.2018, 15:11
теперь репу чешу , а правильно ли отработал макрос?
Просто считайте что правильно :-) , берегите нервы. Но на будущее конечно надо при отладке удаление коментить. Лог писать ну и не удялять, а временно переносить.
anvg, Андрей, рад снова встретить тут. персональный ПК он и ест персональный, чтоб никого там ...... :-)
теперь репу чешу , а правильно ли отработал макрос?
Просто считайте что правильно :-) , берегите нервы. Но на будущее конечно надо при отладке удаление коментить. Лог писать ну и не удялять, а временно переносить.bmv98rus
Замечательный Временно просто медведь , процентов на 20.
Сообщение отредактировал bmv98rus - Вторник, 09.01.2018, 15:13
Set fso = CreateObject("Scripting.FileSystemObject") Set recyclebin = CreateObject("Shell.Application").Namespace(10)
For Each oFile In fso.GetFolder(sFolderPath).Files If oFile.DateLastModified < dDateDif And LCase(fso.GetExtensionName(oFile.Name)) = LCase(sExt) Then recyclebin.MoveHere(oFile.Path) WScript.Sleep 10 End If Next
Set fso = CreateObject("Scripting.FileSystemObject") Set recyclebin = CreateObject("Shell.Application").Namespace(10)
For Each oFile In fso.GetFolder(sFolderPath).Files If oFile.DateLastModified < dDateDif And LCase(fso.GetExtensionName(oFile.Name)) = LCase(sExt) Then recyclebin.MoveHere(oFile.Path) WScript.Sleep 10 End If Next
Sub example_03() 'msoFileDialogFolderPicker Dim Fold As String, f As String Dim colJpg As New Collection
With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Select the folder in which the files to be processed" .ButtonName = "Select": .AllowMultiSelect = False If .Show Then Fold = .SelectedItems(1) Else Exit Sub End With
If Right(Fold, 1) <> "\" Then Fold = Fold & "\" f = Dir(Fold & "*.*", vbNormal) Do While f <> "" 'нужно обнаружить одинаковые и удалить файлы .tif и .png если есть такой же .jpg If InStr(f, ".jpg") Then colJpg.Add f, Mid$(f, 1, InStrRev(f, ".") - 1) f = Dir() Loop
On Error Resume Next: Err.Clear f = Dir(Fold & "*.*", vbNormal) Do While f <> "" If InStr(f, ".jpg") = 0 Then colJpg.Add f, Mid$(f, 1, InStrRev(f, ".") - 1) If Err Then Kill Fold & "\" & f Err.Clear End If End If f = Dir() Loop End Sub
[/vba]
ZamoK, привет попробуйте так:
[vba]
Код
Option Explicit Option Compare Text '!!
Sub example_03() 'msoFileDialogFolderPicker Dim Fold As String, f As String Dim colJpg As New Collection
With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Select the folder in which the files to be processed" .ButtonName = "Select": .AllowMultiSelect = False If .Show Then Fold = .SelectedItems(1) Else Exit Sub End With
If Right(Fold, 1) <> "\" Then Fold = Fold & "\" f = Dir(Fold & "*.*", vbNormal) Do While f <> "" 'нужно обнаружить одинаковые и удалить файлы .tif и .png если есть такой же .jpg If InStr(f, ".jpg") Then colJpg.Add f, Mid$(f, 1, InStrRev(f, ".") - 1) f = Dir() Loop
On Error Resume Next: Err.Clear f = Dir(Fold & "*.*", vbNormal) Do While f <> "" If InStr(f, ".jpg") = 0 Then colJpg.Add f, Mid$(f, 1, InStrRev(f, ".") - 1) If Err Then Kill Fold & "\" & f Err.Clear End If End If f = Dir() Loop End Sub
Dim strFolder As String, collJPG As New Collection, collNotJPG As New Collection Dim strFileName As String Dim var, i As Long
With Application.FileDialog(msoFileDialogFolderPicker) If .Show = 0 Then Exit Sub End If strFolder = .SelectedItems(1) End With
strFileName = Dir(strFolder & "\*.jpg") Do While strFileName <> "" collJPG.Add Item:="", key:=Left(strFileName, InStrRev(strFileName, ".") - 1) strFileName = Dir() Loop If collJPG.Count = 0 Then MsgBox "Готово!", vbInformation Exit Sub End If
strFileName = Dir(strFolder & "\") Do While strFileName <> "" If LCase(strFileName) Like "*.tif" Or LCase(strFileName) Like "*.png" Then collNotJPG.Add Item:=strFolder & "\" & strFileName End If strFileName = Dir() Loop If collNotJPG.Count = 0 Then MsgBox "Готово!", vbInformation Exit Sub End If
On Error Resume Next For i = collNotJPG.Count To 1 Step -1 var = Mid(collNotJPG(i), InStrRev(collNotJPG(i), "\") + 1) var = Left(var, InStrRev(var, ".") - 1) If collJPG(var) = "" Then End If If Err.Number = 0 Then Kill collNotJPG(i) Else Err.Number = 0 End If Next i On Error GoTo 0
MsgBox "Готово!", vbInformation
End Sub
[/vba]
[vba]
Код
Sub Удалить_дубли_файлов()
Dim strFolder As String, collJPG As New Collection, collNotJPG As New Collection Dim strFileName As String Dim var, i As Long
With Application.FileDialog(msoFileDialogFolderPicker) If .Show = 0 Then Exit Sub End If strFolder = .SelectedItems(1) End With
strFileName = Dir(strFolder & "\*.jpg") Do While strFileName <> "" collJPG.Add Item:="", key:=Left(strFileName, InStrRev(strFileName, ".") - 1) strFileName = Dir() Loop If collJPG.Count = 0 Then MsgBox "Готово!", vbInformation Exit Sub End If
strFileName = Dir(strFolder & "\") Do While strFileName <> "" If LCase(strFileName) Like "*.tif" Or LCase(strFileName) Like "*.png" Then collNotJPG.Add Item:=strFolder & "\" & strFileName End If strFileName = Dir() Loop If collNotJPG.Count = 0 Then MsgBox "Готово!", vbInformation Exit Sub End If
On Error Resume Next For i = collNotJPG.Count To 1 Step -1 var = Mid(collNotJPG(i), InStrRev(collNotJPG(i), "\") + 1) var = Left(var, InStrRev(var, ".") - 1) If collJPG(var) = "" Then End If If Err.Number = 0 Then Kill collNotJPG(i) Else Err.Number = 0 End If Next i On Error GoTo 0
nilem, Karataev, огромное спасибо за предложенные варианты. оба варианта отлично справляются с задачей, жаль правда что в кодах нет комментариев и мне сложно определить, что конкретно выполняется в той или иной строке. Хочу отметить код предложенный nilem, он даже перевыполнил задачу т.к. нет фильтра по ".jpg", а он просто удаляет файлы с расширением .tif и .png если есть дублер другого расширения, это даже очень! были два файла .bmp и .tif он справился и оставил только .bmp Ещё раз спасибо!
nilem, Karataev, огромное спасибо за предложенные варианты. оба варианта отлично справляются с задачей, жаль правда что в кодах нет комментариев и мне сложно определить, что конкретно выполняется в той или иной строке. Хочу отметить код предложенный nilem, он даже перевыполнил задачу т.к. нет фильтра по ".jpg", а он просто удаляет файлы с расширением .tif и .png если есть дублер другого расширения, это даже очень! были два файла .bmp и .tif он справился и оставил только .bmp Ещё раз спасибо!ZamoK