Need to display I/O progress dialog box

[SShell]

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

[SShell]

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.

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.

[SShell]

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)