小弟以前租碟在电脑上看VCD，有时候拷贝经典的影片到硬盘上可惜碰到比较粗糙的碟子就很难拷贝过去，因此编了个断点拷贝文件的程序。本程序用于拷贝大文件，并可在旧文件上接着拷贝本程序能在无法读取数据的情况下复制空白数据并跳过坏数据区接着拷贝，专门对付烂盘
.本程序特别适合在恶劣的环境下拷贝大文件，比如拷盘，在网络中拷大文件等。本程序是一个VB程序，包括5个文件，主窗口为 frmCopy 使用了 Microsoft Common Dialog Control6.0 和Micorsoft Windows Common Controls 6.0 两个控件库拷贝文件使用了Win32API,速度比较快。
############################################################################### frmCopy.frm 内容
###############################################################################VERSION
5.00Object = "{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
EndEndAttribute VB_Name =
"frmCopy"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = False
Option ExplicitPrivate Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long)
As LongPrivate 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 LongPrivate Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, ByVal lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long)
As LongPrivate 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 LongPrivate 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 LongPrivate Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long)
As LongPrivate Declare Function GetLastError Lib "kernel32" ()
As LongPrivate Declare Function SetEndOfFile Lib "kernel32" (ByVal hFile As Long)
As LongPrivate 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 TypePrivate Const OFS_MAXPATHNAME =
128Private Type OFSTRUCT cBytes
As Byte fFixedDisk
As Byte nErrCode
As Integer Reserved1
As Integer Reserved2
As Integer szPathName(OFS_MAXPATHNAME)
As ByteEnd TypePrivate Const OF_CREATE = &H1000Private Const OF_WRITE = &H1Private Const OF_READ = &H0Private Const FILE_END =
2Private Const FILE_BEGIN =
0Private bolStop
As BooleanPrivate bolReady
As BooleanPrivate myCount As clsCountPrivate myIni As clsIniFilePrivate bolUnload
As BooleanPrivate Sub cmdCopy_Click
() Call SetControl(True
) Call CopyFile Call SetControl(False
) If chkShutdown.Value = 1
Then dlgShutDown.Show vbModal
End IfEnd SubPrivate 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 SubPrivate Sub cmdStop_Click
() Call SetControl(False
)
End SubPrivate 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 SubPrivate 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 SubPrivate 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 SubPrivate 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_BufSizeCopyExit
: 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 SubCopyErr
: 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 SubPrivate 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 IfEnd SubPrivate 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.00Object = "{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
EndEndAttribute VB_Name =
"dlgShutDown"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = False
Option ExplicitPrivate Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long)
As LongPrivate Const EWX_SHUTDOWN =
1Private Const cTimeCount As Long =
15Private lngCount
As LongPrivate Sub cmdCancel_Click
() Unload
MeEnd SubPrivate Sub cmdShutDown_Click
() ExitWindowsEx EWX_SHUTDOWN,
0
End SubPrivate 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 SubPrivate Sub myTimer_Timer
() lngCount = lngCount -
1 myProc.Value = cTimeCount - lngCount lblTitle.Caption = lngCount &
"秒后关机" If lngCount = 0
Then ExitWindowsEx EWX_SHUTDOWN,
0 lngCount = cTimeCount
End IfEnd Sub
############################################################################### mdlCopy.bas 内容
###############################################################################Attribute VB_Name =
"mdlCopy"
Option ExplicitPublic Const c_NullID As Long = -
9999
############################################################################### clsCount.cls 内容
###############################################################################VERSION 1.0
CLASSBEGIN MultiUse = -1
'True Persistable = 0
'NotPersistable DataBindingBehavior = 0
'vbNone DataSourceBehavior = 0
'vbNone MTSTransactionMode = 0
'NotAnMTSObject
ENDAttribute VB_Name =
"clsCount"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = TrueAttribute VB_PredeclaredId = FalseAttribute VB_Exposed = False
Option Explicit
'******************************************************************************'**'** 用于计算速度的类模块'**'** 该类模块设定一个计数器,由程序不断的累计数据,并根据所花时间计算数据'**'** 编制: 袁永福'** 时间: 2002-4-2'**'******************************************************************************Private Declare Function GetTickCount Lib "kernel32" ()
As LongPrivate lngCountStart
As LongPrivate lngCountCurrent
As LongPrivate lngCountLast
As LongPrivate lngSpeed
As LongPrivate lngTickStart
As LongPrivate lngTickCurrent
As LongPrivate 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
CLASSBEGIN MultiUse = -1
'True Persistable = 0
'NotPersistable DataBindingBehavior = 0
'vbNone DataSourceBehavior = 0
'vbNone MTSTransactionMode = 0
'NotAnMTSObject
ENDAttribute VB_Name =
"clsIniFile"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = TrueAttribute VB_PredeclaredId = FalseAttribute VB_Exposed = FalseAttribute 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.
ResetEnd Sub
############################################################################### clsWindow.cls 内容
###############################################################################VERSION 1.0
CLASSBEGIN MultiUse = -1
'True Persistable = 0
'NotPersistable DataBindingBehavior = 0
'vbNone DataSourceBehavior = 0
'vbNone MTSTransactionMode = 0
'NotAnMTSObject
ENDAttribute VB_Name =
"clsWindow"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = TrueAttribute VB_PredeclaredId = FalseAttribute VB_Exposed = FalseAttribute 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
