-
I'm trying to get some kind of file copying function that will display a progress dialog box because I'm copying large files across the network. I've tried using CopyFileEx with a callback function but I can't get the parameters right, it keeps crashing. Here is what I have:
''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Public Const PROGRESS_CONTINUE As Long = 0
Public Const PROGRESS_CANCEL As Long = 1
Public Const PROGRESS_STOP As Long = 2
Public Const PROGRESS_QUIET As Long = 3
Public Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
Public Declare Function GetLastError Lib "kernel32" () As Long
Public Declare Function CopyFileExA Lib "kernel32" _
( _
ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
lpProgressRoutine As Long, _
lpData As Long, _
pbCancel As Long, _
ByVal dwCopyFlags As Long _
) As Long
Public Function CopyProgressRoutine _
( _
TotalFileSize As LARGE_INTEGER, _
TotalBytesTransferred As LARGE_INTEGER, _
StreamSize As LARGE_INTEGER, _
StreamBytesTransferred As LARGE_INTEGER, _
ByVal dwStreamNumber As Long, _
ByVal dwCallbackReason As Long, _
hSourceFile As Long, _
hDestinationFile As Long, _
lpData As Long _
) As Long
On Error GoTo EH
Dim filenum As Integer
filenum = FreeFile()
'NOTE: this file is never created(must be crashing before entering this callback function)...
Open "c:\info.txt" For Append As #filenum
Print #1, TotalBytesTransferred.highpart, TotalBytesTransferred.lowpart
Close #filenum
CopyProgressRoutine = PROGRESS_CONTINUE
Exit Function
EH:
CopyProgressRoutine = PROGRESS_CANCEL
MsgBox Err.Number & " - " & Err.Description
End Function
Public Sub Main()
On Error GoTo EH
Dim bCancel As Long, x As Long, y As Long, z As Long
z = 1
x = CopyFileExA("<sourcefile>", "<destfile>", _
AddressOf CopyProgressRoutine, z, bCancel, 0&)
If x = 0 Then
y = Err.LastDllError
x = GetLastError()
MsgBox "GetLastError returned: " & x & vbCrLf & "Err.LastDllError is: " & y
End If
Exit Sub
EH:
MsgBox Err.Number & " - " & Err.Description
End Sub
'''''''''''''''''''''''''''''''''''''''''''''
Is there a better way to display Windows' progress dialog box that is shown when copying large files?
Thanks in advance,
Scott
-
For some reason I am unable to edit my own post, so I'm writing another one. Please ignore that yellow smiley face near the end of the code section. Apparently ampersand-end-parenthesis is a code for smiley face. : ) Its supposed to be:
x = CopyFileExA("<sourcefile>", "<destfile>", _
AddressOf CopyProgressRoutine, z, bCancel, 0& )
-
use the [ CODE ], [ / CODE ] tags to post code ;)
Anyway, here is a working version, i modidfied it a bit.
Code:
Option Explicit
Private Const ERROR_SUCCESS As Long = 0&
Public Const PROGRESS_CONTINUE As Long = 0 '#define PROGRESS_CONTINUE 0
Public Const PROGRESS_CANCEL As Long = 1 '#define PROGRESS_CANCEL 1
Public Const PROGRESS_STOP As Long = 2 '#define PROGRESS_STOP 2
Public Const PROGRESS_QUIET As Long = 3 '#define PROGRESS_QUIET 3
Public Const CALLBACK_CHUNK_FINISHED As Long = &H0 '#define CALLBACK_CHUNK_FINISHED 0x00000000
Public Const CALLBACK_STREAM_SWITCH As Long = &H1 '#define CALLBACK_STREAM_SWITCH 0x00000001
Public Const COPY_FILE_FAIL_IF_EXISTS As Long = &H1 '#define COPY_FILE_FAIL_IF_EXISTS 0x00000001
Public Const COPY_FILE_RESTARTABLE As Long = &H2 '#define COPY_FILE_RESTARTABLE 0x00000002
Public Const COPY_FILE_OPEN_SOURCE_FOR_WRITE As Long = &H4 '#define COPY_FILE_OPEN_SOURCE_FOR_WRITE 0x00000004
Public Declare Function GetLastError Lib "kernel32" () As Long
'CopyFileExA(LPCSTR lpExistingFileName, LPCSTR lpNewFileName, LPPROGRESS_ROUTINE lpProgressRoutine OPTIONAL, LPBOOL pbCancel OPTIONAL, DWORD dwCopyFlags);
Public Declare Function CopyFileExA Lib "kernel32" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal lpProgressRoutine As Long, ByVal lpData As Long, ByVal pbCancel As Long, ByVal dwCopyFlags As Long) As Boolean
Private bCancel As Boolean 'Cancel flag
Public Function CopyProgressRoutine(ByVal TotalFileSize As Currency, _
ByVal TotalBytesTransferred As Currency, _
ByVal StreamSize As Currency, _
ByVal StreamBytesTransferred As Currency, _
ByVal dwStreamNumber As Long, _
ByVal dwCallbackReason As Long, _
ByVal hSourceFile As Long, _
ByVal hDestinationFile As Long, _
lpData As Long) As Long
Debug.Print Round(StreamBytesTransferred / TotalFileSize * 100)
CopyProgressRoutine = PROGRESS_CONTINUE
End Function
Public Sub Main()
On Error GoTo ErrTrap
Dim lReturn As Long
Dim lLastDLLError As Long
Dim lLastGetError As Long
lReturn = CopyFileExA("C:\MyLargeSourceFile" & vbNullChar, _
"C:\MyLargeTargetFile" & vbNullChar, _
AddressOf CopyProgressRoutine, _
vbNull, _
VarPtr(bCancel), _
COPY_FILE_RESTARTABLE)
If lReturn = ERROR_SUCCESS Then
lLastDLLError = Err.LastDllError
lLastGetError = GetLastError()
MsgBox "GetLastError returned: " & lLastGetError & vbCrLf & "Err.LastDllError is: " & lLastDLLError
End If
Exit Sub
ErrTrap:
MsgBox Err.Number & " - " & Err.Description
End Sub
Hope it helps.
-
Thanks!
Thanks for the help. It works great.
Scott Shell
-
Oooh how funny Microsoft is.
They are stating information about win95/98 in the explanation of the parameters but it is not supported ;)
(Just something you folks might want to know)
