[Petya V4sechkin]

DIMM2005
Можно сделать vbs-скрипт примерно такого содержания:

Код:

Dim FSO, FldN, Fls, Fl, DtN, FlN
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")

If WScript.Arguments.Count = 0 Then
  MsgBox "Не задано имя папки для распределения файлов по датам. ", vbExclamation, "Ошибка"
  WScript.Quit
End If

FldN = WScript.Arguments(0)
If Not FSO.FolderExists(FldN) Then
  MsgBox "Папка """ & FldN & """ не существует. ", vbExclamation, "Ошибка"
  WScript.Quit
End If

Set Fls = FSO.GetFolder(FldN).Files
For Each Fl In Fls
  DtN = FSO.BuildPath(FldN, GetDateName(Fl.DateLastModified))
  If Not FSO.FolderExists(DtN) Then FSO.CreateFolder DtN

  FlN = FSO.BuildPath(DtN, Fl.Name)
  If FSO.FileExists(FlN) Then FSO.DeleteFile FlN, True
  Fl.Move FlN
Next

MsgBox "Скрипт завершен. ", vbInformation, "Финиш"
WScript.Quit

Private Function GetDateName(Dt)
  Dim M, D

  M = Month(Dt)
  D = Day(Dt)
  If M < 10 Then M = "0" & M
  If D < 10 Then D = "0" & D

  GetDateName = Year(Dt) & "-" & M & "-" & D
End Function

Сохранить с расширением .vbs, например DTMove.vbs.
Формат вызова:
DTMove.vbs Имя_папки

P. S. С контролем ошибок не заморачивался, так что использовать аккуратно.

[DIMM2005]

Petya V4sechkin

Спасибо! Все работает, сортирует как надо. Вроде проверял, при разных условиях - все ок... Я как понял скрипт берет дату изменения файла, а не создания, что впринципе мне и нужно. (т.к. при копировании на комп, дата создания меняется, а дата изменения - нет).

Вот только маленький недочет. Скрипт заменяет одинаковые файлы (если имя совпадает и папка назначения). Хотя содержимое файла может быть разным. Я понимаю, в реальной жизни, такое врятли получится, но..... Можно как-то доработать скрипт, что если при сортировании, файл с таким именем уже существует, то переместить его в папку, например "Непонятное". Чтобы я потом посмотрел и лично все досортировал.

[Vadikan]

Petya V4sechkin
Благодарю!

[Petya V4sechkin]

Vadikan
Не за что ;)


DIMM2005

Вот только маленький недочет. Скрипт заменяет одинаковые файлы (если имя совпадает и папка назначения).

Тогда так (с запросом на перезапись):

Код:

Dim FSO, FldN, Fls, Fl, D, DtN, FlN
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")

If WScript.Arguments.Count = 0 Then
  MsgBox "Не задано имя папки для распределения файлов по датам. ", vbExclamation, "Ошибка"
  WScript.Quit
End If

FldN = WScript.Arguments(0)
If Not FSO.FolderExists(FldN) Then
  MsgBox "Папка """ & FldN & """ не существует. ", vbExclamation, "Ошибка"
  WScript.Quit
End If

Set Fls = FSO.GetFolder(FldN).Files
For Each Fl In Fls
  D = GetDateName(Fl.DateLastModified)
  DtN = FSO.BuildPath(FldN, D)
  If Not FSO.FolderExists(DtN) Then FSO.CreateFolder DtN

  FlN = FSO.BuildPath(DtN, Fl.Name)
  If FSO.FileExists(FlN) Then
    If MsgBox("Файл """ & Fl.Name & """ уже существует в папке """ & D & """. " & vbCr & "Перезаписать?", vbQuestion + vbOKCancel, "Внимание") = vbOK Then
      FSO.DeleteFile FlN, True
      Fl.Move FlN
    End If
  Else
    Fl.Move FlN
  End If
Next

MsgBox "Скрипт завершен. ", vbInformation, "Финиш"
WScript.Quit

Private Function GetDateName(Dt)
  Dim M, D

  M = Month(Dt)
  D = Day(Dt)
  If M < 10 Then M = "0" & M
  If D < 10 Then D = "0" & D

  GetDateName = Year(Dt) & "-" & M & "-" & D
End Function

[DIMM2005]

Спасибо! Лучше я бы и не мог придумать.

Petya V4sechkin Можешь толкать как комерческий продукт Ведь честно, в Инете ничего подобного не нашел. Только вот "фомат вызова: DTMove.vbs Имя_папки" не все могут понять Сегодня наверно тему в сети создам, многим этот скрипт понравится - авторство конечно за тобой Это я упомяну...

[Petya V4sechkin]

DIMM2005

Можешь толкать как комерческий продукт :)

Хе-хе, в продукте 40 строчек кода :)

Только вот "фомат вызова: DTMove.vbs Имя_папки" не все могут понять :)

Типа, можно Drug & Drop :) Запускаем Проводник Windows и левой кнопкой мыши кидаем папку на скрипт.
Конечно, лучше было бы сделать, чтобы при отсутствии параметра скрипт спрашивал путь к папке, но я об этом не подумал.

[Suprus]

Добрый день!
Подскажите как реализовать, сортировку файлов по папкам (по ВРЕМЕНИ создания, не по дате, т.е чтобы скрипт создавал новые папки по формату ЧЧ-ММ и туда сортировал файлы).

[Suprus]

Вопрос решен.
Может пригодится кому-нибудь..

Код:

Dim FSO, FldN, Fls, Fl, D, DtN, FlN
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")

If WScript.Arguments.Count = 0 Then
  MsgBox "Не задано имя папки для распределения файлов по датам. ", vbExclamation, "Ошибка"
  WScript.Quit
End If

FldN = WScript.Arguments(0)
If Not FSO.FolderExists(FldN) Then
  MsgBox "Папка """ & FldN & """ не существует. ", vbExclamation, "Ошибка"
  WScript.Quit
End If

Set Fls = FSO.GetFolder(FldN).Files
For Each Fl In Fls
  D = GetTimeName(Fl.DateLastModified)
  DtN = FSO.BuildPath(FldN, D)
  If Not FSO.FolderExists(DtN) Then FSO.CreateFolder DtN

  FlN = FSO.BuildPath(DtN, Fl.Name)
  If FSO.FileExists(FlN) Then
    If MsgBox("Файл """ & Fl.Name & """ уже существует в папке """ & D & """. " & vbCr & "Перезаписать?", vbQuestion + vbOKCancel, "Внимание") = vbOK Then
      FSO.DeleteFile FlN, True
      Fl.Move FlN
    End If
  Else
    Fl.Move FlN
  End If
Next

MsgBox "Скрипт завершен. ", vbInformation, "Финиш"
WScript.Quit

Private Function GetTimeName(Dt)
    Dim H, M
    H = Hour(Dt)
    If H < 10 Then H = "0" & H
    M = Minute(Dt)
    If M < 10 Then M = "0" & M
    GetTimeName = CStr(H) & "-" & CStr(M)
End Function 

by Petya V4sechkin под редакцией AndVGri, Suprus

[cifrovichek]

Petya V4sechkin, обращаюсь к Вам за помощью.
Ситуация подобная той, которая описана ТС.
Есть папка с большим кол-вом файлов вида:
ffaa-1.jpg
ffaa-2.jpg
ffaa-3.jpg
ggaa-1.jpg
ggaa-2.jpg
ggaa-3.jpg
Нужно чтобы скрипт создал папку "ffaa" и запихнул в неё файлы ffaa-1.jpg, ffaa-2.jpg и ffaa-3.jpg.
Аналогично со следующей группой файлов.
Это реально ?