Hello everyone! There are times when you want to copy a large file (s), with a standard function "FileCopy" freezes the entire program as long as the copy is complete. I have developed a class that uses the possibilities of the function "CopyFileEx" (using ANSI version), display of progress and the possibility of canceling up, as well as multi-threading to run all functions in a background thread. When running the copy process, you can not stop the environment stop button, only closed (it is necessary to call the destructor), otherwise there may be glitches. Also, it is advisable not to run simultaneously copying many files as for each copy creates a separate thread, and large number of them will brake. For a single stream using inline assembly with the following code:
Code:
; Thread procedure
Copy:
xor eax,eax ; eax <- 0
push eax ; local variable pbCancel
mov ecx,esp ; ecx <- *pbCancel
push eax ; dwCopyFlags
push ecx ; *pbCancel
push eax ; lpData
push 0x0 ; lpProgressRoutine
push 0x0 ; lpNewFileName
push 0x0 ; lpExitingFileName
call 0x0 ; callCopyFileEx
mov dword [0],eax ; Return value
xor eax,eax ; dwExitCode
call 0x0 ; call ExitThread
; callback function CopyProgressRoutine
CopyProgressRoutine:
fild qword [esp+12] ; LARGE_INTEGER to floating point - TotalBytesTransferred
fild qword [esp+4] ; LARGE_INTEGER to floating point - TotalFileSize
fdivp ; devide by TotalFileSize
fstp dword [0] ; Save to variable
mov eax, dword [0] ; Return value
ret 0x34Class code:
Code:
' Класс для фонового копирования файла, с отображением прогресса копирования
' Автор: © Кривоус Анатолий Анатольевич (The trick) 2013
Option Explicit
Private Declare Function HeapCreate Lib "kernel32" (ByVal flOptions As Long, ByVal dwInitialSize As Long, ByVal dwMaximumSize As Long) As Long
Private Declare Function HeapDestroy Lib "kernel32" (ByVal hHeap As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
Private Declare Function SetThreadPriority Lib "kernel32" (ByVal hThread As Long, ByVal nPriority As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Enum StateOperation
COMPLETED ' Операция закончена успешно
ACTIVE ' Операция выполняется
FAILED ' Операция завершилась неудачей
End Enum
Private Const STILL_ACTIVE = &H103&
Private Const PROGRESS_CONTINUE = 0
Private Const PROGRESS_CANCEL = 1
Private Const COPY_FILE_FAIL_IF_EXISTS = &H1
Private Const HEAP_CREATE_ENABLE_EXECUTE = &H40000
Private Const HEAP_NO_SERIALIZE = &H1
Private Const INFINITE = &HFFFFFFFF
Private Const THREAD_BASE_PRIORITY_MIN = -2
Private Const THREAD_PRIORITY_LOWEST = THREAD_BASE_PRIORITY_MIN
Private Const AsmSize As Long = 64 ' Размер вставки в байтах
Private mSourceFileName As String ' Путь, откуда копируем
Private mDestinationFileName As String ' Путь, куда копируем
Private mProgress As Single ' Прогресс 0..1
Dim hHeap As Long ' Дескриптор кучи
Dim lpFunc As Long ' Адрес функции в ассемблерной вставке
Dim init As Boolean ' Инициализирован ли код потока
Dim Src() As Byte ' ASCII строка mSourceFileName
Dim Dst() As Byte ' ASCII строка mDestinationFileName
Dim ApiRet As Long ' Возвращаемое значение из API
Dim ProgressRet As Long ' Возвращаемое значение из CopyProgressRoutine
Dim hThread As Long ' Хендл потока
Public Property Get SourceFileName() As String ' Возвращает путь откуда копировать
SourceFileName = mSourceFileName
End Property
Public Property Let SourceFileName(FileName As String) '
mSourceFileName = FileName
End Property
Public Property Get DestinationFileName() As String ' Возвращает путь куда копировать
DestinationFileName = mDestinationFileName
End Property
Public Property Let DestinationFileName(FileName As String) '
mDestinationFileName = FileName
End Property
Public Property Get Progress() As Single ' Возвращает значение от 0 до 1 прогресса копирования
Progress = mProgress
End Property
Public Property Get State() As StateOperation ' Возвращает состояние выполнения операции
If Process Then State = ACTIVE: Exit Property
State = IIf(ApiRet, COMPLETED, FAILED)
End Property
Public Sub Copy() ' Запустить копирование
Dim IDThrd As Long
If Not init Or Process Then Exit Sub ' Если не инициализированы или уже идет процесс то выходим
ProgressRet = PROGRESS_CONTINUE ' Установка продолжения процесса
LoadDynamicValue
ApiRet = -1 ' Проверка возвращаемого значения CopyFileEx
hThread = CreateThread(ByVal 0, 0, lpFunc, ByVal 0, 0, IDThrd) ' Запуск нового потока
If hThread = 0 Then ApiRet = 0: Exit Sub ' Если не удалось создать поток, тогда устанавливаем ошибку
SetThreadPriority hThread, THREAD_PRIORITY_LOWEST ' Устанавливаем низкий приоритет потоку копирования
End Sub
Public Function Cancel(Optional Wait As Boolean = False) As Boolean ' Остановить текущий процесс, ждать завершения?
If Process Then ' Имеет смысл только если идет процесс
If Wait Then
Call StopAll: Cancel = True ' Если ждем
Else
ProgressRet = PROGRESS_CANCEL ' Устанавливаем возвращаемое значение в CPR
Cancel = True
End If
End If
End Function
Private Property Get Process() As Boolean ' Возвращает True если операция выполняется
Dim Ret As Long
If hThread = 0 Then Exit Property ' Если нет активного потока, тогда False
GetExitCodeThread hThread, Ret ' Запрашиваем, завершился ли поток
If Ret = STILL_ACTIVE Then Process = True ' Если он активен, то возвращаем True
End Property
Private Sub StopAll() ' Остановить все процессы
ProgressRet = PROGRESS_CANCEL ' Отменяем процессы
If hThread Then
WaitForSingleObject hThread, INFINITE ' Ждем завершения потока
End If
hThread = 0
End Sub
Private Sub CreateAsm(Asm() As Long) ' Создаем вставку
ReDim Asm(-Int(-AsmSize / 4) - 1) ' Вычисляем нужный размер массива
Asm(0) = &H8950C031: Asm(1) = &H505150E1: Asm(2) = &H68&
Asm(3) = &H6800&: Asm(4) = &H680000: Asm(5) = &HE8000000
Asm(6) = &H0&: Asm(7) = &HA3&: Asm(8) = &HE8C03100
Asm(9) = &H0&: Asm(10) = &HC246CDF: Asm(11) = &H4246CDF
Asm(12) = &H1DD9F9DE: Asm(13) = &H0&: Asm(14) = &HA1&
Asm(15) = &H34C200
End Sub
Private Sub LoadDynamicValue() ' Установка динамических значений в вставке
Src = StrConv(mSourceFileName & vbNullChar, vbFromUnicode) ' Переводим путь из Юникода в ANSI
Dst = StrConv(mDestinationFileName & vbNullChar, vbFromUnicode) ' ...
GetMem4 VarPtr(Src(0)), ByVal lpFunc + &H13& ' Установка указателя на Исходное размещение
GetMem4 VarPtr(Dst(0)), ByVal lpFunc + &HE& ' Установка указателя на "Результирующее" размещение
End Sub
Private Sub LoadStaticValue(lpFunc As Long) ' Установка статичных значений в вставке
Dim hKernel32 As Long ' Хендл модуля Kernel32
Dim lpCopyFileEx As Long ' Адрес функции CopyFileEx
Dim lpExitThread As Long ' Адрес функции ExitThread
hKernel32 = LoadLibrary("Kernel32.dll") ' Получаем хендл Kernel32.dll
lpCopyFileEx = GetProcAddress(hKernel32, "CopyFileExA") ' Получаем адреса функций ...
lpExitThread = GetProcAddress(hKernel32, "ExitThread") '
GetMem4 lpFunc + &H28&, ByVal lpFunc + &H9& ' Установка указателя на CopyProgressRoutine
GetMem4 lpCopyFileEx - (lpFunc + &H1C&), ByVal lpFunc + &H18& ' Установка перехода на CopyFileExA
GetMem4 lpExitThread - (lpFunc + &H28&), ByVal lpFunc + &H24& ' Установка перехода на ExitThread
GetMem4 VarPtr(ApiRet), ByVal lpFunc + &H1D& ' Установка указателя на возвращаемое значение CopyFileEx
GetMem4 VarPtr(mProgress), ByVal lpFunc + &H34& ' Установка указателя на mProgress
GetMem4 VarPtr(ProgressRet), ByVal lpFunc + &H39& ' Установка указателя на возвращаемое значение CPR
End Sub
Private Sub Class_Initialize()
Dim Asm() As Long ' Буфер с ассемблерной вставкой
CreateAsm Asm ' Создаем вставку
hHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE Or _
HEAP_NO_SERIALIZE, AsmSize, AsmSize) ' Создаем кучу, с разрешением для выполнения,
' размером с ассемблерную вставку
If hHeap = 0 Then MsgBox "Error creating heap", vbCritical: _
Exit Sub ' При ошибке выходим
lpFunc = HeapAlloc(hHeap, HEAP_NO_SERIALIZE, AsmSize) ' Выделяем память в куче
If lpFunc = 0 Then MsgBox "HeapAlloc return NULL", _
vbCritical: Call Class_Terminate: Exit Sub ' Не удалось выделить память
CopyMemory ByVal lpFunc, Asm(0), AsmSize ' Копируем вставку в выделенную память
LoadStaticValue lpFunc
ApiRet = -1 ' Чтобы отрабатывало свойство State
init = True ' Инициализация успешно
End Sub
Private Sub Class_Terminate()
If Process Then
StopAll ' Останавливаем
End If
If lpFunc Then
HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpFunc ' Освобождаем выделенную память
End If
If hHeap Then
HeapDestroy hHeap ' Удаляем кучу
End If
End Sub
