小弟以前租碟在电脑上看VCD，有时候拷贝经典的影片到硬盘上
可惜碰到比较粗糙的碟子就很难拷贝过去，因此编了个断点拷贝
文件的程序。本程序用于拷贝大文件，并可在旧文件上接着拷贝
本程序能在无法读取数据的情况下复制空白数据并跳过坏数据区
接着拷贝，专门对付烂盘.
本程序特别适合在恶劣的环境下拷贝大文件，比如拷盘，在网络中拷
大文件等。
本程序是一个VB程序，包括5个文件，主窗口为 frmCopy
使用了 Microsoft Common Dialog Control6.0 和
Micorsoft Windows Common Controls 6.0 两个控件库
拷贝文件使用了Win32API,速度比较快。
###############################################################################
frmCopy.frm 内容
###############################################################################
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmCopy
Caption = "断点拷贝"
ClientHeight = 3555
ClientLeft = 60
ClientTop = 345
ClientWidth = 9135
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 3555
ScaleWidth = 9135
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox TextStart
Height = 300
Left = 6330
TabIndex = 17
Text = "-1"
Top = 735
Width = 1410
End
Begin VB.PictureBox picStatus
Appearance = 0 'Flat
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 195
Left = 75
ScaleHeight = 165
ScaleWidth = 150
TabIndex = 14
Top = 3075
Width = 180
End
Begin VB.CheckBox chkFillData
Caption = "遇到错误时自动填充空白数据"
Height = 225
Left = 6090
TabIndex = 13
Top = 405
Value = 1 'Checked
Width = 2670
End
Begin VB.CheckBox chkShutdown
Caption = "完成任务后关机"
Height = 315
Left = 6090
TabIndex = 12
Top = 45
Width = 1680
End
Begin VB.CommandButton cmdCopy
Caption = "开始拷贝(&S)"
Height = 360
Left = 6225
TabIndex = 10
Top = 2535
Width = 1170
End
Begin VB.CommandButton cmdStop
Caption = "停止"
Height = 360
Left = 6255
TabIndex = 9
Top = 3015
Width = 1170
End
Begin MSComctlLib.ProgressBar myProc
Height = 360
Left = 270
TabIndex = 7
Top = 2985
Width = 5385
_ExtentX = 9499
_ExtentY = 635
_Version = 393216
Appearance = 1
Scrolling = 1
End
Begin MSComDlg.CommonDialog dlgFile
Left = 5265
Top = 1395
_ExtentX = 847
_ExtentY = 847
_Version = 393216
CancelError = -1 'True
End
Begin VB.CommandButton cmdTo
Caption = "..."
Height = 345
Left = 5235
TabIndex = 5
Top = 1005
Width = 510
End
Begin VB.CommandButton cmdFrom
Caption = "..."
Height = 375
Left = 5250
TabIndex = 4
Top = 270
Width = 510
End
Begin VB.TextBox textTo
Height = 345
Left = 975
TabIndex = 3
Top = 1005
Width = 4245
End
Begin VB.TextBox textFrom
Height = 375
Left = 975
TabIndex = 1
Top = 270
Width = 4260
End
Begin VB.Label Label3
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "从 KB处开始拷贝"
Height = 180
Left = 6090
TabIndex = 16
Top = 780
Width = 2790
End
Begin VB.Label lblBlank
BackStyle = 0 'Transparent
Caption = "空白数据"
Height = 180
Left = 285
TabIndex = 15
Top = 2760
Width = 5070
End
Begin VB.Label lblSpeed
BackStyle = 0 'Transparent
Caption = "速度"
Height = 180
Left = 285
TabIndex = 11
Top = 2475
Width = 5070
End
Begin VB.Label lblTotal
BackStyle = 0 'Transparent
Caption = "总计"
Height = 180
Left = 285
TabIndex = 8
Top = 1890
Width = 5070
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = "状态"
Height = 180
Left = 285
TabIndex = 6
Top = 2175
Width = 5070
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "目标文件:"
Height = 180
Left = 105
TabIndex = 2
Top = 1050
Width = 810
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "源文件:"
Height = 180
Left = 135
TabIndex = 0
Top = 315
Width = 630
End
End
Attribute VB_Name = "frmCopy"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
'Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, ByVal lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function SetEndOfFile Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function StrFormatByteSize Lib "shlwapi" Alias _
"StrFormatByteSizeA" (ByVal dw As Long, ByVal pszBuf As String, ByRef _
cchBuf As Long) As String
'Private Type OVERLAPPED
' Internal As Long
' InternalHigh As Long
' offset As Long
' OffsetHigh As Long
' hEvent As Long
'End Type
Private Const OFS_MAXPATHNAME = 128
Private Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type
Private Const OF_CREATE = &H1000
Private Const OF_WRITE = &H1
Private Const OF_READ = &H0
Private Const FILE_END = 2
Private Const FILE_BEGIN = 0
Private bolStop As Boolean
Private bolReady As Boolean
Private myCount As clsCount
Private myIni As clsIniFile
Private bolUnload As Boolean
Private Sub cmdCopy_Click()
Call SetControl(True)
Call CopyFile
Call SetControl(False)
If chkShutdown.Value = 1 Then
dlgShutDown.Show vbModal
End If
End Sub
Private Sub cmdFrom_Click()
On Error Resume Next
dlgFile.FileName = textFrom.Text
dlgFile.ShowOpen
If Err.Number = 0 Then
textFrom.Text = dlgFile.FileName
End If
On Error GoTo 0
End Sub
Private Sub cmdStop_Click()
Call SetControl(False)
End Sub
Private Sub cmdTo_Click()
On Error Resume Next
dlgFile.FileName = textTo.Text
dlgFile.ShowOpen
If Err.Number = 0 Then
textTo.Text = dlgFile.FileName
End If
lblInfo.Enabled = True
On Error GoTo 0
End Sub
Private Sub Form_Load()
Set myCount = New clsCount
Set myIni = New clsIniFile
myIni.IniFileName = "Copy.ini"
myIni.CurrentSection = "Copy"
textFrom.Text = myIni.IniString("From")
textTo.Text = myIni.IniString("To")
bolStop = False
bolReady = True
bolUnload = True
Call SetControl(False)
End Sub
Private Sub SetControl(bolCopying As Boolean)
Dim myCtl As Control
On Error Resume Next
For Each myCtl In Controls
myCtl.Enabled = Not bolCopying
If TypeOf myCtl Is Label Then
myCtl.Enabled = True
End If
Next myCtl
cmdStop.Enabled = bolCopying
bolStop = Not bolCopying
End Sub
Private Sub CopyFile()
Dim lngFrom As Long
Dim lngTo As Long
Const c_BufSize As Long = 8 * 1024
Dim myResult As OFSTRUCT
'Dim myOverLapped As OVERLAPPED
Dim lngTotal As Long
Dim lngCurrent As Long
Dim lngCopy As Long
Dim buf(0 To c_BufSize - 1) As Byte
Dim lCount As Long
Dim lBlankCount As Long
Dim strRate As String
Dim lStart As Long
bolReady = False
On Error Resume Next
On Error GoTo CopyErr
lngTotal = FileLen(textFrom.Text)
lblTotal.Caption = "共计 " & VBStrFormatByteSize(lngTotal)
lngFrom = OpenFile(textFrom.Text, myResult, OF_READ)
'If myResult.nErrCode > 0 Then
' Err.Raise 0, , "打开源文件错误，文件:" & textFrom.Text & " 错误号:" & myResult.nErrCode
'End If
If Dir(textTo.Text) = "" Then
lngTo = OpenFile(textTo.Text, myResult, OF_CREATE)
lngCurrent = 0
Else
lngCurrent = FileLen(textTo.Text)
lStart = CLng(TextStart.Text) * 1024
lngTo = OpenFile(textTo.Text, myResult, OF_WRITE)
If lStart > 0 And lngCurrent > lStart Then
SetFilePointer lngTo, lStart, 0, FILE_BEGIN
lngCurrent = lStart
Else
Call SetFilePointer(lngTo, 0, 0, FILE_END)
End If
End If
'If myResult.nErrCode > 0 Then
' Err.Raise 0, , "打开目标文件错误，文件:" & textFrom.Text & " 错误号:" & myResult.nErrCode
'End If
If lngCurrent >= lngTotal Then
bolStop = True
Else
If lngCurrent > 0 Then
SetFilePointer lngFrom, lngCurrent, 0, FILE_BEGIN
End If
bolStop = False
End If
myCount.Clear
bolUnload = False
lBlankCount = 0
lblBlank.Caption = ""
Do
If bolStop = True Then GoTo CopyExit
'picStatus.BackColor = Me.BackColor
ReadFile lngFrom, VarPtr(buf(0)), c_BufSize, lngCopy, 0
If lngCopy <> c_BufSize And lngCurrent <> lngTotal And lngCurrent + lngCopy <> lngTotal Then
If chkFillData.Value = 1 Then
For lCount = 0 To c_BufSize - 1
buf(lBlankCount) = &HFF
Next lCount
lBlankCount = lBlankCount + 1
lngCopy = lngTotal - lngCurrent
lblBlank.Caption = "填充空白数据:" & VBStrFormatByteSize(lBlankCount * c_BufSize)
If lngCopy > c_BufSize Then
lngCopy = c_BufSize
End If
picStatus.BackColor = vbRed
SetFilePointer lngFrom, lngCurrent + lngCopy, 0, FILE_BEGIN
Else
Exit Do
End If
Else
picStatus.BackColor = vbGreen
End If
WriteFile lngTo, VarPtr(buf(0)), lngCopy, lngCopy, 0
lngCurrent = lngCurrent + lngCopy
myCount.Count lngCopy
'** 设置进度信息
strRate = Format(lngCurrent / lngTotal, "0.00%")
lblInfo.Caption = "目前完成 " _
& VBStrFormatByteSize(lngCurrent) & "(" & strRate & ")"
If myCount.NewSpeed Then
lblSpeed.Caption = "速度:" & VBStrFormatByteSize(myCount.Speed) & "/秒"
End If
Me.Caption = strRate
If lngCurrent * 100# / lngTotal > 100 Then
myProc.Value = 100
Else
myProc.Value = lngCurrent * 100# / lngTotal
End If
DoEvents
Loop Until lngCopy <> c_BufSize
CopyExit:
CloseHandle lngFrom
CloseHandle lngTo
lblInfo.Caption = "共拷贝 " & VBStrFormatByteSize(lngCurrent) & ",所花时间 " & myCount.TotalTickCount & " 毫秒"
lblSpeed.Caption = "平均速度: " & VBStrFormatByteSize(myCount.TotalSpeed) & " 字节/秒"
myProc.Value = 0
bolReady = True
If bolUnload = True Then
Unload Me
End If
bolUnload = True
On Error GoTo 0
Exit Sub
CopyErr:
MsgBox "系统错误:" & Err.Description, vbCritical
'Resume
If lngFrom <> 0 Then CloseHandle lngFrom
If lngTo <> 0 Then CloseHandle lngTo
bolReady = True
If bolUnload = True Then
Unload Me
End If
On Error GoTo 0
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If bolUnload = False Then
bolUnload = True
bolStop = True
Cancel = True
Else
myIni.IniString("From") = textFrom.Text
myIni.IniString("To") = textTo.Text
Set myCount = Nothing
Set myIni = Nothing
End
End If
End Sub
Private Function VBStrFormatByteSize(ByVal lngSize As Long) As String
Dim strSize As String * 128
Dim strData As String
Dim lPos As Long
StrFormatByteSize lngSize, strSize, 128
lPos = InStr(1, strSize, Chr$(0))
strData = Left$(strSize, lPos - 1)
If lngSize > 1024 Then
strData = lngSize & "字节(" & strData & ")"
End If
VBStrFormatByteSize = strData
End Function
###############################################################################
dlgShutDown.frm 内容
###############################################################################
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form dlgShutDown
BorderStyle = 3 'Fixed Dialog
Caption = "关机"
ClientHeight = 3195
ClientLeft = 2760
ClientTop = 3750
ClientWidth = 6735
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3195
ScaleWidth = 6735
ShowInTaskbar = 0 'False
StartUpPosition = 2 '屏幕中心
Begin VB.Timer myTimer
Interval = 1000
Left = 6075
Top = 915
End
Begin MSComctlLib.ProgressBar myProc
Height = 390
Left = 180
TabIndex = 2
Top = 1980
Width = 6120
_ExtentX = 10795
_ExtentY = 688
_Version = 393216
Appearance = 1
End
Begin VB.CommandButton cmdCancel
Caption = "取消"
Height = 375
Left = 4950
TabIndex = 1
Top = 2640
Width = 1215
End
Begin VB.CommandButton cmdShutDown
Caption = "关机"
Height = 375
Left = 3510
TabIndex = 0
Top = 2640
Width = 1215
End
Begin VB.Label lblTitle
Caption = "Label1"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 390
Left = 480
TabIndex = 3
Top = 795
Width = 5190
End
End
Attribute VB_Name = "dlgShutDown"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Private Const EWX_SHUTDOWN = 1
Private Const cTimeCount As Long = 15
Private lngCount As Long
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdShutDown_Click()
ExitWindowsEx EWX_SHUTDOWN, 0
End Sub
Private Sub Form_Load()
Dim myWin As New clsWindow
myWin.hwnd = Me.hwnd
myWin.TopMost = True
Set myWin = Nothing
lngCount = cTimeCount
myProc.Max = cTimeCount
myProc.Min = 0
Call myTimer_Timer
End Sub
Private Sub myTimer_Timer()
lngCount = lngCount - 1
myProc.Value = cTimeCount - lngCount
lblTitle.Caption = lngCount & "秒后关机"
If lngCount = 0 Then
ExitWindowsEx EWX_SHUTDOWN, 0
lngCount = cTimeCount
End If
End Sub
###############################################################################
mdlCopy.bas 内容
###############################################################################
Attribute VB_Name = "mdlCopy"
Option Explicit
Public Const c_NullID As Long = -9999
###############################################################################
clsCount.cls 内容
###############################################################################
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsCount"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'******************************************************************************
'**
'** 用于计算速度的类模块
'**
'** 该类模块设定一个计数器,由程序不断的累计数据,并根据所花时间计算数据
'**
'** 编制: 袁永福
'** 时间: 2002-4-2
'**
'******************************************************************************
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private lngCountStart As Long
Private lngCountCurrent As Long
Private lngCountLast As Long
Private lngSpeed As Long
Private lngTickStart As Long
Private lngTickCurrent As Long
Private lngTickLast As Long
'Public StopCount As Boolean
'** 获得计数数据 **************************************************************
'** 累计初始值
Public Property Get CountStart() As Long
CountStart = lngCountStart
End Property
'** 累计终止值
Public Property Get CountEnd() As Long
CountEnd = lngCountCurrent
End Property
'** 累计总的速度
Public Property Get TotalSpeed() As Long
If lngTickCurrent = lngTickStart Then
TotalSpeed = 0
Else
TotalSpeed = (lngCountCurrent - lngCountStart) / ((lngTickCurrent - lngTickStart) / 1000)
End If
End Property
'** 累计所花毫秒数
Public Property Get TotalTickCount() As Long
TotalTickCount = lngTickCurrent - lngTickStart
End Property
'** 清除所有数据 **************************************************************
Public Sub Clear()
lngCountStart = 0
lngCountCurrent = 0
lngCountLast = 0
lngSpeed = 0
lngTickStart = GetTickCount()
lngTickCurrent = lngTickStart
lngTickLast = lngTickStart
'StopCount = False
End Sub
'** 设置累计基数
Public Property Let CountStart(ByVal lStart As Long)
lngCountStart = lStart
lngCountCurrent = lStart
End Property
'** 累加数据 **
Public Sub Count(Optional ByVal lCount As Long = 1)
lngCountCurrent = lngCountCurrent + lCount
lngTickCurrent = GetTickCount()
End Sub
'** 获得速度 **
Public Property Get Speed() As Long
'lngTickCurrent = GetTickCount()
If lngTickLast = lngTickCurrent Then
Speed = lngSpeed
Else
Speed = (lngCountCurrent - lngCountLast) / ((lngTickCurrent - lngTickLast) / 1000)
lngSpeed = Speed
lngTickLast = lngTickCurrent
lngCountLast = lngCountCurrent
End If
End Property
'** 数据是否是最新更新的 **
Public Property Get NewSpeed() As Boolean
Dim bolNew As Boolean
If lngTickCurrent > lngTickLast + 1000 Then
bolNew = True
Else
bolNew = False
End If
NewSpeed = bolNew
End Property
'** 本模块结束 ****************************************************************
###############################################################################
clsIniFile.cls 内容
###############################################################################
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsIniFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes&quot