Private Sub Command3_Click()
Dim Timenow As String
Dim Sfilename As String
Dim Dfilename As String
Timenow = Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) & Second(Now)
If Level <> 1 Then
MsgBox "你没有操作权限", 0, "注意"
Exit Sub
End If
CommonDialog1.DialogTitle = "请选择备份路径:"
CommonDialog1.Filename = Timenow & "(Backup).mdb"
CommonDialog1.Filter = "*.mdb(Access数据库)|*.mdb"
CommonDialog1.ShowSave
If CommonDialog1.Filename = "" Then Exit Sub
Dfilename = CommonDialog1.Filename
Sfilename = Thispath & "DataBase.mdb"
'读取数据库文件并在新的路径写入
Dim Filenum As Integer
Dim Filenum2 As Integer
Dim i As Integer
Dim n As Long
Dim Leftsize As Long
Dim cells() As Byte
Filenum = FreeFile
Open Sfilename For Binary As Filenum
ProBar.Visible = True
ProBar.Min = 0
ProBar.Max = LOF(Filenum)
n = LOF(Filenum) / 1024
Leftsize = LOF(Filenum) Mod 1024&
Filenum2 = FreeFile
Open Dfilename For Binary As Filenum2
ReDim cells(1024)
For i = 1 To n
Get Filenum, , cells
Put Filenum2, , cells
On Error Resume Next
ProBar.value = ProBar.value + 1024&
DoEvents
Next
If Left > 0 Then
ReDim cells(Left)
Get Filenum, , cells
Put Filenum2, , cells
On Error Resume Next
ProBar.value = ProBar.value + Leftsize&
End If
Close
ProBar.Visible = False
MsgBox "备份完成!", 0, "报告"
End Sub

谢谢大家了

谢谢楼上的大哥
小弟万分感谢！！！！