Option Explicit
Option Compare Text ' for the Like operator
Private Enum IfStringNotFound
ReturnOriginalStr = 0
ReturnEmptyStr = 1
End Enum
Private Sub Form_Load()
Dim CMD As String, Command1 As String, Command2 As String
Dim FileNames As Collection, K As Variant, SplitBytes As Long
Dim Buffer As String, FileCount As Integer
Me.Hide
On Error GoTo ErrExit
CMD = Trim(Command)
If CMD = "" Then
MsgBox "Format examples:" & vbNewLine & _
"FileSplit -split -2files ""TestFile.dat""" & vbNewLine & _
"FileSplit -split -700kbytes ""TestFile.dat""" & vbNewLine & _
"FileSplit -split -3mbytes ""TestFile.dat""" & vbNewLine & _
"FileSplit -join ""TestFile.dat.split001"" ""TestFile.dat.split002"""
Unload Me
Exit Sub
End If
Command1 = LeftRight(CMD, "-", , ReturnEmptyStr)
Command2 = LeftLeft(LeftRight(Command1, "-", , ReturnEmptyStr), " ")
Command1 = LeftLeft(Command1, " ")
' Command1 should contain either "split" or "join" without qwotes
Set FileNames = GetFileNames(LeftRight(RightRight(CMD, "-", , ReturnEmptyStr), " "))
If FileNames Is Nothing Then
MsgBox "No files selected", vbExclamation
Unload Me
Exit Sub
End If
If Command1 Like "*split*" Then ' split into files
For Each K In FileNames
If Command2 Like "#*files*" Then ' splits file in # files
SplitBytes = FileLen(CStr(K)) / Val(Command2) ' calculate how many bytes in one file
ElseIf Command2 Like "#*kbytes" Then
SplitBytes = Val(Command2) * 1024& ' size is given in Kilo Bytes
ElseIf Command2 Like "#*mbytes" Then
SplitBytes = Val(Command2) * 1048576 ' size is given in Mega Bytes
ElseIf Command2 Like "#*bytes" Then
SplitBytes = Val(Command2) ' size is given in Bytes
End If
Open CStr(K) For Binary Access Read As #1
Do
If Loc(1) + SplitBytes > LOF(1) Then
Buffer = String(LOF(1) - Loc(1), 0) ' if last file, do only remaining bytes
Else
Buffer = String(SplitBytes, 0)
End If
Get #1, , Buffer
FileCount = FileCount + 1
Open CStr(K) & ".split" & Right("000" & FileCount, 3) For Binary Access Write As #2
Put #2, , Buffer
Close #2
Loop Until Loc(1) >= LOF(1)
Close #1
Next
ElseIf Command1 Like "*join*" Then ' join files
Dim Q As Integer, P As Integer, TmpStr As String
Dim ArrFileNames() As String, BaseFile As String
' can't sort the items in the Collection, so have to transfer into String array
ReDim ArrFileNames(FileNames.Count - 1)
For Q = 0 To UBound(ArrFileNames)
ArrFileNames(Q) = FileNames(Q + 1)
Next Q
' sort the files, to make sure the data will be joined back in the right order
For Q = 0 To UBound(ArrFileNames)
For P = Q To UBound(ArrFileNames)
If ArrFileNames(Q) > ArrFileNames(P) Then
TmpStr = ArrFileNames(Q)
ArrFileNames(Q) = ArrFileNames(P)
ArrFileNames(P) = TmpStr
End If
Next P
Next Q
Do Until FileNames.Count = 0
FileNames.Remove 1
Loop
' put the filenames back into the collection in the right order
For Q = 0 To UBound(ArrFileNames)
FileNames.Add ArrFileNames(Q)
Next Q
' now they are in the right order, and ready to put them together
Do Until FileNames.Count = 0
BaseFile = RightLeft(FileNames(1), ".split", , ReturnEmptyStr)
Open BaseFile For Binary Access Write As #1
Do While (CStr(FileNames(1)) Like BaseFile & "*")
Open CStr(FileNames(1)) For Binary Access Read As #2
Buffer = String(LOF(2), 0)
Get #2, , Buffer
Close #2
Put #1, , Buffer
FileNames.Remove 1
If FileNames.Count = 0 Then Exit Do
Loop
Close #1
Loop
Else
MsgBox "Unknown command.", vbExclamation
End If
Unload Me
Exit Sub
ErrExit:
MsgBox "Unexpected error !" & vbNewLine & _
"Error: " & Err.Number & vbNewLine & _
"Description: " & Err.Description, vbCritical, "Error"
Err.Clear
Unload Me
Exit Sub
End Sub
Private Function GetFileNames(ByVal CMD As String) As Collection
Dim FileName As String
If Trim(CMD) = "" Then Exit Function
On Error GoTo ErrResize
Do Until Trim(CMD) = ""
CMD = LeftRight(CMD, """", , ReturnEmptyStr)
FileName = LeftLeft(CMD, """", , ReturnEmptyStr)
CMD = LeftRight(CMD, """", , ReturnEmptyStr)
If Dir(FileName, vbHidden Or vbArchive) <> "" Then
If GetFileNames Is Nothing Then Set GetFileNames = New Collection
GetFileNames.Add FileName
End If
Loop
Exit Function
ErrResize:
MsgBox "Unexpected error !" & vbNewLine & _
"Error: " & Err.Number & vbNewLine & _
"Description: " & Err.Description, vbCritical, "Error"
Err.Clear
Exit Function
End Function
Private Function LeftLeft(ByRef Str As String, LFind As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long
K = InStr(1, Str, LFind, Compare)
If K = 0 Then
LeftLeft = IIf(RetError = ReturnOriginalStr, Str, "")
Else
LeftLeft = Left(Str, K - 1)
End If
End Function
Private Function LeftRight(ByRef Str As String, LFind As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long
K = InStr(1, Str, LFind, Compare)
If K = 0 Then
LeftRight = IIf(RetError = ReturnOriginalStr, Str, "")
Else
LeftRight = Right(Str, (Len(Str) - Len(LFind)) - K + 1)
End If
End Function
Private Function RightLeft(ByRef Str As String, RFind As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long
K = InStrRev(Str, RFind, , Compare)
If K = 0 Then
RightLeft = IIf(RetError = ReturnOriginalStr, Str, "")
Else
RightLeft = Left(Str, K - 1)
End If
End Function
Private Function RightRight(ByRef Str As String, RFind As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long
K = InStrRev(Str, RFind, , Compare)
If K = 0 Then
RightRight = IIf(RetError = ReturnOriginalStr, Str, "")
Else
RightRight = Mid(Str, K + 1, Len(Str))
End If
End Function
Reply With Quote
