[VB6] - Class for copying a file in a separate thread with display progress.

http://s43.radikal.ru/i099/1401/49/85f1cd6c2c76.png

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

---

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!

Attachment 123731

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

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.

Quote:

---

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

ANSI version works with Cyrillic characters??

Quote:

---

Originally Posted by fafalone

ANSI version works with Cyrillic characters??

---

Yes, of course like most of intrinsic VB6-functions.

In my IDE I get ????? if I try to display them in non-Unicode places. Paste them into code, ?????.

And:

https://www.vbforums.com/attachment....hmentid=184175

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.

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>

Quote:

---

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.

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.