1

Тема: VBS: парсинг имен файлов с датой, перенос старых

Здравствуйте.

На общей шаре есть папка, в которую складываются файлы со строго определенными именами + в имени файла присутствует дата.
Например:

Информация по углю 03.03.2011.pdf
Сборы на 20.02.2011.pdf
Прочая информация 14.03.2011.pdf

В какой-то момент времени (пару раз в неделю) туда складываются новые файлы с такими же именами, но новыми датами (но не обязательно сегодняшними).
В итоге необходим скрипт, который бы запускался, например, каждый день и проверял в этой папке наличие двух файлов с одинаковыми именами, но тот, у которого дата меньше - переносился в архивную папку.

Я уже было придумал как сделать это на cmd, но только если с привязкой к сегодняшней дате. Боюсь, что для решения данной задачи средств cmd не хватит. Посему сабж.

2 (изменено: Xameleon, 2011-03-15 11:07:49)

Re: VBS: парсинг имен файлов с датой, перенос старых

2 holydiver: То ли я с утра совсем туп, то ли объяснение такое замудрёное. ) Перечитал 3 раза - что надо сделать пока не понял.

Сфокусировал внимание на этих предложениях. Вроде бы самая суть.

В итоге необходим скрипт, который бы запускался, например, каждый день и проверял в этой папке наличие двух файлов с одинаковыми именами, но тот, у которого дата меньше - переносился в архивную папку.

Но фраза - "проверял в этой папке наличие двух файлов с одинаковыми именами", ставит меня в тупик, т.к в папке не может существовать файлов и папок с одинаковыми именами. Читаю дальше - "но тот, у которого дата меньше - переносился в архивную папку." Постойте, постойте... Только что выше посмотрел примеры файлов: "03.03.2011.pdf","20.02.2011.pdf". У них дата и есть имя файла. Значит файлы не с одинаковыми именами ?

Требуется пояснение.

Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

3

Re: VBS: парсинг имен файлов с датой, перенос старых

Ну да, пардон. Файлы не совсем с одинаковыми именами, немного смудрил в объяснении...
В общем, есть строго фиксированная первая часть имени файла, вторая часть - некая дата.
Например, в папки лежат 2 файла:

Информация по углю 03.03.2011.pdf
Информация по углю 12.03.2011.pdf

Скрипт должен проверить, что есть два файла, у которых первая часть имени совпадает. Если это так, то проверяет вторую часть имен этих файлов, которая соответствует некой дате. И вот тот файл, у которого дата меньше - должен переноситься в архивную папку.

4

Re: VBS: парсинг имен файлов с датой, перенос старых

Понял. Это я с утра туго соображал. Глядя на строки:

Информация по углю 03.03.2011.pdf
Информация по углю 12.03.2011.pdf

я решил, что первая часть это Ваш комментарий, и считал, что имя файла "03.03.2011.pdf"

Сейчас тяп ляп собрал скрипт. Работать работает. Но надо оптимизировать. Из папки 2 в папку 1 файлы переносит по Вашим условиям.

Option Explicit
Dim FileSystemObject, Folder1, Folder2, File, i, FileNames(), FilteredItems, File1Description, File1Date, File2Description, File2Date
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
Set Folder1 = FileSystemObject.GetFolder("D:\Visual Basic Projects\file test\folder1")
Set Folder2 = FileSystemObject.GetFolder("D:\Visual Basic Projects\file test\folder2")

'MsgBox FileSystemObject.FileExists("D:\Visual Basic Projects\file test\folder1\*.pdf")

For Each File in Folder1.Files
    Redim Preserve FileNames(i)
    FileNames(i) = File.Name
    i = i + 1
Next

