Total Commander

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

'=====================================================================
' Разрезание выделенных файлов на заданное количество строк
'
' Параметры:
' {файл-список} [{количество строк}]
'
' Пример вызова из TC:
' %L 2
'=====================================================================
Option Explicit
'======== Изменяемые параметры =======================================
Const DefRowCount = 1 'Количество строк по умолчанию
Const NameMode    = 0 'Режим формирования имен файлов
'Варианты режима формирования имен:
'  0 - {Имя}.{Расширение}.{Номер части}
'  1 - {Имя}.{Номер части}.{Расширение}
'  2 - {Имя}_{Номер части}.{Расширение}
'  3 - {Имя}[{Номер части}].{Расширение}
'=====================================================================
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)
    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 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

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

Dim fso, InFile, Cnt, Stroki, ts, nn

Set fso = CreateObject("Scripting.FileSystemObject") 
InFile = WScript.Arguments(0) 

Set ts=fso.OpenTextFile(InFile,1) 
Const n=3 ' число строк в каждом "куске"
Cnt=0

Do Until ts.AtEndOfStream
   Stroki=""
   For nn = 1 To n
      If Not ts.AtEndOfStream Then
         Stroki=Stroki & ts.ReadLine & vbNewLine
      End If
   Next
   Set MyFile= fso.CreateTextFile(InFile & "." & CStr(Cnt), True) 
   MyFile.Write(Stroki)
   MyFile.Close
   Cnt=Cnt+1
Loop

ts.Close 
Set ts=Nothing 
Set fso = Nothing 

WScript.Quit