VB断点拷贝大文件（WIN7系统需要更改某个API函数，具体我也忘了）

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

转载于:https://www.cnblogs.com/boentouch/p/9951830.html