For Each File in Folder2.Files
    GetFileParams File.Name, File2Description, File2Date
    FilteredItems = Filter(FileNames,File1Description,True,1)
    if Ubound(FilteredItems) => 0 Then
        GetFileParams FilteredItems(0), File1Description, File1Date
        MsgBox File2Date & "/" & File1Date
        if CDate(File2Date) > CDate(File1Date) Then
            FileSystemObject.GetFile(FileSystemObject.BuildPath(Folder1.Path,FilteredItems(0))).Delete True
            File.Copy FileSystemObject.BuildPath(Folder1.Path,"\"), True
        End if
    End if
Next

Sub GetFileParams(FileName,FileDescription,FileDate)
    Dim BaseName
    BaseName = FileSystemObject.GetBaseName(FileName)
    FileDescription = Left(BaseName,InstrRev(BaseName," ")-1)
    FileDate = Mid(BaseName,InstrRev(BaseName," ")+1)
End Sub
Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

5

Re: VBS: парсинг имен файлов с датой, перенос старых

holydiver пишет:

...
В какой-то момент времени (пару раз в неделю) туда складываются новые файлы с такими же именами, но новыми датами (но не обязательно сегодняшними).
В итоге необходим скрипт, который бы запускался, например, каждый день и проверял в этой папке наличие двух файлов с одинаковыми именами, но тот, у которого дата меньше - переносился в архивную папку.
...

holydiver,

я бы пересмотрел сам алгоритм архивирования.

Вы предлагаете:
1. Копировать новые файлы в рабочую папку.
2. С некоторой периодичностью (раз в час, день, месяц, год...) запускать проверку однотипных файлов с разной датой и архивировать все, кроме последнего по дате.

На мой взгляд архивирование надо делать уже на этапе копирования, точнее перед копированием.
Т.е. перед копирование, например, Информация по углю 12.03.2011.pdf в рабочую папку делать что-то типа 
copy Информация по углю*.pdf в архивную папку, а затем del Информация по углю*.pdf из рабочей папки.

6

Re: VBS: парсинг имен файлов с датой, перенос старых

Xameleon, спасибо, сейчас буду пробовать. С vbs дела имел, но тут нечто новое.
Кстати, задача, оказывается, расширилась... Каждый файл надо пихать в свою архивную папку. Поэтому, видимо, придется как-то разделить и явно указывать начальное имя файла, чтобы потом знать какой куда перенести.

Slav, согласен, и я бы так сделал. Но дело в том, что в эту рабочую папку новые файлы копируют пользователи, причем с iPad'ов, а происходит это не каждый день.

7

Re: VBS: парсинг имен файлов с датой, перенос старых

Xameleon, хм... твой скрипт получается сравнивает то, что в папке folder2 и folder1, а не внутри одной папки?
Я сейчас попробовал. Положил в папку folder2 файлы:

Информация по углю 03.03.2011.pdf
Информация по углю 12.03.2011.pdf

В папке folder1 пусто. При запуске скрипта выдает мэсседж бокс "Ложь" (я раскомментил строку). В итоге ничего не происходит.
Положил в папку folder1 файлы:

Сборы 01.02.2011
Сборы 11.03.2011

Результат такой:
мэсседж бокс "03.03.2011/01.02.2011" (то есть даты первых файлов в папке folder1 и папки folder2),
мэсседж бокс "12.03.2011/01.02.2011" (первая дата - это второй файл в папке folder2, вторая - первый файл в папке folder1).
И в папке folder1 два файла: Информация по углю 03.03.2011.pdf и Сборы 11.03.2011.pdf

8 (изменено: Xameleon, 2011-03-16 11:57:27)

Re: VBS: парсинг имен файлов с датой, перенос старых

2 holydiver: Кхм. Опять из объяснения ничего не понял, что у Вас происходит. Информация попала в голову и безнадёжно ищет мозги...

1) Только что проверил скрипт. Он из папки folder2 копирует более новые файлы в папку folder1. Сделал

в папке "folder1" файл "Информация по углю 03.03.2011.pdf", а в папке "folder2" файл "Информация по углю 12.03.2011.pdf". При запуске, скрипт успешно заменяет один файл на другой.

