Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Нестандартное (побайтное) копирование файлов средствами VBA
 
#1
08.05.2021 15:27:59
'кому-то это нужно...
Код
'-----------------------------------------------------------------
'-----------------------------------------------------------------
'File:      duplex.xls
'Author:    Mikhail I.
'Purpose:   code for the files copying
'               //(for files < 256Mb)
'Revision:  1.0
'-----------------------------------------------------------------
'-----------------------------------------------------------------
Function BinaryDuplicate()
Dim ByteArg() As Byte
Dim ByteNum As String
Dim NewByteNum As String
Dim NewByte As Byte
Dim ByteLen As Integer
Dim NewByteArray() As Byte
Dim FilesPathsArray() As String
Dim FilesSizesArray() As String
Dim timeNow As Date
Dim timeFinish As Date
Dim timeCode As Date
Dim NewFilesPathsArray() As String
Dim OldFilesName() As String
Dim FilePath0 As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
MsgBox "Выберите файлы для копирования"
With fd
    If .Show = -1 Then
        For Each FilePath In .SelectedItems
            NmbrOfFiles = NmbrOfFiles + 1
        Next
    End If
End With
i = 1
ReDim Preserve FilesPathsArray(NmbrOfFiles)
ReDim Preserve OldFilesName(NmbrOfFiles)
With fd
For Each FilePath In .SelectedItems
FilesPathsArray((NmbrOfFiles - (NmbrOfFiles - i))) = FilePath
i = i + 1
Next
i = 1
For Each Filename In .SelectedItems
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(Filename)
OldFilesName((NmbrOfFiles - (NmbrOfFiles - i))) = f.Name
i = i + 1
Next
End With
MsgBox "Выберите папку, куда копировать. (в туже папку копировать нельзя)"
Dim FilePathCopy As String
Dim fd0 As FileDialog
Set fd0 = Application.FileDialog(msoFileDialogFolderPicker)
With fd0
    If .Show = -1 Then
        For Each FolderPath In .SelectedItems
            FilePathCopy = FolderPath
        Next
    End If
End With
Dim SingleFileSize As Variant
Dim FilesSize As Variant
For i0 = 1 To NmbrOfFiles
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(FilesPathsArray(i0))
SingleFileSize = f.Size
FilesSize = FilesSize + SingleFileSize
Next i0
MsgBox ("Size:                       " & Left((FilesSize / 1000000), 6) & " Mb" & vbCrLf & _
        "Coding time:  ~  " & Left((((((FilesSize / 1000000) / 60)) * 2)), 6) & " minutes")
Num0 = InputBox("press 0 key")
Num1 = InputBox("press 1 key")
Num2 = InputBox("press 2 key")
Num3 = InputBox("press 3 key")
Num4 = InputBox("press 4 key")
Num5 = InputBox("press 5 key")
Num6 = InputBox("press 6 key")
Num7 = InputBox("press 7 key")
Num8 = InputBox("press 8 key")
Num9 = InputBox("press 9 key")
i0 = 1
timeNow = Time
For n0 = 1 To NmbrOfFiles
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(FilesPathsArray(i0))
i00 = 0
fnp = Empty
Do Until fnp = FilesPathsArray(i0)
fnp = Left(FilesPathsArray(i0), i00)
i00 = i00 + 1
Loop
CountSymbolsFullFilePath = i00 - 1
Ext = fs.GetExtensionName(FilesPathsArray(i0))
i00 = 0
extn = Empty
Do Until extn = Ext
extn = Left(Ext, i00)
i00 = i00 + 1
Loop
CountSymbolsExt = i00
CountSymbolsShP = CountSymbolsFullFilePath - CountSymbolsExt - 1
FileNameShortPath = Left(FilesPathsArray(i0), CountSymbolsShP)
Const ForReading = 1, ForWriting = 2, ForAppending = 3
fs.CreateTextFile FileNameShortPath
Set nf = fs.GetFile(FileNameShortPath)
Set ts = nf.OpenAsTextStream(ForWriting, TristateUseDefault)
ts.Write f.Name
ts.Close
Dim TempFileLength As Variant
Dim TempByteArg() As Byte
Dim NewTempByteArray() As Byte
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(FileNameShortPath)
TempFileLength = f.Size
Open FileNameShortPath For Binary Access Read Write As #1
ReDim TempByteArg(TempFileLength)
ReDim NewTempByteArray(TempFileLength)
For n = 1 To TempFileLength
Get #1, , TempByteArg(n)
TempByteNum = TempByteArg(n)
TempByteLen = Len(TempByteNum)
If TempByteLen = 1 Then
    If Left(TempByteNum, 1) = Num0 Then NewByteNum = Num0
    If Left(TempByteNum, 1) = Num1 Then NewByteNum = Num1
    If Left(TempByteNum, 1) = Num2 Then NewByteNum = Num2
    If Left(TempByteNum, 1) = Num3 Then NewByteNum = Num3
    If Left(TempByteNum, 1) = Num4 Then NewByteNum = Num4
    If Left(TempByteNum, 1) = Num5 Then NewByteNum = Num5
    If Left(TempByteNum, 1) = Num6 Then NewByteNum = Num6
    If Left(TempByteNum, 1) = Num7 Then NewByteNum = Num7
    If Left(TempByteNum, 1) = Num8 Then NewByteNum = Num8
    If Left(TempByteNum, 1) = Num9 Then NewByteNum = Num9
