Total Commander

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

'MessBox Mess(3), 3

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

Const NameMode    = 1 'Режим формирования имен файлов

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

'=====================================================================
' Разрезание выделенных файлов на заданное количество строк
'
' Параметры:
' {файл-список} [{количество строк}]
'
' Пример вызова из TC:
' %L 2
'=====================================================================
Option Explicit
Dim CharArr
'======== Изменяемые параметры =======================================
Const DefRowCount = 1 'Количество строк по умолчанию
Const NameMode    = 4 'Режим формирования имен файлов
'Варианты режима формирования имен:
'  0 - {Имя}.{Расширение}.{Номер части}
'  1 - {Имя}.{Номер части}.{Расширение}
'  2 - {Имя}_{Номер части}.{Расширение}
'  3 - {Имя}[{Номер части}].{Расширение}
'  4 - {Первые несколько слов текста}.{Расширение}
Const WordsCount  = 3 'Количество слов для режима 4 формирования имен
'Массив недопустимых символов имени. Заменяем их указанным ниже символом
CharArr = Split(Chr(10) & " " & Chr(13) & " \ / * ? "" < > . ,")
'Символ для замены недопустимого символа
Const ReplaceChar = " "
'=====================================================================
Dim Mess, FSO, WSH, FF, RowCount
SetMess
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = CreateObject("WScript.Shell")

On Error Resume Next
CheckParam:CheckErr
Main:CheckErr
'MessBox Mess(3), 3
Quit 0

Sub Main
  Dim F
  For Each F In Split(FSO.OpenTextFile(FF).ReadAll, vbNewLine)
    Action F
  Next
End Sub

Sub Action(pPath)
  Dim lText, lT, lCnt, lPath, lArr, lR, lNum, lNewPath
  If pPath = "" Then Exit Sub
  lPath = GetPath(pPath)
  If Not FSO.FileExists(lPath) Then Exit Sub
  lText = FSO.OpenTextFile(lPath).ReadAll
  lCnt  = 0
  lArr  = CutText(lText, RowCount)
  lR    = Len(CStr(UBound(lArr)))
  For Each lT In lArr
    lNum = Right(String(lR, "0") & CStr(lCnt), lR)
    Select Case NameMode
      Case 0 lNewPath = lPath & "." & lNum
      Case 1 lNewPath = FSO.GetParentFolderName(lPath) & "" & FSO.GetBaseName(lPath) &_
                        "." & lNum & "." & FSO.GetExtensionName(lPath)
      Case 2 lNewPath = FSO.GetParentFolderName(lPath) & "" & FSO.GetBaseName(lPath) &_
                        "_" & lNum & "." & FSO.GetExtensionName(lPath)
      Case 3 lNewPath = FSO.GetParentFolderName(lPath) & "" & FSO.GetBaseName(lPath) &_
                        "[" & lNum & "]." & FSO.GetExtensionName(lPath)
      Case 4 lNewPath = FSO.GetParentFolderName(lPath) & "" & GetSomeWords(ReplaceInadmissibleChars(lT), WordsCount) &_
                        "." & FSO.GetExtensionName(lPath)
    End Select
    FSO.CreateTextFile(lNewPath, True).Write lT
    lCnt = lCnt + 1
  Next
End Sub

Function CutText(pText, pRowCount)
  Dim lArr, lR, lR1, l, l1, l2, l3
  lArr = Split(pText, vbNewLine)
  lR   = UBound(lArr)
  lR1  = -Int(-(lR + 1)/pRowCount) - 1
  ReDim lArr1(lR1)
  For l = 0 To lR1
    l1 = (l + 1) * pRowCount - 1
    l2 = pRowCount - 1
    If l1 > lR Then l2 = lR - l * pRowCount
    For l3 = 0 To l2
      lArr1(l) = lArr1(l) & lArr(l3 + l1 - pRowCount + 1) & vbNewLine
    Next
  Next
  lArr1(lR1) = Left(lArr1(lR1), Len(lArr1(lR1)) - Len(vbNewLine))
  CutText = lArr1
End Function

Sub CheckParam
  With WScript
    If .Arguments.Count = 0 Then Err.Raise vbObjectError + 1, "", Mess(1)
    FF = GetPath(.Arguments(0))
    If Not FSO.FileExists(FF) Then Err.Raise vbObjectError + 2, "", Mess(2)
    If .Arguments.Count > 1 Then
      RowCount = .Arguments(1)
      If IsNumeric(RowCount) Then
        RowCount = CInt(RowCount)
      Else
        RowCount = DefRowCount
      End If
    Else
      RowCount = DefRowCount
    End If
  End With
End Sub

Function GetSomeWords(pText, pNumWords)
  Dim regEx, lM, l, lF, lNum
  Set regEx     = New RegExp
  regEx.Pattern = "\S+"
  regEx.Global  = True
  Set lM        = regEx.Execute(pText)
  If  lM.Count  < pNumWords Then
    lNum = lM.Count
  Else
    lNum = pNumWords
  End If
  For l = 1 To lNum
    lF = lF & " " & lM.Item(l-1).Value
  Next
  GetSomeWords = Mid(lF, 2)
  Set lM    = Nothing
  Set regEx = Nothing
End Function

Function ReplaceInadmissibleChars(pText)
  Dim lC
  ReplaceInadmissibleChars = pText
  For Each lC In CharArr
    ReplaceInadmissibleChars = Replace(ReplaceInadmissibleChars, lC, ReplaceChar)
  Next
End Function

Function GetPath(pPath)
  GetPath = FSO.GetAbsolutePathName(WSH.ExpandEnvironmentStrings(pPath))
End Function

Sub CheckErr
  If Err.Number <> 0 Then
    MessBox "Возникла ошибка № " & Err.Number & ":" & vbNewLine & Err.Description, 1
    Quit Err.Number
  End If
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
  End Select
  MessBox = MsgBox(pMess, lIcon, Mess(0))
End Function

Sub SetMess
  Set Mess = CreateObject("Scripting.Dictionary")
  With Mess
    .Add 0,  "Разрезание файлов на строки"
    .Add 1,  "Не указаны параметры!"
    .Add 2,  "Файл-список не существует!"
    .Add 3,  "Операция завершена."
  End With
End Sub

Sub Quit(pQuitCode)
  Set Mess = Nothing
  Set WSH  = Nothing
  Set FSO  = Nothing
  WScript.Quit pQuitCode
End Sub

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

      Case 4 lNewPath = FSO.GetParentFolderName(lPath) & "" & ReplaceInadmissibleChars(GetSomeWords(lT, WordsCount)) &_
                        "." & FSO.GetExtensionName(lPath)

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

      Case 4 lNewPath = FSO.GetParentFolderName(lPath) & "" & ReplaceInadmissibleChars(GetSomeWords(lT, WordsCount)) &_
                        ".txt"

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

    FSO.CreateTextFile(lNewPath, True).Write lT

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

    MsgBox "Попытка сформировать файл """ & lNewPath & """ с содержимым:" & vbNewLine & vbNewLine & lT, 0, Mess(0)