Бывает ситуация, когда нужно скопировать большой файл(ы), при этом стандартная ф-ция FileCopy вешает всю программу до тех пор, пока не закончится копирование. Я разработал класс, в котором используется возможности ф-ции CopyFileEx (использовал ANSI версию), отображение прогресса копирования и возможности отмены, а также многопоточность для запуска всех функций в фоновом потоке. При запущенном процессе копирования, нельзя останавливать среду кнопкой стоп, только закрытием (нужно обязательно вызывать деструктор класса), иначе возможны глюки. Также желательно не запускать одновременно копирование большого количества файлов т.к. на каждое копирование создается отдельный поток, и при большом их количестве будут тормоза. Для отдельного потока использовал ассемблерную вставку со следующим кодом:| Assembler | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
| ; Основная функция вызываемая в новом потоке при копировании
Copy:
xor eax,eax ; eax <- 0
push eax ; Локальная переменная pbCancel
mov ecx,esp ; Сохраняем адрес переменной
push eax ; dwCopyFlags
push ecx ; Указатель на pbCancel
push eax ; lpData
push 0x0 ; lpProgressRoutine
push 0x0 ; lpNewFileName
push 0x0 ; lpExitingFileName
call 0x0 ; Вызов CopyFileEx
mov dword [0],eax ; Возвращаемое значение
xor eax,eax ; dwExitCode
call 0x0 ; Вызов ExitThread
; Функция обратного вызова CopyProgressRoutine
CopyProgressRoutine:
fild qword [esp+12] ; LARGE_INTEGER в вещественное число TotalBytesTransferred
fild qword [esp+4] ; LARGE_INTEGER в вещественное число TotalFileSize
fdivp ; делим на TotalFileSize
fstp dword [0] ; Сохраняем в переменную
mov eax, dword [0] ; Возвращаемое значение
ret 0x34 |
|
Код класса:| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
| ' Класс для фонового копирования файла, с отображением прогресса копирования
' Автор: © Кривоус Анатолий Анатольевич (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 |
|
| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
| 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 |
|
|
