Total Commander

Код: Выделить всё

'==============================================================================
' Создание дерева папок согласно разделителя в имени файла.
' В именах создаваемых папок первый символ делается заглавным.
' Например,если разделитель "_", а имя файла "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

Код: Выделить всё

• "abc_de\abc_de_fghi_jk.ext"
• "abc\abc_de_fghi_jk.ext"
• "abc\de\abc_de_fghi_jk.ext"
• "abc\de\fghi\abc_de_fghi_jk.ext"

Код: Выделить всё

01  для получения      abc_de\abc_de_fghi_jk.ext 
1   для получения         abc\abc_de_fghi_jk.ext 
111 для получения abc\de\fghi\abc_de_fghi_jk.ext
011 для получения abc_de\fghi\abc_de_fghi_jk.ext

Код: Выделить всё

'=======================================================
' Создание текстового файла с содержимым буфера обмена
'=======================================================

Спасибо Batya всё работает!

Но есть пару вопросов:
Можно так что бы текстовый фал создавался не в той дирректории
откуда запустился сам скрипт а в любой папке на активной панели?
И если можно то было бы не плохо давать динамическое имя файлу 
например по двум первым словам из текста - как в Word ?
Спасибо.

Код: Выделить всё

FileName = Left(Clip, InStr(Clip, " ") - 1)