2) Предлагаю связаться по icq, т.к я так понял там условия поменялись и теперь есть подкаталоги или как то так ? Либо опишите проблему более доступно с ветвлением. Блок схемы приветствуются )

Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

9

Re: VBS: парсинг имен файлов с датой, перенос старых

В аську постучал, но раз пока ответа нет, то напишу сюда подробнее.

На шаренном диске есть папка "Информация". В ней лежат файлы:

Информация по углю 03.03.2011.pdf
Сборы на 20.02.2011.pdf
Прочая информация 14.03.2011.pdf

В какой-нибудь момент времени юзер записывает туда еще один файл, например положение в папке становится таким:

Информация по углю 03.03.2011.pdf
Информация по углю 03.03.2011.pdf
Сборы на 20.02.2011.pdf
Прочая информация 14.03.2011.pdf

Нужно, чтобы скрипт пробегался по этой папке "Информация" в поисках двух файлов, которые начинают одинаково. Если такие есть, то сравнивал из концовки, то есть даты. И с меньшей датой отправлял в архивную папку. То есть на данном примере он бы перемещал файл Информация по углю 03.03.2011.pdf

Проблема еще состоит в том, что "Информация по углю"  имеет одну архивную папку, "Сборы" - другую и т.д.

10 (изменено: Xameleon, 2011-03-16 16:24:56)

Re: VBS: парсинг имен файлов с датой, перенос старых

Option Explicit

Const ForAppending = 8
Const ForWriting = 2
Dim FileSystemObject
Dim Dictionary
Dim Folder
Dim File
Dim LogFile
Dim PreviousFile
Dim ScriptPath
Dim FullArchivePath

CheckHost

Set Dictionary = CreateObject("Scripting.Dictionary")
'---- настройки
Const FolderPath = "D:\f\test"

Dictionary("") = "D:\f\0"
Dictionary("Информация по углю") = "D:\f\Уголь"
Dictionary("Сборы на") = "D:\f\Сборы"
Dictionary("Прочая информация") = "D:\f\Информация"
'---- настройки

Set FileSystemObject = CreateObject("Scripting.FileSystemObject")

