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