小弟以前租碟在电脑上看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"
Attribute VB_Ext_KEY = "Top_Level" , "Yes"
Option Explicit
'******************************************************************************
'**
'** INI文件操作类模块
'**
'** 本模块定义了INI文件读写的API操作及中间的数据转化
'**
'** 编制: 袁永福
'** 时间: 2001-12-11
'**
'** 该模块在配第5版补丁的VB6.0企业版/Windows98第二版的环境下调试通过
'**
'******************************************************************************
'** 定义变量 **
Public IniFileName As String ' 当前的配置文件名
Public CurrentSection As String ' 当前的类别
Public CurrentData As String ' 当前值
' Public AutoSave As Boolean ' 是否自动保存
'** 声明API函数 **
Private Declare Function GetPrivateProfileString& Lib "kernel32" Alias _
"GetPrivateProfileStringA" _
(ByVal lpAppName$, _
ByVal lpKeyName$, _
ByVal lpDefault$, _
ByVal lpRetStr$, _
ByVal nSize&, _
ByVal lpFileName$ )
Private Declare Function GetPrivateProfileInt& Lib "kernel32" Alias _
"GetPrivateProfileIntA" _
(ByVal lpAppName$, _
ByVal lpKeyName$, _
ByVal nDefault&, _
ByVal lpFileName$ )
Private Declare Function WritePrivateProfileString& Lib "kernel32" Alias _
"WritePrivateProfileStringA" _
(ByVal lpAppName$, _
ByVal lpKeyName$, _
ByVal lpString$, _
ByVal lpFileName$ )
'******************************************************************************
'************* 定义读写配置文件的接口函数 ***********************
'******************************************************************************
'** 从系统配置文件中读取相应配置字符串
Public Function GetIniStr(ByVal sSection As String, _
ByVal sKey As String, _
Optional ByVal sDefault As String = "") As String
Dim sReturnStr As String
Dim lTemp As Long
sReturnStr = Space(1024 )
'此处虽然设定在读不成功时为NONE,但绝对不会为NONE(webpaul)
GetPrivateProfileString sSection, sKey, sDefault, _
sReturnStr, 1024, IniFileName
sReturnStr = Trim$(sReturnStr )
lTemp = LenB(sReturnStr )
If lTemp > 0 Then
sReturnStr = Trim(MidB(sReturnStr, 1, lTemp - 1 ))
End If
If sReturnStr = "" Then
sReturnStr = sDefault
End If
GetIniStr = sReturnStr
End Function
'** 从系统配置文件中读取相应配置数值
Public Function GetIniNum(ByVal sSection As String, _
ByVal sKey As String, _
Optional ByVal lDefault As Long = c_NullID) As Long
Dim lReturn As Long
lReturn = GetPrivateProfileInt(sSection, sKey, lDefault, IniFileName )
GetIniNum = lReturn
End Function
'** 从配置文件中读取Boolean类型变量的设置
Public Function GetIniBoolean _
(ByVal strSection As String, _
ByVal strKey As String, _
Optional ByVal bolDefault As Boolean = False) _
As Boolean
Dim strData As String
strData = GetIniStr(strSection, strKey, IIf(bolDefault, "True", "False" ))
GetIniBoolean = CBool(strData )
End Function
'** 将配置信息写入配置文件中
Public Sub WriteIniStr(ByVal sSection As String, ByVal sKey As String, ByVal sValue As String )
Dim lReturn As Long
lReturn = WritePrivateProfileString(sSection, sKey, sValue, IniFileName )
End Sub
'**
'** 初始化模块 **
'**
Public Sub Reset ()
IniFileName = ""
CurrentSection = ""
CurrentData = ""
End Sub
'**
'** 获得设置值 **
'**
Public Property Get IniValue(ByVal strKey As String) As Variant
Dim strData As String
Dim strTemp As String
strData = GetIniStr(CurrentSection, strKey, "" )
If strData = "" Then
IniValue = ""
Else
If IsNumeric(strData) Then
IniValue = Val(strData )
Exit Property
End If
If IsDate(strData) Then
IniValue = CDate(strData )
Exit Property
End If
strTemp = UCase(strData )
If strTemp = "TRUE" Or strTemp = "FALSE" Then
IniValue = CBool(strData )
Exit Property
End If
IniValue = strData
End If
End Property
'**
'** 保存设置值 **
'**
Public Property Let IniValue(ByVal strKey As String, ByVal vData As Variant )
Dim strData As String
If IsDate(vData) Then
strData = Format(vData, "yyyy-mm-dd hh:mm:ss" )
ElseIf TypeName(vData) = "String" Then
strData = vData
Else
strData = Trim(CStr(vData ))
End If
WriteIniStr CurrentSection, strKey, strData
End Property
'**
'** 获得字符串设置
'**
Public Property Get IniString(ByVal strKey As String) As String
IniString = GetIniStr(CurrentSection, strKey )
End Property
'**
'** 保存字符串设置
'**
Public Property Let IniString(ByVal strKey As String, ByVal strData As String )
WriteIniStr CurrentSection, strKey, strData
End Property
'**
'** 获得数字设置
'**
Public Property Get IniNumber(ByVal strKey As String, Optional ByVal sngDefault As Single = 0) As Single
Dim strData As String
strData = GetIniStr(CurrentSection, strKey )
If IsNumeric(strData) Then
IniNumber = strData
Else
IniNumber = sngDefault
End If
End Property
' Public Property Let IniNumber(ByVal strKey As String, ByVal vData As Variant)
' WriteIniStr IniFileName, CurrentSection, strKey, Str(vData)
' End Property
'**
'** 获得布儿值设置
'**
Public Property Get IniBoolean(ByVal strKey As String, Optional ByVal bolDefault As Boolean = False) As Boolean
Dim strData As String
strData = GetIniStr(CurrentSection, strKey )
On Error Resume Next
IniBoolean = CBool(strData )
If Err.Number <> 0 Then
IniBoolean = bolDefault
End If
On Error GoTo 0
End Property
' Public Property Let IniBooleanl(ByVal strKey As String, ByVal bolData As Boolean)
' WriteIniStr IniFileName, CurrentSection, strKey, IIf(bolData, "True", "False")
' End Property
'******************************************************************************
'************* 定义内部私有的过程 ***********************
'******************************************************************************
'** 初始化模块
Private Sub Class_Initialize ()
Me. Reset
End Sub
###############################################################################
clsWindow.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 = "clsWindow"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" , "Yes"
Attribute VB_Ext_KEY = "Top_Level" , "Yes"
Option Explicit
'******************************************************************************
'**
'** 窗体状态类模块
'**
'** 本模块用户处理窗体的大小,位置,状态.
'**
'** 编制 : 袁永福
'** 时间 : 2001-12-7
'**
'** 该模块在配第5版补丁的VB6.0企业版/Windows98第二版的环境下调试通过
'**
'******************************************************************************
'** 声明API函数及常量 **
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) _
As Long
Private Declare Function FlashWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal bInvert As Long) _
As Long
Private Declare Function UpdateWindow Lib "user32" _
(ByVal hwnd As Long) As Long
'Private Declare Function SendMessage& Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any )
'Private Declare Function SendMessageBynum& Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long )
Private Const WM_CHAR = &H102
Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As String) _
As Long
'Private Declare Function GetDC Lib "user32" (ByVal Hwnd As Long) As Long
'Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Private Declare Function ReleaseDC Lib "user32" _
(ByVal Hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function InvalidateRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT, _
ByVal bErase As Long) _
As Long
Private Declare Function ValidateRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) _
As Long
Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) _
As Long
'** 定义窗体状态的枚举量 **
Public Enum enumWindowStatus
WIN_Normal = 0 ' 一般窗体
WIN_Min = 1 ' 最小化
WIN_Max = 2 ' 最大化
End Enum
'** 定义关于窗体状态的变量 **
Private myRect As RECT
Public Left As Single
Public Top As Single
Public Width As Single
Public Height As Single
Public WindowState As enumWindowStatus
'Private MYFrm As Form
Public hwnd As Long
'Public myForm As Form
'Public MoveRect As clsMoveRect
'Public SysEvent As clsSystemEvent
'** 定义接口过程及函数 ********************************************************
'** 窗体大小改变时改变窗体大小方框 **
Public Sub GetRect ()
Call Resize
End Sub
Public Sub Resize ()
GetClientRect hwnd, myRect
End Sub
'** 禁止客户区重画 **
Public Sub ForbitDraw ()
ValidateRect hwnd, myRect
End Sub
'
' '** 设置当前窗体
' Public Property Let Hwnd(ByVal lngHwnd As Long)
'
' lngHwnd = frm.Hwnd
' Set MYFrm = frm
' End Property
'** 获得窗体状态数据
Public Sub GetWindowState ()
' If MYFrm Is Nothing Then Exit Sub
' With MYFrm
' WindowState = .WindowState
' If WindowState <> WIN_Normal Then
' .WindowState = WIN_Normal
' End If
' Left = .Left
' Top = .Top
' Width = .Width
' Height = .Height
' End With
End Sub
'** 设置窗体状态数据
Public Sub SetWindowState ()
' If MYFrm Is Nothing Then Exit Sub
' With MYFrm
' .WindowState = WIN_Normal
' .Left = Left
' .Top = Top
' .Width = Width
' .Height = Height
' .WindowState = WindowState
' End With
End Sub
'将窗体放在屏幕最高层
Public Property Let TopMost(ByVal bolTopMost As Boolean )
Const HWND_TOPMOST = -&H1
Const HWND_NOTOPMOST = -&H2
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
If bolTopMost Then
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
Else
SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End If
End Property
Public Property Let FlashWin(ByVal bolFlash As Boolean )
FlashWindow hwnd, bolFlash
End Property
Public Sub Refresh ()
UpdateWindow hwnd
End Sub
Public Function SendString(ByVal wMsg As Long, ByVal wParam As Long, ByVal strMsg As String) As Long
SendString = SendMessageByString(hwnd, wMsg, wParam, strMsg )
End Function
Public Function SendKey(ByVal KeyAscii As Integer) As Long
SendKey = SendMessageByString(hwnd, WM_CHAR, KeyAscii, 0 )
End Function
可惜碰到比较粗糙的碟子就很难拷贝过去，因此编了个断点拷贝
文件的程序。本程序用于拷贝大文件，并可在旧文件上接着拷贝
本程序能在无法读取数据的情况下复制空白数据并跳过坏数据区
接着拷贝，专门对付烂盘 .
本程序特别适合在恶劣的环境下拷贝大文件，比如拷盘，在网络中拷
大文件等。
本程序是一个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"
Attribute VB_Ext_KEY = "Top_Level" , "Yes"
Option Explicit
'******************************************************************************
'**
'** INI文件操作类模块
'**
'** 本模块定义了INI文件读写的API操作及中间的数据转化
'**
'** 编制: 袁永福
'** 时间: 2001-12-11
'**
'** 该模块在配第5版补丁的VB6.0企业版/Windows98第二版的环境下调试通过
'**
'******************************************************************************
'** 定义变量 **
Public IniFileName As String ' 当前的配置文件名
Public CurrentSection As String ' 当前的类别
Public CurrentData As String ' 当前值
' Public AutoSave As Boolean ' 是否自动保存
'** 声明API函数 **
Private Declare Function GetPrivateProfileString& Lib "kernel32" Alias _
"GetPrivateProfileStringA" _
(ByVal lpAppName$, _
ByVal lpKeyName$, _
ByVal lpDefault$, _
ByVal lpRetStr$, _
ByVal nSize&, _
ByVal lpFileName$ )
Private Declare Function GetPrivateProfileInt& Lib "kernel32" Alias _
"GetPrivateProfileIntA" _
(ByVal lpAppName$, _
ByVal lpKeyName$, _
ByVal nDefault&, _
ByVal lpFileName$ )
Private Declare Function WritePrivateProfileString& Lib "kernel32" Alias _
"WritePrivateProfileStringA" _
(ByVal lpAppName$, _
ByVal lpKeyName$, _
ByVal lpString$, _
ByVal lpFileName$ )
'******************************************************************************
'************* 定义读写配置文件的接口函数 ***********************
'******************************************************************************
'** 从系统配置文件中读取相应配置字符串
Public Function GetIniStr(ByVal sSection As String, _
ByVal sKey As String, _
Optional ByVal sDefault As String = "") As String
Dim sReturnStr As String
Dim lTemp As Long
sReturnStr = Space(1024 )
'此处虽然设定在读不成功时为NONE,但绝对不会为NONE(webpaul)
GetPrivateProfileString sSection, sKey, sDefault, _
sReturnStr, 1024, IniFileName
sReturnStr = Trim$(sReturnStr )
lTemp = LenB(sReturnStr )
If lTemp > 0 Then
sReturnStr = Trim(MidB(sReturnStr, 1, lTemp - 1 ))
End If
If sReturnStr = "" Then
sReturnStr = sDefault
End If
GetIniStr = sReturnStr
End Function
'** 从系统配置文件中读取相应配置数值
Public Function GetIniNum(ByVal sSection As String, _
ByVal sKey As String, _
Optional ByVal lDefault As Long = c_NullID) As Long
Dim lReturn As Long
lReturn = GetPrivateProfileInt(sSection, sKey, lDefault, IniFileName )
GetIniNum = lReturn
End Function
'** 从配置文件中读取Boolean类型变量的设置
Public Function GetIniBoolean _
(ByVal strSection As String, _
ByVal strKey As String, _
Optional ByVal bolDefault As Boolean = False) _
As Boolean
Dim strData As String
strData = GetIniStr(strSection, strKey, IIf(bolDefault, "True", "False" ))
GetIniBoolean = CBool(strData )
End Function
'** 将配置信息写入配置文件中
Public Sub WriteIniStr(ByVal sSection As String, ByVal sKey As String, ByVal sValue As String )
Dim lReturn As Long
lReturn = WritePrivateProfileString(sSection, sKey, sValue, IniFileName )
End Sub
'**
'** 初始化模块 **
'**
Public Sub Reset ()
IniFileName = ""
CurrentSection = ""
CurrentData = ""
End Sub
'**
'** 获得设置值 **
'**
Public Property Get IniValue(ByVal strKey As String) As Variant
Dim strData As String
Dim strTemp As String
strData = GetIniStr(CurrentSection, strKey, "" )
If strData = "" Then
IniValue = ""
Else
If IsNumeric(strData) Then
IniValue = Val(strData )
Exit Property
End If
If IsDate(strData) Then
IniValue = CDate(strData )
Exit Property
End If
strTemp = UCase(strData )
If strTemp = "TRUE" Or strTemp = "FALSE" Then
IniValue = CBool(strData )
Exit Property
End If
IniValue = strData
End If
End Property
'**
'** 保存设置值 **
'**
Public Property Let IniValue(ByVal strKey As String, ByVal vData As Variant )
Dim strData As String
If IsDate(vData) Then
strData = Format(vData, "yyyy-mm-dd hh:mm:ss" )
ElseIf TypeName(vData) = "String" Then
strData = vData
Else
strData = Trim(CStr(vData ))
End If
WriteIniStr CurrentSection, strKey, strData
End Property
'**
'** 获得字符串设置
'**
Public Property Get IniString(ByVal strKey As String) As String
IniString = GetIniStr(CurrentSection, strKey )
End Property
'**
'** 保存字符串设置
'**
Public Property Let IniString(ByVal strKey As String, ByVal strData As String )
WriteIniStr CurrentSection, strKey, strData
End Property
'**
'** 获得数字设置
'**
Public Property Get IniNumber(ByVal strKey As String, Optional ByVal sngDefault As Single = 0) As Single
Dim strData As String
strData = GetIniStr(CurrentSection, strKey )
If IsNumeric(strData) Then
IniNumber = strData
Else
IniNumber = sngDefault
End If
End Property
' Public Property Let IniNumber(ByVal strKey As String, ByVal vData As Variant)
' WriteIniStr IniFileName, CurrentSection, strKey, Str(vData)
' End Property
'**
'** 获得布儿值设置
'**
Public Property Get IniBoolean(ByVal strKey As String, Optional ByVal bolDefault As Boolean = False) As Boolean
Dim strData As String
strData = GetIniStr(CurrentSection, strKey )
On Error Resume Next
IniBoolean = CBool(strData )
If Err.Number <> 0 Then
IniBoolean = bolDefault
End If
On Error GoTo 0
End Property
' Public Property Let IniBooleanl(ByVal strKey As String, ByVal bolData As Boolean)
' WriteIniStr IniFileName, CurrentSection, strKey, IIf(bolData, "True", "False")
' End Property
'******************************************************************************
'************* 定义内部私有的过程 ***********************
'******************************************************************************
'** 初始化模块
Private Sub Class_Initialize ()
Me. Reset
End Sub
###############################################################################
clsWindow.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 = "clsWindow"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" , "Yes"
Attribute VB_Ext_KEY = "Top_Level" , "Yes"
Option Explicit
'******************************************************************************
'**
'** 窗体状态类模块
'**
'** 本模块用户处理窗体的大小,位置,状态.
'**
'** 编制 : 袁永福
'** 时间 : 2001-12-7
'**
'** 该模块在配第5版补丁的VB6.0企业版/Windows98第二版的环境下调试通过
'**
'******************************************************************************
'** 声明API函数及常量 **
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) _
As Long
Private Declare Function FlashWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal bInvert As Long) _
As Long
Private Declare Function UpdateWindow Lib "user32" _
(ByVal hwnd As Long) As Long
'Private Declare Function SendMessage& Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any )
'Private Declare Function SendMessageBynum& Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long )
Private Const WM_CHAR = &H102
Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As String) _
As Long
'Private Declare Function GetDC Lib "user32" (ByVal Hwnd As Long) As Long
'Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Private Declare Function ReleaseDC Lib "user32" _
(ByVal Hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function InvalidateRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT, _
ByVal bErase As Long) _
As Long
Private Declare Function ValidateRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) _
As Long
Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) _
As Long
'** 定义窗体状态的枚举量 **
Public Enum enumWindowStatus
WIN_Normal = 0 ' 一般窗体
WIN_Min = 1 ' 最小化
WIN_Max = 2 ' 最大化
End Enum
'** 定义关于窗体状态的变量 **
Private myRect As RECT
Public Left As Single
Public Top As Single
Public Width As Single
Public Height As Single
Public WindowState As enumWindowStatus
'Private MYFrm As Form
Public hwnd As Long
'Public myForm As Form
'Public MoveRect As clsMoveRect
'Public SysEvent As clsSystemEvent
'** 定义接口过程及函数 ********************************************************
'** 窗体大小改变时改变窗体大小方框 **
Public Sub GetRect ()
Call Resize
End Sub
Public Sub Resize ()
GetClientRect hwnd, myRect
End Sub
'** 禁止客户区重画 **
Public Sub ForbitDraw ()
ValidateRect hwnd, myRect
End Sub
'
' '** 设置当前窗体
' Public Property Let Hwnd(ByVal lngHwnd As Long)
'
' lngHwnd = frm.Hwnd
' Set MYFrm = frm
' End Property
'** 获得窗体状态数据
Public Sub GetWindowState ()
' If MYFrm Is Nothing Then Exit Sub
' With MYFrm
' WindowState = .WindowState
' If WindowState <> WIN_Normal Then
' .WindowState = WIN_Normal
' End If
' Left = .Left
' Top = .Top
' Width = .Width
' Height = .Height
' End With
End Sub
'** 设置窗体状态数据
Public Sub SetWindowState ()
' If MYFrm Is Nothing Then Exit Sub
' With MYFrm
' .WindowState = WIN_Normal
' .Left = Left
' .Top = Top
' .Width = Width
' .Height = Height
' .WindowState = WindowState
' End With
End Sub
'将窗体放在屏幕最高层
Public Property Let TopMost(ByVal bolTopMost As Boolean )
Const HWND_TOPMOST = -&H1
Const HWND_NOTOPMOST = -&H2
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
If bolTopMost Then
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
Else
SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End If
End Property
Public Property Let FlashWin(ByVal bolFlash As Boolean )
FlashWindow hwnd, bolFlash
End Property
Public Sub Refresh ()
UpdateWindow hwnd
End Sub
Public Function SendString(ByVal wMsg As Long, ByVal wParam As Long, ByVal strMsg As String) As Long
SendString = SendMessageByString(hwnd, wMsg, wParam, strMsg )
End Function
Public Function SendKey(ByVal KeyAscii As Integer) As Long
SendKey = SendMessageByString(hwnd, WM_CHAR, KeyAscii, 0 )
End Function
扫一扫
4252
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
