Тема: VBS: JPG не протоколируется
Ранее в другой теме создавал скрипт, который переносит из одной папки в другую и создает дату съемки для фотографий (что б наконец-таки разобрать свой фото архив). Сейчас дописал обработку для видео файлов, рекурсивный проход, меню выбора директорий и не могу понять почему не производится протоколирование для файлов JPG, а все остальное протоколируется без проблем. Пол дня просидел не могу понять ошибку.
Так же не понятные моменты, если кто сможет что-то подсказать по данным ошибкам буду очень благодарен:
1) Почему нельзя использовать напрямую File.Name и File.ParentFolder, которые получаю из
Set File = FSO.GetFile(Fl)и приходится пересохранять в переменную.
Set File = FSO.GetFile(Fl)
FileName = File.Name
FileParentFolder = File.ParentFolder
NextCheck = 1
IF LCase(FSO.GetExtensionName(File)) = LCase("jpg") Then
Set Folder = CreateObject("Shell.Application").NameSpace(FileParentFolder)
dd = Folder.GetDetailsOf(Folder.ParseName(FileName), 12)
NextCheck = 0
End IF
IF LCase(FSO.GetExtensionName(File)) = LCase("mp4") Then
Set Folder = CreateObject("Shell.Application").NameSpace(FileParentFolder)
dd = Folder.GetDetailsOf(Folder.ParseName(FileName), 3)
NextCheck = 0
End IF2) Почему здесь можно использовать переменную FL(в ней находится полный путь к файлу), но не получается использовать File.Path ведь я создаю объект Set File = FSO.GetFile(Fl)?
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(FldN1 &"\" &D) 'место назначения
objFolder.CopyHere Fl,8
'WScript.Sleep 60000 'даём время на скачивание (минута)
File.DeleteИ обязательно нужно использовать WScript.Sleep 60000 ???
3) При протоколировании, если убираю 3й передаваемый параметр, то Jpg так же начинает протоколироваться например
вместо
call WhoTakeFile(File.Path, "Скопирована копия",FlN1)делаю например так
call WhoTakeFile(File.Path, "Скопирована копия","FlN1")Предполагаю что-то не так с переменной D.
4) Предложенный вариант Flasher в 6-м посте темы VBS: Перенос фото в папку с датой съемки http://forum.script-coding.com/viewtopic.php?id=10731 не работает с файлами mpg говорит несоответствие типов:
dd = Folder.GetDetailsOf(Folder.ParseName(Name1), 12)
dd = Split(Replace(dd, Left(dd, 1), ""))(0)
D = Day(dd) : If Len(D) = 1 Then D = "0" & D
M = Month(dd) : If Len(M) = 1 Then M = "0" & M
D = Year(dd) & "-" & M & "-" & DПришлось использовать:
DMY = Split(dd,".")
YYYY = Split(DMY(2)," ")
D = DMY(0) & "." & DMY(1) & "." & YYYY(0)Предполагаю что-то не так с переменной D.
Полный код ниже:
Dim FSO, FldN, FldN1, Fl, D, FlN, FlN1, i
Dim FileMassiv()
Dim Folder, File
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
Do
Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Выберите каталог размещения файлов:", 0)
'Если пользователь не выбрал папку, завершаем приложение &H0001 + &H4000
If objFolder Is Nothing Then Exit Do
'Получаем путь к выбранной папке
FldN = objFolder.Self.Path
FoundColon = InStr(1,FldN,":",vbTextCompare)
If FoundColon = 1 Then
MsgBox "Вы выбрали некорректную папку размещения файлов попробуйте еще раз!"
End if
Loop while(FoundColon = 1)
If objFolder Is Nothing Then
MsgBox "Не выбран каталог размещения файлов"
Else
If Not FSO.FolderExists(FldN) Then
MsgBox "Папка """ & FldN & """ не существует. ", vbExclamation, "Ошибка"
WScript.Quit
End If
Do
Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Выберите каталог куда будут перемещаться файлы:", 0)
'Если пользователь не выбрал папку, завершаем приложение &H0001 + &H4000
If objFolder Is Nothing Then Exit Do
'Получаем путь к выбранной папке
FldN1 = objFolder.Self.Path
FoundColon = InStr(1,FldN1,":",vbTextCompare)
If FoundColon = 1 Then
MsgBox "Вы выбрали некорректную папку размещения файлов попробуйте еще раз!"
End if
Loop while(FoundColon = 1)
If objFolder Is Nothing Then
MsgBox "Не выбран каталог размещения файлов"
Else
If Not FSO.FolderExists(FldN1) Then
MsgBox "Папка """ & FldN1 & """ не существует. ", vbExclamation, "Ошибка"
WScript.Quit
End If
Dim NextCheck
NextCheck = 0
Erase FileMassiv
reDim preserve FileMassiv(-1)
'Запуск рекурсии по каталогу для нахождения файлов и помещения в массив FileMassiv() с полным путем нахождения
Call CheckFolderInFolder (FldN &"\")
'MsgBox Ubound(FileMassiv)
If Ubound(FileMassiv,1) = -1 Then
''WScript.Echo "Файлов в данном каталоге нет"
NextCheck = 1
End IF
If NextCheck = 0 Then
For Each Fl In FileMassiv
Dim dd
Set File = FSO.GetFile(Fl)
FileName = File.Name
FileParentFolder = File.ParentFolder
NextCheck = 1
IF LCase(FSO.GetExtensionName(File)) = LCase("jpg") Then
Set Folder = CreateObject("Shell.Application").NameSpace(FileParentFolder)
dd = Folder.GetDetailsOf(Folder.ParseName(FileName), 12)
NextCheck = 0
End IF
IF LCase(FSO.GetExtensionName(File)) = LCase("mp4") Then
Set Folder = CreateObject("Shell.Application").NameSpace(FileParentFolder)
dd = Folder.GetDetailsOf(Folder.ParseName(FileName), 3)
NextCheck = 0
End IF
If NextCheck = 0 Then
If dd = "" Then
D = "Нет_даты"
Else
DMY = Split(dd,".")
YYYY = Split(DMY(2)," ")
D = DMY(0) & "." & DMY(1) & "." & YYYY(0)
End If
Else
call WhoTakeFile(File.Path, "Файл не определен","Перенос не осуществлен")
'D = "Формат_файла_не_определен"
NextCheck = 1
End IF
If NextCheck = 0 Then
FlN = FldN1 &"\" &D &"\" &FileName
FlN1 = FldN1 &"\" &D &"\" &FileName
If Not FSO.FolderExists(FldN1 &"\" &D) Then
Dim tt
tt = "Будет создана папка " &D &" и помещен файл " &File.Name &" " &D &" = " &File.DateLastModified
'Создание папок по запросу
'ExitFromName = MsgBox (tt, 36, "Прекратить создание папки?")
If ExitFromName = 6 Then
Exit For
End If
FSO.CreateFolder (FldN1 &"\" &D)
End If
If FSO.FileExists(FlN) Then
rr = "Файл " & File.Name & " уже существует в папке " & D & ". " & vbCr & "Перезаписать?"
'ExitFromName1 = MsgBox (rr, 36, "Внимание")
ExitFromName1 = 7
If ExitFromName1 = 6 Then
FSO.DeleteFile FlN, True
call WhoTakeFile(File.Path, "Файл Перезатерт",FlN1)
File.Move FlN
Else
Set File3 = FSO.GetFile(FlN)
call WhoTakeFile(File.Path, "Скопирована копия",FlN1)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(FldN1 &"\" &D) 'место назначения
objFolder.CopyHere Fl,8
'WScript.Sleep 60000 'даём время на скачивание (минута)
File.Delete
End If
Else
'MsgBox File.Path
call WhoTakeFile(File.Path, "Файл Перенесен",FlN1)
File.Move FlN
End If
End IF
Next
End IF
End IF
MsgBox "Скрипт завершен. ", vbInformation, "Финиш"
WScript.Quit
End If
Function CheckFolderInFolder (P1)
'P1 - передаваемый параметр пути где необходима рекурсия возвращаемый заполненный массив FileMassiv(i)
RetCode = 0
If Ubound(FileMassiv) = -1 Then
i = -1
End IF
Dim File2,CollectionFolder,CollectionFile,Folder5
Set Folder5 = FSO.GetFolder(P1)
Set CollectionFolder = Folder5.SubFolders
Set CollectionFile = Folder5.Files
If CollectionFile.count > 0 Then
For Each File2 In CollectionFile
' Сообщение о файле при переборе
i = i + 1
reDim preserve FileMassiv(i)
FileMassiv(i) = File2.Path
'MsgBox File2.Path &" = " &i
'WScript.Echo File2.Path &" Размерность =" &i &" Размер массива = " &Ubound(FileMassiv)
Next
End If
For Each SubFolder In CollectionFolder
call CheckFolderInFolder (SubFolder)
Next
End Function
Sub WhoTakeFile(P1,P2,P3)
'P1 - обрабатываемый файл путь
'P2 - наименование операции
'P3 - директория для переноса
Dim File1
YearNow = Split(TakeFolderData,"_")
Dim FileTakeUser
Dim OpenFileBuzyCheck
Set FileTakeUser = FSO.GetFile(P1)
On Error Resume Next
If Not FSO.FileExists(FldN1 &"\" &"Протокол" &".txt") Then
Set OpenFileBuzyCheck = FSO.OpenTextFile(FldN1 &"\" &"Протокол" &".txt", 8, True)
OpenFileBuzyCheck.WriteLine "******************************************************************************************************************************************************************************************************************************************************************************************************************************"
OpenFileBuzyCheck.WriteLine "* Журнал обработки *"
OpenFileBuzyCheck.WriteLine "******************************************************************************************************************************************************************************************************************************************************************************************************************************"
OpenFileBuzyCheck.WriteLine "* Обрабатываемый файл * Дата и время выполнения * Производимая операция* Директория размещения * дата создания * Дата изменения * Дата открытия *"
OpenFileBuzyCheck.WriteLine "******************************************************************************************************************************************************************************************************************************************************************************************************************************"
Set File1 = FSO.GetFile(FldN1 &"\" &"Протокол" &".txt")
Else
Set File1 = FSO.GetFile(FldN1 &"\" &"Протокол" &".txt")
Set OpenFileBuzyCheck = FSO.OpenTextFile(File1, 8, True)
End If
If Err.Number = 0 Then
Dim P(7)
P(0) = FileTakeUser.Path
P(1) = P2
P(2) = P3
P(3) = FileTakeUser.DateCreated
P(4) = FileTakeUser.DateLastModified
P(5) = FileTakeUser.DateLastAccessed
P(6) = " - "
P(7) = now
Dim L(7)
L(0) = 105
L(1) = 20
L(2) = 90
L(3) = 18
L(4) = 18
L(5) = 18
L(6) = 70
L(7) = 24
For a = 0 To 7 Step 1
Do
'WScript.Echo "=" &P(a) &"="
If L(a) = "" Then
Exit Do
End If
If Len(P(a)) < L(a) Then
P(a) = P(a) &" "
End If
'If Len(P(a)) < L(a) Then
' P(a) = " " &P(a)
'End If
Loop While (Len(P(a)) < L(a))
Next
OpenFileBuzyCheck.WriteLine "* " &P(0) &" * " &P(7) &" * " &P(1) &" * " &P(2) &" * " &P(3) &" * " &P(4) &" * " &P(5) &" *"
OpenFileBuzyCheck.Close
Else
OpenFileBuzyCheck.Close
End IF
Err.Clear
On Error Goto 0
End Sub
