| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 2347 人关注过本帖
标题:进度条的问题
只看楼主 加入收藏
huangyz_xy
Rank: 2
等 级:论坛游民
帖 子:101
专家分:30
注 册:2016-10-2
结帖率:77.78%
收藏
 问题点数:0 回复次数:6 
进度条的问题
我想在这段代码加一个progressbar显示进度,看了好多例子也没有成功!哪位热心的神帮个忙,先谢!
Private Sub Cmd_Mail_Click()
   Call Find    '这个过程有文件的复制功能
   SendMail Date & "系统库文件", "请注意查收并保存", "D:\database.mdb"
 Kill "D:\database.mdb"
End Sub
2016-12-24 12:13
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:0 
看这段代码,是在
Call Find    '这个过程有文件的复制功能
这个过程里添加这个功能

授人于鱼,不如授人于渔
早已停用QQ了
2016-12-24 23:16
xzlxzlxzl
Rank: 15Rank: 15Rank: 15Rank: 15Rank: 15
来 自:湖北
等 级:贵宾
威 望:125
帖 子:1091
专家分:5825
注 册:2014-5-3
收藏
得分:0 
如果是用filecopy函数实现的文件拷贝,是无法加入进度条的。好像用fso的方法可以获得一个类似于在windows下拷贝文件的进度条,不需要你用控件,系统自己自动给出的。如果用api自己实现,那就使用CopyFileEx,实现其CopyProgressRoutine回调函数。
2016-12-24 23:38
huangyz_xy
Rank: 2
等 级:论坛游民
帖 子:101
专家分:30
注 册:2016-10-2
收藏
得分:0 
回复 2楼 风吹过b
应该是发邮件这个过程耗时最长吧!该怎么加呢?
2016-12-25 09:58
wube
Rank: 12Rank: 12Rank: 12
等 级:贵宾
威 望:23
帖 子:1820
专家分:3681
注 册:2011-3-24
收藏
得分:0 
我记得之前用这个API可以有进度条~
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

不要選我當版主
2016-12-26 11:27
wube
Rank: 12Rank: 12Rank: 12
等 级:贵宾
威 望:23
帖 子:1820
专家分:3681
注 册:2011-3-24
收藏
得分:0 
另一个顺便~
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

不要選我當版主
2016-12-26 11:28
wube
Rank: 12Rank: 12Rank: 12
等 级:贵宾
威 望:23
帖 子:1820
专家分:3681
注 册:2011-3-24
收藏
得分:0 
很久以前做的一部分代码~给你参考看看~

程序代码:
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


不要選我當版主
2016-12-26 11:43
快速回复:进度条的问题
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.031386 second(s), 8 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved