进度条如何才能正确显示COPY资料的进度

Question

在VB中进度条如何才能正确显示出COPY文件或文件夹的进度？
最好给予个例子：）

Answer 1

首先将文件的大小得到,我这台电脑没有装VB,所以只能凭记忆了!progressbar1.min=0
progressbar1.max=filelen
progressbar1.value=0for i=0 to filelen
    progressbar1.value=i
    ...................     '每复制一字节(byte),就I就加1,进度条也相应的进了!
    
next i

Answer 2

记得shfileoperation函数可以显示进度

Answer 3

'TextBox:
'Filepath
'Destinationpath'CommonDialog:
'Dialog'CommanButton:
'Browsefile
'Browsedestination
'Copy
'Cancel
Function CopyFile(Src As String, Dst As String) As Single
    Static Buf$
    Dim BTest!, FSize!
    Dim Chunk%, F1%, F2%    Const BUFSIZE = 1024    If Len(Dir(Dst)) Then
        Response = MsgBox(Dst + Chr(10) + Chr(10) + "File already exists. Do you want to overwrite it?", vbYesNo + vbQuestion)
        If Response = vbNo Then
            Exit Function
        Else
            Kill Dst
        End If
    End If
 
    On Error GoTo FileCopyError
    F1 = FreeFile
    Open Src For Binary As F1
    F2 = FreeFile
    Open Dst For Binary As F2
 
    FSize = LOF(F1)
    BTest = FSize - LOF(F2)    Do
        If BTest < BUFSIZE Then
            Chunk = BTest
        Else
            Chunk = BUFSIZE
        End If
      
        Buf = String(Chunk, " ")
        Get F1, , Buf
        Put F2, , Buf
        BTest = FSize - LOF(F2)        ProgressBar.Value = (100 - Int(100 * BTest / FSize))    Loop Until BTest = 0
    Close F1
    Close F2
    CopyFile = FSize
    ProgressBar.Value = 0
    Exit FunctionFileCopyError:
    MsgBox "Copy Error!, Please try again..."
    Close F1
    Close F2
    Exit Function
End FunctionPublic Function ExtractName(SpecIn As String) As String
    Dim i As Integer
    Dim SpecOut As String
   
    On Error Resume Next
    For i = Len(SpecIn) To 1 Step -1
        If Mid(SpecIn, i, 1) = "\" Then
            SpecOut = Mid(SpecIn, i + 1)
            Exit For
        End If
    Next
    ExtractName = SpecOut
End FunctionPrivate Sub Browsedestination_Click()
    Dim bi As BROWSEINFO
    Dim rtn&, pidl&, path$, pos%    bi.hOwner = Me.hWnd
    bi.lpszTitle = "Browse for Destination..."
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    pidl& = SHBrowseForFolder(bi)
  
    path = Space(512)
    T = SHGetPathFromIDList(ByVal pidl&, ByVal path)    pos% = InStr(path$, Chr$(0))
    SpecIn = Left(path$, pos - 1)    If Right$(SpecIn, 1) = "\" Then
        SpecOut = SpecIn
    Else
        SpecOut = SpecIn + "\"
    End If    Destinationpath.Text = SpecOut + ExtractName(Filepath.Text)
End SubPrivate Sub Browsefile_Click()
    Dialog.DialogTitle = "Browse for source..."
    Dialog.ShowOpen
    Filepath.Text = Dialog.FileName
End SubPrivate Sub Cancel_Click()
    Unload Me
End SubPrivate Sub Copy_Click()
    On Error Resume Next
    If Filepath.Text = "" Then
        MsgBox "You must specify a file and path in the text box provided", vbCritical
        Exit Sub
    End If
    If Destinationpath.Text = "" Then
        MsgBox "You must specify a destination path in the text box provided", vbCritical
        Exit Sub
    End If
    ProgressBar.Value = CopyFile(Filepath.Text, Destinationpath.Text)
End SubPrivate Sub filepath_Change()
    Destinationpath.Enabled = True
    Browsedestination.Enabled = True
    Destinationpath.SetFocus
End SubPrivate Sub Form_Load()
    Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2 'centre the form on the screen
End Sub
'模块Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
    "SHGetPathFromIDListA" (ByVal pidl As Long, _
    ByVal pszPath As String) As Long
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
    (ByVal hwndOwner As Long, ByVal nFolder As Long, _
    pidl As ITEMIDLIST) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
    "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongType SHITEMID
     cb As Long
     abID As Byte
End TypeType ITEMIDLIST
     mkid As SHITEMID
End TypeType BROWSEINFO
     hOwner As Long
     pidlRoot As Long
     pszDisplayName As String
     lpszTitle As String
     ulFlags As Long
     lpfn As Long
     lParam As Long
     iImage As Long
End TypePublic Const NOERROR = 0Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000

