Batya
|
 Posted: Mon Jan 11, 2010 16:23 Post subject: |
 |
|
| JayK wrote: | | А если разбиение не по одной строке, а по задаваемому кол-ву, можно такое сделать? |
Можно:
| Code: | '=====================================================================
' Разрезание выделенных файлов на заданное количество строк
'
' Параметры:
' {файл-список} [{количество строк}]
'
' Пример вызова из 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 |
Last edited by Batya on Thu Jan 14, 2010 15:48; edited 4 times in total |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
