[VB6] - Class for copying a file in a separate thread with display progress.-VBForums
Results 1 to 2 of 2

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

  1. #1

    Thread Starter
    Fanatic Member
    Join Date
    Feb 2015

    [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:
    ; Thread procedure
        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
        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:
    ' Класс для фонового копирования файла, с отображением прогресса копирования
    ' Автор:  Кривоус Анатолий Анатольевич (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 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                                 ' Установка продолжения процесса
        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                             ' Если ждем
                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

  2. #2

    Thread Starter
    Fanatic Member
    Join Date
    Feb 2015

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

    Test class (form):
    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                                                                      ' отменяем копирование
        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()                                                                   ' Ищем следующий файл
        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
        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
            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()
    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!


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


Click Here to Expand Forum to Full Width

Survey posted by VBForums.