进度条的问题
我想在这段代码加一个progressbar显示进度,看了好多例子也没有成功!哪位热心的神帮个忙,先谢!Private Sub Cmd_Mail_Click()
Call Find '这个过程有文件的复制功能
SendMail Date & "系统库文件", "请注意查收并保存", "D:\database.mdb"
Kill "D:\database.mdb"
End Sub
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