End If
If TempByteLen = 2 Then
    If Left(TempByteNum, 1) = Num0 Then NewByteNum = Num0
    If Left(TempByteNum, 1) = Num1 Then NewByteNum = Num1
    If Left(TempByteNum, 1) = Num2 Then NewByteNum = Num2
    If Left(TempByteNum, 1) = Num3 Then NewByteNum = Num3
    If Left(TempByteNum, 1) = Num4 Then NewByteNum = Num4
    If Left(TempByteNum, 1) = Num5 Then NewByteNum = Num5
    If Left(TempByteNum, 1) = Num6 Then NewByteNum = Num6
    If Left(TempByteNum, 1) = Num7 Then NewByteNum = Num7
    If Left(TempByteNum, 1) = Num8 Then NewByteNum = Num8
    If Left(TempByteNum, 1) = Num9 Then NewByteNum = Num9
    If Right(TempByteNum, 1) = Num0 Then NewByteNum = NewByteNum + Num0
    If Right(TempByteNum, 1) = Num1 Then NewByteNum = NewByteNum + Num1
    If Right(TempByteNum, 1) = Num2 Then NewByteNum = NewByteNum + Num2
    If Right(TempByteNum, 1) = Num3 Then NewByteNum = NewByteNum + Num3
    If Right(TempByteNum, 1) = Num4 Then NewByteNum = NewByteNum + Num4
    If Right(TempByteNum, 1) = Num5 Then NewByteNum = NewByteNum + Num5
    If Right(TempByteNum, 1) = Num6 Then NewByteNum = NewByteNum + Num6
    If Right(TempByteNum, 1) = Num7 Then NewByteNum = NewByteNum + Num7
    If Right(TempByteNum, 1) = Num8 Then NewByteNum = NewByteNum + Num8
    If Right(TempByteNum, 1) = Num9 Then NewByteNum = NewByteNum + Num9
End If
If TempByteLen = 3 Then
    If Left(TempByteNum, 1) = Num0 Then NewByteNum = Num0
    If Left(TempByteNum, 1) = Num1 Then NewByteNum = Num1
    If Left(TempByteNum, 1) = Num2 Then NewByteNum = Num2
    If Left(TempByteNum, 1) = Num3 Then NewByteNum = Num3
    If Left(TempByteNum, 1) = Num4 Then NewByteNum = Num4
    If Left(TempByteNum, 1) = Num5 Then NewByteNum = Num5
    If Left(TempByteNum, 1) = Num6 Then NewByteNum = Num6
    If Left(TempByteNum, 1) = Num7 Then NewByteNum = Num7
    If Left(TempByteNum, 1) = Num8 Then NewByteNum = Num8
    If Left(TempByteNum, 1) = Num9 Then NewByteNum = Num9
    If Right((Left(TempByteNum, 2)), 1) = Num0 Then NewByteNum = NewByteNum + Num0
    If Right((Left(TempByteNum, 2)), 1) = Num1 Then NewByteNum = NewByteNum + Num1
    If Right((Left(TempByteNum, 2)), 1) = Num2 Then NewByteNum = NewByteNum + Num2
    If Right((Left(TempByteNum, 2)), 1) = Num3 Then NewByteNum = NewByteNum + Num3
    If Right((Left(TempByteNum, 2)), 1) = Num4 Then NewByteNum = NewByteNum + Num4
    If Right((Left(TempByteNum, 2)), 1) = Num5 Then NewByteNum = NewByteNum + Num5
    If Right((Left(TempByteNum, 2)), 1) = Num6 Then NewByteNum = NewByteNum + Num6
    If Right((Left(TempByteNum, 2)), 1) = Num7 Then NewByteNum = NewByteNum + Num7
    If Right((Left(TempByteNum, 2)), 1) = Num8 Then NewByteNum = NewByteNum + Num8
    If Right((Left(TempByteNum, 2)), 1) = Num9 Then NewByteNum = NewByteNum + Num9
    If Right(TempByteNum, 1) = Num0 Then NewByteNum = NewByteNum + Num0
    If Right(TempByteNum, 1) = Num1 Then NewByteNum = NewByteNum + Num1
    If Right(TempByteNum, 1) = Num2 Then NewByteNum = NewByteNum + Num2
    If Right(TempByteNum, 1) = Num3 Then NewByteNum = NewByteNum + Num3
    If Right(TempByteNum, 1) = Num4 Then NewByteNum = NewByteNum + Num4
    If Right(TempByteNum, 1) = Num5 Then NewByteNum = NewByteNum + Num5
    If Right(TempByteNum, 1) = Num6 Then NewByteNum = NewByteNum + Num6
    If Right(TempByteNum, 1) = Num7 Then NewByteNum = NewByteNum + Num7
    If Right(TempByteNum, 1) = Num8 Then NewByteNum = NewByteNum + Num8
    If Right(TempByteNum, 1) = Num9 Then NewByteNum = NewByteNum + Num9
