[shadowbat]

куда в тотал командере копировать этот текст?

читать дальше »

Код:

'===================================================================== 
' Разрезание выделенных файлов на заданное количество строк 
' 
' Параметры: 
' {файл-список} [{количество строк}] 
' 
' Пример вызова из 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