进度条的问题

Option Explicit

Private Const PROGRESS_CANCEL = 1
Private Const PROGRESS_CONTINUE = 0
Private Const PROGRESS_QUIET = 3
Private Const PROGRESS_STOP = 2
Private Const COPY_FILE_FAIL_IF_EXISTS = &H1
Private Const COPY_FILE_RESTARTABLE = &H2

Private Const MOVEFILE_REPLACE_EXISTING = &H1   '相同的Volume下移动文件用
Private Const MOVEFILE_COPY_ALLOWED = &H2       '不同的Volume下移动文件用

'// 此 API 在 WIN9X 下不能使用
Private Declare Function CopyFileEx Lib "kernel32.dll" Alias "CopyFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal lpProgressRoutine As Long, lpData As Any, ByRef pbCancel As Long, ByVal dwCopyFlags As Long) As Long
'Private Declare Function CopyFileEx Lib "kernel32.dll" Alias "CopyFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByRef lpProgressRoutine As PROGRESS_ROUTINE, lpData As Any, ByRef pbCancel As Long, ByVal dwCopyFlags As Long) As Long
'Private Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) As Long
Private Declare Function MoveFileWithProgress Lib "kernel32.dll" Alias "MoveFileWithProgressA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByRef lpProgressRoutine As Long, lpData As Any, ByVal dwFlags As Long) As Long
'Private Declare Function MoveFileWithProgress Lib "kernel32.dll" Alias "MoveFileWithProgressA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByRef lpProgressRoutine As PROGRESS_ROUTINE, lpData As Any, ByVal dwFlags As Long) As Long

Private mlngCancel  As Long
Private mprgState   As Object
Private mlblState   As Object

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, _
                        ByVal lpData As Long) As Long
  
    '// 显示进度
    mprgState.value = CLng((100 / TotalFileSize) * TotalBytesTransferred)
    mlblState.Caption = "已完成: " & FormatPercent(mprgState.value / 100, 0)
    '
    DoEvents
    '// 继续复制
    CopyProgressRoutine = PROGRESS_CONTINUE

End Function

Public Function uCopyFile(ByVal strFrom As String, ByVal strTo As String, ByRef prgState As Object, ByRef lblState As Object) As Boolean
Dim lngReturn As Long

    Set mprgState = prgState
    Set mlblState = lblState
  
    '// 开始复制
    lngReturn = CopyFileEx(strFrom, strTo, AddressOf CopyProgressRoutine, ByVal 0&, mlngCancel, COPY_FILE_RESTARTABLE)

    If lngReturn = 0 Then
        uCopyFile = False
    Else
        uCopyFile = True
    End If
  
End Function

Public Function uMoveFile(ByVal strFrom As String, ByVal strTo As String, ByRef prgState As Object, ByRef lblState As Object) As Boolean
Dim lngReturn As Long

    Set mprgState = prgState
    Set mlblState = lblState
  
    '// 开始移动
    lngReturn = MoveFileWithProgress(strFrom, strTo, AddressOf CopyProgressRoutine, Null, MOVEFILE_COPY_ALLOWED)
  
    If lngReturn = 0 Then
      uMoveFile = False
    Else
      uMoveFile = True
    End If

End Function

Public Function FTPCopy(ByVal Mode As Long, ByVal strFrom As String, ByVal strTo As String, ByRef prgState As Object, ByRef lblState As Object, vTransferMode As FtpTransferModes) As Boolean
Dim strFileName As String, TempString As String, TargetPath As String, TargetPath1 As String
Dim lStartPoint As Long
  
On Error GoTo ErrorHandling
  
    ChangFolder = False: TargetPath = "/" & "On_line_Trigger"
  
    If Mode = 0 Then
        TargetPath1 = "Copy_log"
    ElseIf Mode = 1 Then
        TargetPath1 = "Backup_log"
    End If
  
    If Len(strFrom) = 0 Then
        TempString = strFrom & " can't be Found ."
        Call ErrorWriteBuff(strFrom, 0, "FTPCopy", Err.Number, Err.Description, TempString)
        Exit Function
    End If
  
    strFileName = Mid$(strFrom, InStrRev(strFrom, "\") + 1)
  
    If Len(LotNumber) > 0 Then

        If ChangFolder = False Then
            If frmMain.m_FtpConnection.SetCurrentDirectory(TargetPath) = True Then
                If frmMain.m_FtpConnection.SetCurrentDirectory(TargetPath1) = True Then
                    If CreateLotNumber(Mode) = False Then
                        If frmMain.m_FtpConnection.CreateDirectory(LotNumber) = False Then
'                            TempString = "Can't create new directory." '& vbCrLf & vbCrLf & "Server response: " & frmMain.m_FtpConnection.GetLastServerResponse & ", , Can't create directory"
'                            Call ErrorWriteBuff(strFileName, 0, "FTPCopy", Err.Number, Err.Description, TempString)
                            CreateLotNumber(Mode) = True
                        End If
                    End If
                  
                    ChangFolder = frmMain.m_FtpConnection.SetCurrentDirectory(LotNumber)
                  
                Else
                    TempString = TargetPath & TargetPath1 & "/ Folder is Empty !"
                    Call ErrorWriteBuff(strFileName, 0, "FTPCopy", Err.Number, Err.Description, TempString)
                End If
            Else
                TempString = TargetPath & " not Found !"
                Call ErrorWriteBuff(strFileName, 0, "FTPCopy", Err.Number, Err.Description, TempString)
            End If
        End If
      
        If ChangFolder = True Then
      
            m_lFileSize = FileLen(strFrom)
            m_strFile = strFileName
         
            If frmMain.m_FtpConnection.UploadFile(strFrom, strFileName, vTransferMode, lStartPoint) = True Then
                FTPCopy = True ': Debug.Print "vTransferMode = " & vTransferMode
            Else
                FTPCopy = False
                TempString = "Can't upload file." & vbCrLf & vbCrLf & "Server response: " & frmMain.m_FtpConnection.GetLastServerResponse & ", , Can't upload file"
                Call ErrorWriteBuff(strFileName, 0, "FTPCopy", Err.Number, Err.Description, TempString)
            End If

        End If
      
    End If
  
Exit Function
  
ErrorHandling:
    FTPCopy = False: TempString = "FTPCopy Error"
    Call ErrorWriteBuff(strFileName, 0, "FTPCopy", Err.Number, Err.Description, TempString)
    Resume Next
End Function