End If
NewTempByteArray(n) = NewByteNum
Next
For n1 = 1 To FileLength
Put #1, n1, NewTempByteArray(n1)
Next
Close #1
Set nf = fs.GetFile(FileNameShortPath)
Set ts = nf.OpenAsTextStream(ForReading, TristateUseDefault)
    NewName = ts.ReadLine
ts.Close
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CreateTextFile (FilePathCopy & "\" & NewName)
Set fs = CreateObject("Scripting.FileSystemObject")
Set nf = fs.GetFile(FileNameShortPath)
fs.DeleteFile FileNameShortPath, 1
i0 = i0 + 1
Next
i0 = 1
For i1 = 1 To NmbrOfFiles
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(FilesPathsArray(i0))
FileLength = f.Size
Open FilesPathsArray(i0) For Binary Access Read Write As #1
ReDim Preserve NewFilesPathsArray(NmbrOfFiles)
NewFilesPathsArray(i0) = FilePathCopy & "\" & OldFilesName(i0)
Open NewFilesPathsArray(i0) For Binary Access Read Write As #2
i0 = i0 + 1
ReDim ByteArg(FileLength)
ReDim NewByteArray(FileLength)
For n = 1 To FileLength
Get #1, , ByteArg(n)
ByteNum = ByteArg(n)
ByteLen = Len(ByteNum)
If ByteLen = 1 Then
    If Left(ByteNum, 1) = Num0 Then NewByteNum = Num0
    If Left(ByteNum, 1) = Num1 Then NewByteNum = Num1
    If Left(ByteNum, 1) = Num2 Then NewByteNum = Num2
    If Left(ByteNum, 1) = Num3 Then NewByteNum = Num3
    If Left(ByteNum, 1) = Num4 Then NewByteNum = Num4
    If Left(ByteNum, 1) = Num5 Then NewByteNum = Num5
    If Left(ByteNum, 1) = Num6 Then NewByteNum = Num6
    If Left(ByteNum, 1) = Num7 Then NewByteNum = Num7
    If Left(ByteNum, 1) = Num8 Then NewByteNum = Num8
    If Left(ByteNum, 1) = Num9 Then NewByteNum = Num9
End If
If ByteLen = 2 Then
    If Left(ByteNum, 1) = Num0 Then NewByteNum = Num0
    If Left(ByteNum, 1) = Num1 Then NewByteNum = Num1
    If Left(ByteNum, 1) = Num2 Then NewByteNum = Num2
    If Left(ByteNum, 1) = Num3 Then NewByteNum = Num3
    If Left(ByteNum, 1) = Num4 Then NewByteNum = Num4
    If Left(ByteNum, 1) = Num5 Then NewByteNum = Num5
    If Left(ByteNum, 1) = Num6 Then NewByteNum = Num6
    If Left(ByteNum, 1) = Num7 Then NewByteNum = Num7
    If Left(ByteNum, 1) = Num8 Then NewByteNum = Num8
    If Left(ByteNum, 1) = Num9 Then NewByteNum = Num9
    If Right(ByteNum, 1) = Num0 Then NewByteNum = NewByteNum + Num0
    If Right(ByteNum, 1) = Num1 Then NewByteNum = NewByteNum + Num1
    If Right(ByteNum, 1) = Num2 Then NewByteNum = NewByteNum + Num2
    If Right(ByteNum, 1) = Num3 Then NewByteNum = NewByteNum + Num3
    If Right(ByteNum, 1) = Num4 Then NewByteNum = NewByteNum + Num4
    If Right(ByteNum, 1) = Num5 Then NewByteNum = NewByteNum + Num5
    If Right(ByteNum, 1) = Num6 Then NewByteNum = NewByteNum + Num6
    If Right(ByteNum, 1) = Num7 Then NewByteNum = NewByteNum + Num7
    If Right(ByteNum, 1) = Num8 Then NewByteNum = NewByteNum + Num8
    If Right(ByteNum, 1) = Num9 Then NewByteNum = NewByteNum + Num9
End If
If ByteLen = 3 Then
    If Left(ByteNum, 1) = Num0 Then NewByteNum = Num0
    If Left(ByteNum, 1) = Num1 Then NewByteNum = Num1
    If Left(ByteNum, 1) = Num2 Then NewByteNum = Num2
    If Left(ByteNum, 1) = Num3 Then NewByteNum = Num3
    If Left(ByteNum, 1) = Num4 Then NewByteNum = Num4
    If Left(ByteNum, 1) = Num5 Then NewByteNum = Num5
    If Left(ByteNum, 1) = Num6 Then NewByteNum = Num6
    If Left(ByteNum, 1) = Num7 Then NewByteNum = Num7
    If Left(ByteNum, 1) = Num8 Then NewByteNum = Num8
    If Left(ByteNum, 1) = Num9 Then NewByteNum = Num9
    If Right((Left(ByteNum, 2)), 1) = Num0 Then NewByteNum = NewByteNum + Num0
    If Right((Left(ByteNum, 2)), 1) = Num1 Then NewByteNum = NewByteNum + Num1
    If Right((Left(ByteNum, 2)), 1) = Num2 Then NewByteNum = NewByteNum + Num2
    If Right((Left(ByteNum, 2)), 1) = Num3 Then NewByteNum = NewByteNum + Num3
    If Right((Left(ByteNum, 2)), 1) = Num4 Then NewByteNum = NewByteNum + Num4
    If Right((Left(ByteNum, 2)), 1) = Num5 Then NewByteNum = NewByteNum + Num5
    If Right((Left(ByteNum, 2)), 1) = Num6 Then NewByteNum = NewByteNum + Num6
    If Right((Left(ByteNum, 2)), 1) = Num7 Then NewByteNum = NewByteNum + Num7
    If Right((Left(ByteNum, 2)), 1) = Num8 Then NewByteNum = NewByteNum + Num8
    If Right((Left(ByteNum, 2)), 1) = Num9 Then NewByteNum = NewByteNum + Num9
    If Right(ByteNum, 1) = Num0 Then NewByteNum = NewByteNum + Num0
    If Right(ByteNum, 1) = Num1 Then NewByteNum = NewByteNum + Num1
    If Right(ByteNum, 1) = Num2 Then NewByteNum = NewByteNum + Num2
    If Right(ByteNum, 1) = Num3 Then NewByteNum = NewByteNum + Num3
    If Right(ByteNum, 1) = Num4 Then NewByteNum = NewByteNum + Num4
    If Right(ByteNum, 1) = Num5 Then NewByteNum = NewByteNum + Num5
    If Right(ByteNum, 1) = Num6 Then NewByteNum = NewByteNum + Num6
    If Right(ByteNum, 1) = Num7 Then NewByteNum = NewByteNum + Num7
    If Right(ByteNum, 1) = Num8 Then NewByteNum = NewByteNum + Num8
    If Right(ByteNum, 1) = Num9 Then NewByteNum = NewByteNum + Num9
End If
NewByteArray(n) = NewByteNum
Next
For n1 = 1 To FileLength
Put #2, n1, NewByteArray(n1)
Next
Close #1
Close #2
Next i1
timeFinish = Time
timeCode = timeFinish - timeNow
Beep
If timeCode > ("00:05:00") Then
For beeping = 1 To 7
Beep
Application.Wait (Now + TimeValue("00:00:01"))
Next beeping
End If
MsgBox ("decoding complited..." & vbCrLf & _
        "" & vbCrLf & _
        "File Size:    " & (FilesSize / 1000000) & " Mb" & vbCrLf & _
        "Start Time:    " & timeNow & "" & vbCrLf & _
        "Finish Time:    " & timeFinish & "" & vbCrLf & _
        "Coding time : " & timeCode)
'Эта программа предоставляется бесплатно. Но вы можете
'помочь проекту отправив любую сумму на этот биткойн адрес:
'14pKtuTeaHJyi4yQeX4T7W3pGphbNrx62p

End Function
 
 
 
#2
08.05.2021 16:05:41
Все тоже самое, только в 2 строки
Код
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.CopyFile "C:\txt.txt", "C:\txt_copy.txt"
Спасибо
 
 
 
#3
08.05.2021 16:18:11
для такой задачи - две строки кода это неоправданное расточительство:
Код
FileCopy "C:\txt.txt", "C:\txt_copy.txt"
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
Страницы: 1
Наверх