vbs:gumanok писал(а):Теперь нужно запихать файл на несколько уровней поглубже.
Код: Выделить всё
'==============================================================================
' Создание дерева папок согласно разделителя в имени файла.
' В именах создаваемых папок первый символ делается заглавным.
' Например,если разделитель "_", а имя файла "abc_de_fghi_jk.ext", то
' будет создано "Abc\De\Fghi\jk.ext".
' Параметры:
' {список файлов} [{целевая папка} [{режим} [{разделители}]]]
' где {режим} по разрядам может принимать значения:
' 1-й разряд цифр:
' 1 - копирование (по умолчанию},
' 2 - перемещение;
' 2-й разряд цифр:
' 1 - переименовывать файл (по умолчанию},
' 2 - не переименовывать.
' Если не указана {целевая папка}, то используется папка файла.
' Можно указать несколько разделителей, перечислив их через символ ""
' Пример параметров вызова из TC:
' %L "%T" 22 "_\-\test"
' Автор - Batya
'==============================================================================
Option Explicit
'================= Изменяемые параметры =======================================
Const DefaultMode = 11 'Режим по умолчанию
Const UpperCaseMode = True 'Изменять ли регистр первого символа имени папки
Const DefaultSeparators = "_\-" 'Разделители по умолчанию
'==============================================================================
Dim FSO, FileList, TargetDir, Mode, Separators, Mess, WSH, F, NameArr, r, i, S
Dim Path, Name, FullPath
SetMess
Set WSH = CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
CheckParam
For Each F In Split(FSO.OpenTextFile(FileList).ReadAll, vbNewLine)
If F = "" Then Exit For
NameArr = FSO.GetBaseName(F)
For Each S In Separators
NameArr = Replace(NameArr, S, vbNewLine)
Next
NameArr = Split(NameArr, vbNewLine)
If TargetDir = "" Then
Path = FSO.GetAbsolutePathName(FSO.GetParentFolderName(F))
Else
Path = TargetDir
End If
r = UBound(NameArr)
On Error Resume Next
For i = 0 To r - 1
Name = NameArr(i)
If Name <> "" Then
If UpperCaseMode Then Name = UCase(Left(Name,1)) & Mid(Name, 2)
Path = Path & "" & Name
If Not FSO.FolderExists(Path) Then FSO.CreateFolder Path
If Err.Number <> 0 Then
MessBox Mess(5) & vbNewLine & Err.Description, 1
Err.Clear
Quit
End If
End If
Next
If Rank(Mode, 2) = 2 Then NameArr(r) = FSO.GetBaseName(F)
FullPath = Path & "" & NameArr(r) & "." & FSO.GetExtensionName(F)
Select Case Rank(Mode, 1)
Case 1 FSO.CopyFile F, FullPath
Case 2 FSO.MoveFile F, FullPath
End Select
If Err.Number <> 0 Then
MessBox Mess(5) & vbNewLine & Err.Description, 1
Err.Clear
Quit
End If
On Error GoTo 0
Next
MessBox Mess(6), 3
Quit
Sub CheckParam
If WScript.Arguments.Count = 0 Then
MessBox Mess(1), 1
Quit
End If
FileList = WScript.Arguments(0)
If Not FSO.FileExists(FileList) Then
MessBox Mess(2), 1
Quit
End If
If WScript.Arguments.Count > 1 Then
TargetDir = WScript.Arguments(1)
If Not TargetDir = "" Then
TargetDir = GetPath(TargetDir)
If Not FSO.FolderExists(TargetDir) Then
MessBox Mess(3), 1
Quit
End If
End If
Else
TargetDir = ""
End If
If WScript.Arguments.Count > 2 Then
Mode = WScript.Arguments(2)
If Mode = "" Then Mode = DefaultMode
If IsNumeric(Mode) Then
Mode = CInt(Mode)
Else
MessBox Mess(4), 1
Quit
End If
If Not(Rank(Mode,1) = 1 Or Rank(Mode,1) = 2) Then
MessBox Mess(4), 1
Quit
End If
If Not(Rank(Mode,2) = 1 Or Rank(Mode,2) = 2) Then
MessBox Mess(4), 1
Quit
End If
Else
Mode = DefaultMode
End If
If WScript.Arguments.Count > 3 Then
S = WScript.Arguments(3)
Else
S = ""
End If
If S = "" Then S = DefaultSeparators
Separators = Split(S, "")
End Sub
Sub SetMess
Set Mess = CreateObject("Scripting.Dictionary")
Mess.Add 0, "Создание дерева папок"
Mess.Add 1, "Не указаны входные параметры!"
Mess.Add 2, "Файл-список не существует!"
Mess.Add 3, "Целевая папка не существует!"
Mess.Add 4, "Неправильно указан режим работы скрипта!"
Mess.Add 5, "Операция прервана по причине ошибки:"
Mess.Add 6, "Операция завершена."
End Sub
Function MessBox(pMess, pMode)
Dim lIcon
Select Case pMode
Case 1 lIcon = vbCritical + vbOKOnly
Case 2 lIcon = vbExclamation + vbOKOnly
Case 3 lIcon = vbInformation + vbOKOnly
Case 4 lIcon = vbExclamation + vbOKCancel
End Select
MessBox = MsgBox(pMess, lIcon, Mess(0))
End Function
Function GetPath(pPath)
GetPath = FSO.GetAbsolutePathName(WSH.ExpandEnvironmentStrings(pPath))
End Function
Function Rank(pNumber, pPosition)
Rank = Left(Right(pNumber, pPosition), 1)
End Function
Sub Quit
Set Mess = Nothing
Set FSO = Nothing
Set WSH = Nothing
WScript.Quit
End Sub- возможность не переименовывать файл;
- возможность задать несколько разделителей;
- несколько разделителей подряд обрабатываются, как один.