Answer 4

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form CopyFile 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "备份数据"
   ClientHeight    =   3135
   ClientLeft      =   3330
   ClientTop       =   3210
   ClientWidth     =   4830
   Icon            =   "CopyFile.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   3135
   ScaleWidth      =   4830
   Begin VB.CommandButton Copy 
      Caption         =   "备份"
      Height          =   375
      Left            =   2520
      TabIndex        =   5
      Top             =   2400
      Width           =   975
   End
   Begin VB.CommandButton Command1 
      Caption         =   "退出"
      Height          =   375
      Left            =   3600
      TabIndex        =   4
      Top             =   2400
      Width           =   975
   End
   Begin VB.TextBox Filepath 
      Height          =   285
      Left            =   240
      TabIndex        =   3
      Top             =   480
      Width           =   3255
   End
   Begin VB.CommandButton Browsefile 
      Caption         =   "from"
      Height          =   375
      Left            =   3600
      TabIndex        =   2
      Top             =   480
      Width           =   975
   End
   Begin VB.TextBox Destinationpath 
      Enabled         =   0   'False
      Height          =   285
      Left            =   240
      TabIndex        =   1
      Top             =   1080
      Width           =   3255
   End
   Begin VB.CommandButton copytopath 
      Caption         =   "To"
      Enabled         =   0   'False
      Height          =   375
      Left            =   3600
      TabIndex        =   0
      Top             =   1080
      Width           =   975
   End
   Begin MSComDlg.CommonDialog Dialog 
      Left            =   360
      Top             =   2400
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      Flags           =   6148
   End
   Begin ComctlLib.ProgressBar copybar 
      Height          =   375
      Left            =   300
      TabIndex        =   9
      Top             =   1830
      Width           =   4095
      _ExtentX        =   7223
      _ExtentY        =   661
      _Version        =   327682
      Appearance      =   1
   End
   Begin VB.Label Label3 
      AutoSize        =   -1  'True
      Caption         =   "Percent complete:"
      Height          =   195
      Left            =   360
      TabIndex        =   6
      Top             =   1545
      Width           =   1290
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "要备份的数据路径:"
      Height          =   180
      Left            =   240
      TabIndex        =   8
      Top             =   240
      Width           =   1530
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "备份数据的路径:"
      Height          =   180
      Left            =   240
      TabIndex        =   7
      Top             =   840
      Width           =   1350
   End
End
Attribute VB_Name = "CopyFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = FalseFunction CopyFile(Src As String, Dst As String) As Single
    Static Buf As String
    Dim needsize, Fizesize As Single
    Dim Chunk, i2, i1 As Integer    Const BUFizesize = 1024    If Len(Dir(Dst)) Then
        Response = MsgBox(Dst + Chr(10) + Chr(10) + "文件已存在，覆盖吗？", vbYesNo + vbQuestion) 'prompt the user with a message box
        If Response = vbNo Then
            Exit Function
        Else
            '如果文件存在，先删除文件
            Kill Dst
        End If
    End If
   ' On Error GoTo FileCopyError
    i1 = FreeFile
    Open Src For Binary As i1
    i2 = FreeFile
    Open Dst For Binary As i2
    
    Fizesize = LOF(i1)
    needsize = Fizesize - LOF(i2)
    Do
        If needsize < BUFizesize Then
            Chunk = needsize
        Else
            Chunk = BUFizesize
        End If
      
        Buf = String(Chunk, " ")
        Get i1, , Buf
        Put i2, , Buf
        needsize = Fizesize - LOF(i2)
        '显示copy进程
        copybar.Value = (100 - Int(100 * needsize / Fizesize))    Loop Until needsize = 0
    Close i1
    Close i2
    CopyFile = Fizesize
    copybar.Value = 0
    Exit FunctionFileCopyError:
    MsgBox "拷贝没有完成"
    Close i1
    Close i2
    Exit FunctionEnd Function
Public Function getpath(inpath As String) As String
   
    Dim i As Integer
    Dim outpath As String
   
    On Error Resume Next
   
    For i = Len(inpath) To 1 Step -1
        If Mid(inpath, i, 1) = "\" Then
            outpath = Mid(inpath, i + 1)
            Exit For
        End If
    Next i    getpath = outpathEnd FunctionPrivate Sub copytopath_Click()
    Dim br As BROWSEINFO
    Dim hhh, ppp As Long
    Dim path As String
    Dim pos As Integer    br.hOwner = Me.hWnd
    br.lpszTitle = "目标路径"
    br.ulFlags = brF_RETURNONLYFSDIRS
    ppp = SHBrowseForFolder(br)
  
    path = Space(512)
    T = SHGetPathFromIDList(ByVal ppp, ByVal path)    pos = InStr(path, Chr$(0))
    inpath = Left(path, pos - 1)    If Right$(inpath, 1) = "\" Then
        outpath = inpath
    Else
        outpath = inpath + "\"
    End If
    Destinationpath.Text = outpath + getpath(Filepath.Text)
End SubPrivate Sub Browsefile_Click()
    Dialog.DialogTitle = "源文件路径"
    Dialog.ShowOpen
    Filepath.Text = Dialog.Filename
End SubPrivate Sub Command1_Click()
  Unload Me
End SubPrivate Sub Copy_Click()
    On Error Resume Next    If Filepath.Text = "" Then
        MsgBox "你没有选择拷贝文件", vbCritical
        Exit Sub
    End If
    If Destinationpath.Text = "" Then
        MsgBox "你没有选择目标路径", vbCritical
        Exit Sub
    End If    copybar.Value = CopyFile(Filepath.Text, Destinationpath.Text)
End SubPrivate Sub filepath_Change()
    Destinationpath.Enabled = True
    copytopath.Enabled = True
 '   Destinationpath.SetFocus
End Sub
Private Sub Form_Load()
  Filepath.Text = "c:\ndr20001229\sftcc.mdb"
  Destinationpath.Text = "c:\ndr20001229\backup\sftcc.mdb"
End Sub