ScriptPath = FileSystemObject.BuildPath(FileSystemObject.GetParentFolderName(WScript.ScriptFullName),"\")

Set Folder = FileSystemObject.GetFolder(FolderPath)

Set LogFile = FileSystemObject.OpenTextFile(ScriptPath & Date & ".txt", ForWriting, True)

For Each File in Folder.Files
    if Not isObject(PreviousFile) Then
        Set PreviousFile = File
    Else
        
        if GetDescription(PreviousFile.Name) = GetDescription(File.Name) Then
            AppendToLog "Найдены однотипные файлы """ & PreviousFile.Name & """ """ & File.Name & """"
            if GetFileDate(File.Name) > GetFileDate(PreviousFile.Name) Then
                FullArchivePath = Dictionary(GetDescription(PreviousFile.Name))
                if FullArchivePath <> "" Then
                    FullArchivePath = FileSystemObject.BuildPath(FullArchivePath,"\")
                    AppendToLog "Перемещаем файл """ & PreviousFile.Name & """ в архивный каталог """ & FullArchivePath & """."
                    If Not FileSystemObject.FolderExists(FullArchivePath) Then RecursiveCreateFolder FullArchivePath
                    PreviousFile.Move FullArchivePath
                Else
                    AppendToLog "Не известен каталог архива для файлов """ & GetDescription(PreviousFile.Name) & """"
                End if
            End if
        End if
        
        Set PreviousFile = File
    End if
Next

Sub RecursiveCreateFolder(ByVal path)
    Dim part, tmpPath
    Path = Replace(Path,"/","\")
    Path = Split(Path,"\")
    For Each Part in Path
        tmpPath = tmpPath & Part & "\"
        If Not FileSystemObject.FolderExists(tmpPath) Then FileSystemObject.CreateFolder(tmpPath)
    Next
End Sub

Function GetDescription(FileName)
    GetDescription = Left(FileName,InstrRev(FileName," ") - 1)
End Function

Function GetFileDate(ByVal FileName)
    Dim SpacePos, DateValue
    FileName = FileSystemObject.GetBaseName(FileName)
    SpacePos = InstrRev(FileName," ")
    if SpacePos > 0 Then
        DateValue = mid(FileName,SpacePos + 1)
        if isDate(DateValue) Then GetFileDate = CDate(DateValue)
    End if
End Function

Sub AppendToLog(Text)
    LogFile.WriteLine Time & ": " & Text 
End Sub

Sub CheckHost()
    if Instr(1,WScript.FullName,"cscript",1) Then
        Dim WshShell
        Set WshShell = CreateObject("WScript.Shell")
        WshShell.Run "wscript.exe """ & WScript.ScriptFullName & """",1,False
        WScript.Quit()
    End if
End Sub

Вот такой вот вариант )

Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

11

Re: VBS: парсинг имен файлов с датой, перенос старых

Xameleon пишет:

Вот такой вот вариант )

А если составить список всех файлов вида "категория дата.pdf" и переместить все кроме последнего в архивный каталог? Псевдокод:

files = dirlist("Информация по углю*.pdf", SORT_BY_MDATE)
n = files.length - 2
for each i = 0 .. n
    f = files[i]
    f.moveTo(targetDir)
next
( 2 * b ) || ! ( 2 * b )

12 (изменено: Xameleon, 2011-03-16 17:01:39)

Re: VBS: парсинг имен файлов с датой, перенос старых

2 Rumata: Ну от псевдокода до рабочего кода далеко. А работать должно уже сейчас. ) А в принципе я как раз так и сделал. FileSystemObject всегда возвращает файлы в алфавитном порядке. Этим я и воспользовался для выборки наиболее "свежего" файла.

Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

13

Re: VBS: парсинг имен файлов с датой, перенос старых

Xameleon пишет:

…FileSystemObject всегда возвращает файлы в алфавитном порядке.

Xameleon, только на NTFS (там они сортируются в MFT изначально). Но, например, для FAT32:

&#9556;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552; H:\0056 &#9552;&#9552;&#9552;&#9572;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9552;&#9572;&#9552;&#9552;&#9552;&#9552;&#9552;&#9559;
&#9553;и         Имя          &#9474;Размер&#9474;  Дата  &#9474;Время&#9553;
&#9553;..                     &#9474; Вверх&#9474;16.03.11&#9474;16:51&#9553;
&#9553;0001                vbs&#9474;   154&#9474;16.03.11&#9474;16:53&#9553;
&#9553;aaaa                txt&#9474;     0&#9474;16.03.11&#9474;16:52&#9553;
&#9553;bbbb                txt&#9474;     0&#9474;16.03.11&#9474;16:51&#9553;
&#9553;                       &#9474;      &#9474;        &#9474;     &#9553;
For Each objFile In WScript.CreateObject("Scripting.FileSystemObject").GetFolder("H:\0056").Files
    WScript.Echo objFile.Name
Next
H:\0056>cscript.exe //nologo 0001.vbs
bbbb.txt
aaaa.txt
0001.vbs

14

Re: VBS: парсинг имен файлов с датой, перенос старых

Мне кажется такой вариант должен работать и на FAT(к тому же будет работать если "внезапно" однотипных файлов более двух):

' VB Script Document
Option Explicit
Dim MonitorDir, OutInfo, OutCoal, OutTax
MonitorDir = "c:\aScripts\vbs\script-coding_01\In\"
OutInfo = "c:\aScripts\vbs\script-coding_01\Out\Информация\"
OutCoal = "c:\aScripts\vbs\script-coding_01\Out\Уголь\"
OutTax = "c:\aScripts\vbs\script-coding_01\Out\Сборы\"

chkFolder OutInfo
chkFolder OutCoal
chkFolder OutTax

Dim tmplInfo, tmplCoal, tmplTax
tmplInfo = "Прочая информация"
tmplCoal = "Информация по углю"
tmplTax = "Сборы на"

Dim dicInfo, dicCoal, dicTax
Set dicInfo = CreateObject("Scripting.Dictionary")
Set dicCoal = CreateObject("Scripting.Dictionary")
Set dicTax = CreateObject("Scripting.Dictionary")

Dim fso, WshShell
Set fso = CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")

Dim folder, file
If fso.FolderExists(MonitorDir) Then
  Set folder = fso.GetFolder(MonitorDir)
 Else
  wscript.echo "Исходный каталог задан неверно!"
  wscript.quit
End If

Dim prefix, data
For Each file In folder.files
 prefix = trim(left(file.name,len(file.name) - 14))
 data = left(trim(right(file.name, 14)),10)
 Select Case prefix
  Case tmplInfo
   dicInfo.add data, file.name
  Case tmplCoal
   dicCoal.add  data, file.name
  Case tmplTax
   dicTax.add  data, file.name
 End Select
Next

Dim arrTMP, i, lastData

If dicInfo.Count > 1 Then  chkFiles dicInfo, OutInfo
If dicCoal.Count > 1 Then chkFiles dicCoal, OutCoal
If dicTax.Count > 1 Then  chkFiles dicTax, OutTax

Set fso = Nothing
Set WshShell = Nothing

Sub chkFiles(Dic, ToDir)
 arrTMP = Dic.Keys
 lastData = vbNullString
 For i = lBound(arrTMP) To uBound(arrTMP)
  If len(lastData) = 0 Then lastData = arrTMP(i) 'первый проход
  If cDate(lastData) < cDate(arrTMP(i)) Then
    fso.GetFile(fso.BuildPath(MonitorDir,Dic.Item(lastData))).Move ToDir
    lastData = arrTMP(i)
   elseif cDate(lastData) > cDate(arrTMP(i)) Then
    fso.GetFile(fso.BuildPath(MonitorDir,Dic.Item(arrTMP(i)))).Move ToDir
  End If
 Next
End Sub

'##############################################################################
'########            проверка-создание дерева каталогов              ##########
'##############################################################################
' 1/2
Dim s_chkPath : s_chkPath = ""
Sub chkFolder(s_path) ' проверка существования файла(логфайла, например)
 Dim s_fso, s_a
 Set s_fso = CreateObject("Scripting.FileSystemObject")
 If Not s_fso.FolderExists(s_path) Then ' если папка не существует
   If StrComp(right(s_path,1),"\") = 0 Then ' папка с пустым именем нам не нужна :)
     s_chkPath = left(s_path, len(s_path) - 1)
    Else
     s_chkPath = s_path
   End If
   ' разбиваем путь на состовляющие
   Dim s_arrFolderPath(), s_regEx, s_Match, s_Matches   ' Create variable.
   Set s_regEx = New RegExp   ' Create regular expression.
   s_regEx.Pattern = "(\\){1}?"   ' Set pattern.
   s_regEx.Global = True   ' Set global applicability.
   Set s_Matches = s_regEx.Execute(s_path)   ' Execute search.
   Redim s_arrFolderPath(s_Matches.count)
   s_chkPath = s_fso.BuildPath (s_chkPath,"")
   wscript.echo "проверяемый путь => " & s_path
   Call MkFldrTree(s_arrFolderPath, s_fso.BuildPath(s_chkPath,""), 0)
 End If
 Set s_a = Nothing
 Set s_fso = Nothing
End Sub
' 2/2
Sub MkFldrTree(Byref s_arr(), s_path2chk, s_fi) ' формирование дерева каталогов
 'wscript.echo fi
 Dim s_fso
 Set s_fso = CreateObject("Scripting.FileSystemObject")
 If s_fso.FolderExists(s_path2chk) Then ' если полученный путь существует...
  If StrComp(s_path2chk, s_chkPath, vbTextCompare) <> 0 Then
    Dim s_fi2
    For s_fi2 = s_fi - 1 To 0 step - 1
     wscript.echo "создаю папку: " & s_path2chk & "\" & s_arr(s_fi2)
     s_fso.CreateFolder s_path2chk & "\" & s_arr(s_fi2)
     s_path2chk = s_path2chk & "\" & s_arr(s_fi2)
    Next
    wscript.echo "done"
  End If
 Else ' если полученный путь НЕ существует...
  wscript.echo s_path2chk & " - не найдена"
  ' укорачиваем путь на один уровень
  s_arr(s_fi) = Right(s_path2chk, Len(s_path2chk)-InStrRev(s_path2chk, "\", -1, vbTextCompare))
  s_path2chk = Left(s_path2chk, InStrRev(s_path2chk, "\", -1, vbTextCompare) - 1)
  s_fi = s_fi + 1
  Call MkFldrTree(s_arr, s_path2chk, s_fi)
 End If
 Set s_fso = Nothing
End Sub
'##############################################################################

Для некоторой универсальности для каждого из трёх типов документов архивная папка файлов задаётся отдельно.
Вывод процесса в лог-файл не делал(рутина, не интересно ).
Если папок архивных не существует, то они будут созданы(в оригинале это была заготовка под текстовый файл, но и с папками жить будет). Правда предполагается, что права на запись в папке содержащей каталог архивных папок у пользователя запускающего скрипт имеются(обработки отказа в доступе нет).
Если исходной папки не существует - сообщение в консоль и завершение работы скрипта.
Подозреваю что при отличной от русской локали(т.е. формат даты не dd.mm.yyyy) сравнение дат будет некорректно - можно и это учесть, просто больше писать прийдётся.

15

Re: VBS: парсинг имен файлов с датой, перенос старых

alexii пишет:

Xameleon, только на NTFS (там они сортируются в MFT изначально). Но, например, для FAT32:

Ах вон оно как. На FAT не работал, поэтому не ожидал. Тогда стоит загнать весь массив файлов в Recordset и упорядочить. )

Спасибо за информацию.

Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

16

Re: VBS: парсинг имен файлов с датой, перенос старых

Проще на JS написать:)

17 (изменено: JSmаn, 2011-03-17 00:17:51)

Re: VBS: парсинг имен файлов с датой, перенос старых

var fso = new ActiveXObject("Scripting.FileSystemObject");

function SORT_BY_DATE(A , B)
{
    var a = A.match(/[\d\.]+/)[0].replace(/(\d{2})\.(\d{2})\.(\d{4})/, "$3$2$1"),
    b = B.match(/[\d\.]+/)[0].replace(/(\d{2})\.(\d{2})\.(\d{4})/, "$3$2$1");
    return a>b;
}

function FileList(Re)
{
    var Result=[], os = new ActiveXObject("WScript.Shell"), 
    fls = new Enumerator(fso.getFolder(os.CurrentDirectory + "\\").Files);    
    for (;!fls.atEnd();fls.moveNext()) 
    if (Re.test(fls.item())) Result.push(fls.item()+"");
    return Result;
}

Array.prototype.move = function (path)
{
    for (var i=0; i<this.length; i++)
    fso.MoveFile(this[i], path+"\\"+this[i].split("\\").pop());
}

FileList(/сборы/i).sort(SORT_BY_DATE).slice(0,-1).move("Folder");

18

Re: VBS: парсинг имен файлов с датой, перенос старых

Ого, какая дискуссия развернулась
Спасибо всем!
Код от Xameleon в #10 работает так как мне нужно

19

Re: VBS: парсинг имен файлов с датой, перенос старых

Xameleon.
Правильно оформленный псевдокод залог быстрой реализации на реальном языке.
Основной упор в моем сообщении был не в том чтобы иметь отсортированный список (хотя это тоже очень важно), но в том, чтобы перенести все файлы, кроме последнего.
Судя по последним сообщениям - Ваш код работает. Поэтому дискуссия уже не имеет значения.

( 2 * b ) || ! ( 2 * b )