Batya
|
 Posted: Mon Nov 23, 2009 13:59 Post subject: |
 |
|
| angry_dog wrote: | | Буду ждать помощи. |
Готово:
| Code: | '==============================================================================
' Создание дерева папок согласно разделителя в имени файла\папки.
' В именах создаваемых папок первый символ делается заглавным.
' Например,если разделитель "_", а имя файла "abc_de_fghi_jk.ext", то
' будет создано "abc\de\fghi\jk.ext".
' Параметры:
' {список файлов\папок} [{целевая папка} [{режим} [{разделители} [{обрабатываемые разделители}]]]]
' где {режим} по разрядам может принимать значения:
' 1-й разряд цифр:
' 1 - копирование (по умолчанию},
' 2 - перемещение;
' 2-й разряд цифр:
' 1 - переименовывать файл\папку (по умолчанию},
' 2 - не переименовывать.
' Если не указана {целевая папка}, то используется текущая папка.
' Можно указать несколько разделителей, перечислив их через символ "\".
' Параметр {обрабатываемые разделители} указывает, какие разделители
' в имени файла\папки учитываются при создании дерева папок. Данный параметр
' представляет из себя набор 0 и 1, задающих необходимость (0 - нет,
' 1 - да) обработки разделителя в соответствующей позиции слева направо.
' Пример параметров вызова из TC:
' %L "%T" 22 "_\-\test" 101
' Автор - Batya
'==============================================================================
Option Explicit
'================= Изменяемые параметры =======================================
Const DefaultMode = 11 'Режим по умолчанию
Const UpperCaseMode = False 'Изменять ли регистр первого символа имени папки
Const DefaultSeparators = "_\-" 'Разделители по умолчанию
'==============================================================================
Dim FSO, FileList, TargetDir, Mode, Separators, Mess, WSH, F, NameArr, r, i, S
Dim Path, Name, FullPath, SepPos, SepPosArr, IsFolder, BaseName
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
IsFolder = False
If FSO.FolderExists(F) Then IsFolder = True
If IsFolder Then
BaseName = FSO.GetFolder(F).Name
Else
BaseName = FSO.GetBaseName(F)
End If
NameArr = Split(Separate(BaseName, Separators, SepPosArr, vbNewLine), 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) = BaseName
FullPath = Path & "\" & NameArr(r)
If Not IsFolder Then FullPath = FullPath & "." & FSO.GetExtensionName(F)
If IsFolder Then
Select Case Rank(Mode, 1)
Case 1 FSO.CopyFolder GetPath(F), FullPath
Case 2 FSO.MoveFolder GetPath(F), FullPath
End Select
Else
Select Case Rank(Mode, 1)
Case 1 FSO.CopyFile F, FullPath
Case 2 FSO.MoveFile F, FullPath
End Select
End If
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, "\")
If WScript.Arguments.Count > 4 Then
SepPos = WScript.Arguments(4)
If Not IsNumeric(SepPos) Then
MessBox Mess(7), 1
Quit
End If
r = Len(SepPos) - 1
ReDim SepPosArr(r)
For i = 0 To r
S = Mid(SepPos, i + 1, 1)
If Not(S = 0 Or S = 1) Then
MessBox Mess(7), 1
Quit
End If
SepPosArr(i) = (S = 1)
Next
Else
SepPosArr = Array()
End If
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, "Операция завершена."
Mess.Add 7, "Неправильно указан параметр позиций обрабатываемых разделителей!"
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 Separate(pText, pSeparators, pSepPosArr, pL)
Dim ss, sf, lPos0, lPos1, lS, lText
ss = "<":sf = ">":lText = pText
For Each lS In pSeparators
lPos0 = 1
Do
lPos1 = InStr(lPos0, lText, ss)
If lPos1 = 0 Then
lText = Left(lText, lPos0 - 1) & Replace(Mid(lText, lPos0), lS, ss & lS & sf)
lPos0 = 1
Else
lText = Left(lText, lPos0 - 1) & Replace(Mid(lText, lPos0, lPos1 - lPos0), lS, ss & lS & sf) &_
Mid(lText, lPos1)
lPos0 = InStr(lPos1 + 1, lText, sf) + 1
End If
Loop Until lPos0 = 1
Next
lPos0 = 1:i = 0
r = UBound(pSepPosArr)
Do
lPos1 = InStr(lPos0, lText, ss)
If lPos1 > 0 Then
lPos0 = InStr(lPos1 + 1, lText, sf) + 1
If r >= i Then
If pSepPosArr(i) Then lText = Left(lText, lPos1 - 1) & pL & Mid(lText, lPos0):lPos0 = lPos1 + Len(pL)
Else
lText = Left(lText, lPos1 - 1) & pL & Mid(lText, lPos0):lPos0 = lPos1 + Len(pL)
End If
i = i + 1
Else
lPos0 = 1
End If
Loop Until lPos0 = 1
lText = Replace(lText, ss, ""):lText = Replace(lText, sf, "")
Separate = lText
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 |
Согласно изначально поставленной задачи, параметры вызова из TC должны быть:
| ! | CaptainFlint: | | Скрипт отредактирован по просьбе Batya: исправлена ошибка при работе с количеством параметров меньше 5. |
_________________
Нет, я не сплю. Я просто медленно моргаю.
Last edited by Batya on Tue Nov 24, 2009 18:58; edited 1 time in total |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
