Форум программистов [Powered by Invision Power Board]

Код

Option Explicit

Public Type LARGE_INTEGER
    LowPart As Long
    HiPart As Long
End Type

Public Type LARGE_INTEGER2
    QuardPart As Double
End Type

Public Declare Function CopyFileExW Lib "kernel32" (ByVal lpExistingFileName As Long, ByVal lpNewFileName As Long, ByVal lpRoutine As Long, ByVal lData As IUnknown, ByRef bCancel As Long, ByVal dwFlags As Long) As Long

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 Function CopyFileWithProgress(ByVal nSource As String, ByVal nDest As String, ByVal nForm As IUnknown) As Long
    Dim bCancel As Long
    CopyFileWithProgress = CopyFileExW(StrPtr(nSource), StrPtr(nDest), AddressOf CopyProgressRoutine, nForm, bCancel, 0)
End Function

Public Function CopyProgressRoutine(ByVal TotalFileSize As Double, ByVal TotalBytesTransferred As Double, ByVal StreamSize As Double, ByVal StreamBytesTransferred As Double, ByVal StreamNumber As Long, ByVal dwCallbackReason As Long, ByVal hSourceFile As Long, ByVal hDestinationFile As Long, ByVal lpData As IUnknown) As Long
    Dim nTotalSize As Single
    Dim nTotalBytesTransferred As Single
    nTotalSize = GetSingleFromLargeInteger(TotalFileSize)
    nTotalBytesTransferred = GetSingleFromLargeInteger(TotalBytesTransferred)
    If lpData Is Nothing Then
        'При неподходящий условиях продолжаем копирование, но не используем прогресс
        CopyProgressRoutine = PROGRESS_QUIET
    Else
        If TypeOf lpData Is Form1 Then
            Dim nFrm As Form1
            Set nFrm = lpData
            nFrm.ProgressBar1.Max = nTotalSize
            'Исключаем арифметические ошибки при преобразовании
            If nTotalBytesTransferred <= nTotalSize Then
                nFrm.ProgressBar1.Value = nTotalBytesTransferred
            Else
                nFrm.ProgressBar1.Value = nTotalSize
            End If
            nFrm.ProgressBar1.Refresh
            CopyProgressRoutine = PROGRESS_CONTINUE
        Else
            'При неподходящий условиях продолжаем копирование, но не используем прогресс
            CopyProgressRoutine = PROGRESS_QUIET
        End If
    End If
End Function

'Перблизительное преобразование LargeInteger в Single
Public Function GetSingleFromLargeInteger(ByVal nDouble As Double) As Single
    Dim nL2 As LARGE_INTEGER2, nL1 As LARGE_INTEGER
    nL2.QuardPart = nDouble
    LSet nL1 = nL2
    GetSingleFromLargeInteger = CSng(nL1.LowPart) + CSng(nL1.HiPart) * CSng(&H7FFFFFFF) * 2
End Function