小弟以前租碟在电脑上看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 AsOFSTRUCT, 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