-
Feb 13th, 2015, 08:31 AM
#1
[VB6] - Class for copying a file in a separate thread with display progress.
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 0x34
Instead of zeros, fit the data later in proceedings: "LoadStaticValue" - are those that will not change; "LoadDynamicValue" - the names of the files. You can use the class and one for multiple copying, or the same number of simultaneous backup.
Class 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
-
Feb 13th, 2015, 08:36 AM
#2
Re: [VB6] - Class for copying a file in a separate thread with display progress.
Test class (form):
Code:
Option Explicit
Dim Fle As Collection ' Коллекция объектов копируемых файлов
Private Sub cmdCancel_Click() ' Если жмем Cancel
Dim Obj As clsProgressCopy
If Not lstFileProgress.SelectedItem Is Nothing Then ' Если выделен в листе
Set Obj = Fle(lstFileProgress.SelectedItem.Index) ' Устанавливаем во временную переменную объект
Obj.Cancel ' Отменяем копирование
RefreshList ' Обновляем список
End If
End Sub
Private Sub cmdCancelAll_Click() ' Если жмем Cancel All
Dim Obj As clsProgressCopy
For Each Obj In Fle ' Для каждого объекта
Obj.Cancel ' отменяем копирование
Next
RefreshList ' Обновляем список
End Sub
Private Sub cmdCopy_Click()
Dim fName As String, Obj As clsProgressCopy, SrcPath As String, DstPath As String
SrcPath = dirFoldersSrc.List(dirFoldersSrc.ListIndex) & "\" ' Устанавливаем пути
DstPath = dirFoldersDst.List(dirFoldersDst.ListIndex) & "\"
If StrComp(SrcPath, DstPath, vbTextCompare) = 0 Then _
MsgBox "Выберите другую директорию": Exit Sub ' Если пути совпадают то выходим
lstFileProgress.ListItems.Clear ' Очищаем список
Do While Fle.Count: Fle.Remove (1): Loop ' Очищаем коллекцию
fName = Dir(SrcPath) ' Ищем первый файл в папке
Do While Len(fName) And Fle.Count <= 64 ' Пока есть файлы и их количество <=64
Set Obj = New clsProgressCopy ' Создаем объект фонового копирования
Obj.SourceFileName = SrcPath & fName ' Задаем пути
Obj.DestinationFileName = DstPath & fName ' ...
Fle.Add Obj ' Добавляем в коллекцию
lstFileProgress.ListItems.Add , , fName ' Добавляем в список
Obj.Copy ' Запускаем копирование
fName = Dir() ' Ищем следующий файл
Loop
If Fle.Count = 0 Then Exit Sub ' Если не было файлов, выходим
SetState True ' Сменяем контролы
tmrRefresh.Enabled = True ' Запускаем таймер обновления
End Sub
Private Sub drvVolumeSrc_Change()
dirFoldersSrc.Path = drvVolumeSrc.Drive ' Смена диска
End Sub
Private Sub drvVolumeDst_Change()
dirFoldersDst.Path = drvVolumeDst.Drive ' Смена диска
End Sub
Private Sub SetState(Value As Boolean) ' Сменить рабочие контролы
cmdCopy.Enabled = Not Value
cmdCancel.Enabled = Value
cmdCancelAll.Enabled = Value
drvVolumeSrc.Enabled = Not Value
drvVolumeDst.Enabled = Not Value
dirFoldersSrc.Enabled = Not Value
dirFoldersDst.Enabled = Not Value
End Sub
Private Sub RefreshList() ' Обновить список
Dim Obj As clsProgressCopy, I As Long, s As Boolean
For Each Obj In Fle
With lstFileProgress.ListItems(I + 1)
.Text = GetFileTitle(Obj.DestinationFileName)
.SubItems(1) = Format(Obj.Progress, "0.00%")
.SubItems(2) = Choose(Obj.State + 1, "Завершено", "Активно", "Ошибка")
End With
s = s Or (Obj.State = ACTIVE) ' Если хоть один еще работает, тогда s=True
I = I + 1
Next
If Not s Then ' Если все закончилось, очищаем все
tmrRefresh.Enabled = False
Do While Fle.Count: Fle.Remove (1): Loop
SetState False
End If
End Sub
Private Function GetFileTitle(Path As String) As String ' Получить имя по пути
Dim L As Long, P As Long
L = InStrRev(Path, "\")
P = Len(Path) + 1
If P > L Then
L = IIf(L = 0, 1, L + 1)
GetFileTitle = Mid$(Path, L, P - L)
ElseIf P = L Then
GetFileTitle = Path
Else
GetFileTitle = Mid$(Path, L + 1)
End If
End Function
Private Sub Form_Load()
Set Fle = New Collection
dirFoldersSrc.Path = drvVolumeSrc.Drive
dirFoldersDst.Path = drvVolumeDst.Drive
End Sub
Private Sub Form_Resize()
lstFileProgress.ColumnHeaders(1).Width = lstFileProgress.Width / 3
lstFileProgress.ColumnHeaders(2).Width = lstFileProgress.Width / 3
lstFileProgress.ColumnHeaders(3).Width = lstFileProgress.Width / 3
End Sub
Private Sub tmrRefresh_Timer()
RefreshList
End Sub
PS. Because it is not recommended to terminate the thread through the "TerminateThread", I used "ExitThread" in the thread itself, so when a large number of files processed at the same time, when you close the window, waiting for the completion of each class of its threads and VB6 freezes at this time. Good luck!
CopyProgress.zip
-
Mar 2nd, 2022, 04:26 AM
#3
Member
Re: [VB6] - Class for copying a file in a separate thread with display progress.
Why there is a limit on 64 files? There is any reason?
I ask you this because I want to use your code in my backup system. I need to copy multiple file, several times the number of files is above of 4k and the total size is near 4/5gb.
Does this code still work with their amount of data?
Best regards
-
Mar 2nd, 2022, 04:45 AM
#4
Re: [VB6] - Class for copying a file in a separate thread with display progress.
It's better to modify the code because each instance creates a heap. The class supports the file size >4GB. I'll modify this class later.
-
Mar 2nd, 2022, 04:48 AM
#5
Member
Re: [VB6] - Class for copying a file in a separate thread with display progress.
Originally Posted by The trick
It's better to modify the code because each instance creates a heap. The class supports the file size >4GB. I'll modify this class later.
Many thanks man.
I'll wait for it.
See you soon
-
Mar 2nd, 2022, 05:05 AM
#6
Re: [VB6] - Class for copying a file in a separate thread with display progress.
ANSI version works with Cyrillic characters??
-
Mar 2nd, 2022, 05:34 AM
#7
Re: [VB6] - Class for copying a file in a separate thread with display progress.
Originally Posted by fafalone
ANSI version works with Cyrillic characters??
Yes, of course like most of intrinsic VB6-functions.
-
Mar 2nd, 2022, 06:51 AM
#8
Re: [VB6] - Class for copying a file in a separate thread with display progress.
In my IDE I get ????? if I try to display them in non-Unicode places. Paste them into code, ?????.
And:
I always use Unicode functions because the moment VB touches another alphabet, that's the result.
Internally I know VB strings are Unicode, so you can store them normally and pass via StrPtr(), but I thought the reason for all those ??? was the native controls and IDE were only ANSI.
-
Mar 2nd, 2022, 08:30 AM
#9
Re: [VB6] - Class for copying a file in a separate thread with display progress.
VB6 is one of the few languages/compilers which treats source files as ANSI in system's current codepage (i.e. CP_ACP).
Cyrillic in ANSI sources get encodes in second page (i.e. &H80-&HFF) but on compilation these are converted to UTF-16 (i.e. Unicode) and get embedded in the final executable as BSTRs (i.e. zero-terminated and length prefixed).
So yes, it's possible to use VB6 with cyrillic texts in both sources and UI controls but the final executable runs correctly only on systems with Cyrillic system's codepage (a.k.a. locale for non-Unicode applications).
The same is true for Latin-1 codepages (i.e. English/German) but in English you don't use second ANSI page for umlauts and accents (rarely for special symbols) so you don't get to know the problems this introduces on client machines with different locale.
VB6 being an ANSI language is a problem for github for instance (not git) where you cannot configure repo's ANSI files codepage. It tries to autodetect codepage, fails and default's to Latin-1 so you get garbled cyrillic texts unless there is a lot of cyrillic texts for autodetect to succeed.
cheers,
</wqw>
-
Mar 2nd, 2022, 08:39 AM
#10
Re: [VB6] - Class for copying a file in a separate thread with display progress.
Originally Posted by fafalone
I always use Unicode functions because the moment VB touches another alphabet, that's the result.
Yes, this is the proper solution. Just it's quite old project i'll update as said with Unicode support.
About codepages wqweto answered. You can check this thread where you can see the details about it.
-
Mar 4th, 2022, 10:14 AM
#11
Re: [VB6] - Class for copying a file in a separate thread with display progress.
I think the codepage would be the text codepage which we set at VB6 IDE text editor options. So before opening a Greek say cpde, we have to set Greek as language for text editor. Also you have to use the Greek keyboard to insert Greek characters. The compiled program use the utf16 strings.
My M2000 Interpreter has many string literals in Greek language and can run in any computer, with any language, including any language for non unicode programs.
Also the problem for IDE and then non unicode programs setting is the decimal point. If the original frm files are edited in a regional preference like the one for Greek language, the decimal point character is comma (,) and for this reason the font size which are mostly numbers with decimals use the coma. So if you have Greek text on IDE and Greek keyboard, but not comma for decimal point you get log files which says that there is a problem on reading numbers on a number of frm files.
Tags for this Thread
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|