利用自建的文件缓冲区来提高文件读写速度，下面是与VB 自带的Put Get 进行比较
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
测试代码 :Form1
Option Explicit
Private cfb1 As CFileBuff
Private cfb2 As CFileBuff
Private fh1 As Long
Private fh2 As Long
Private Sub Command1_Click()
Dim fn1 As String
Dim fn2 As String
Dim fn3 As String
Dim ch As Byte
Dim i As Long
Dim st1 As Single, et1 As Single
Dim st2 As Single, et2 As Single
fn1 = App.Path & "\D.DAT"
fn2 = App.Path & "\D.BAK"
fn3 = App.Path & "\D.BAK2"
st1 = Timer
Set cfb1 = New CFileBuff
Set cfb2 = New CFileBuff
If cfb1.Create(fn1) = True Then
cfb2.Create (fn2)
Do
If cfb1.GetByte(ch) = 1 Then
cfb2.PutByte ch
Else
Exit Do
End If
Loop While cfb1.FEof = False
Else
Debug.Print "Error Open File!"
End If
Set cfb1 = Nothing
Set cfb2 = Nothing
et1 = Timer
' MsgBox CStr(et1 - st1)
st2 = Timer
fh1 = FreeFile(0)
Open fn1 For Binary As fh1
fh2 = FreeFile(0)
Open fn3 For Binary As fh2
Do
Get fh1, , ch
Put fh2, , ch
Loop While EOF(fh1) = False
Close fh1
Close fh2
et2 = Timer
MsgBox CStr(et1 - st1) & " " & CStr(et2 - st2)
Debug.Print "Success!"
End Sub
///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
类代码 : CFileBuff
Option Explicit
'文件缓冲类，利用块读写来提高文件的读写速度
Private Const GENERIC_WRITE = &H40000000
Private Const GENERIC_READ = &H80000000
Const FILE_ATTRIBUTE_NORMAL = &H80
Const CREATE_ALWAYS = 2
Const OPEN_ALWAYS = 4
Const INVALID_HANDLE_VALUE = -1
Const ERROR_HANDLE_EOF = 38
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, _
lpBuffer As Any, 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 WriteFile Lib "kernel32" ( _
ByVal hFile As Long, lpBuffer As Any, _
ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, ByVal lpOverlapped As _
Long) As Long
Private Declare Function CreateFile Lib "kernel32" _
Alias "CreateFileA" (ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
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 loWord As Long, ByVal hiWord As Long, ByVal MoveMethod As Long) As Long
Public Enum enumFileSeek
FS_BEGIN
FS_CURRENT
FS_END
End Enum
Private Const MAX_FILE_BUFF As Long = 512 '定义最大的缓冲区，正好一个扇区
Private Const EOF_CHAR As Byte = 0
Private m_fb(MAX_FILE_BUFF - 1) As Byte
Private m_NeedCloseFile As Boolean '是否需要
Private m_Handle As Long
Private m_OffSet As Long
Private m_DirtyFlag As Boolean
Private m_LastBuff As Boolean
Private m_MaxBytes As Long
Private m_FileName As String
'按标志创建文件
Public Function Create(FileName As String) As Boolean
m_Handle = CreateFile(FileName, GENERIC_WRITE Or GENERIC_READ, 0, 0, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
If m_Handle <> INVALID_HANDLE_VALUE Then '看是否正确创建了文件
m_FileName = FileName
ReadFileToBuff
Create = True
Else
Create = False
End If
End Function
'关闭文件
Public Sub CloseFile()
WriteBuffToFile
CloseHandle m_Handle
End Sub
'移动文件指针，不支持超过2 ^ 31 的位移
Public Function FSeek(Pos As Long, FS As enumFileSeek) As Boolean
Dim iPos As Long
If m_DirtyFlag = True Then WriteBuffToFile
Select Case FS
Case FS_BEGIN
If Pos < 0 Then FSeek = False
If SetFilePointer(m_Handle, Pos, 0, 0) = &HFFFFFFFF Then
FSeek = False
Else
If ReadFileToBuff = -1 Then
FSeek = False
Else
FSeek = True
End If
End If
Case FS_END
If Pos > 0 Then FSeek = False
If SetFilePointer(m_Handle, Pos, 0, 2) = &HFFFFFFFF Then
FSeek = False
Else
If ReadFileToBuff = -1 Then
FSeek = False
Else
FSeek = True
End If
End If
Case FS_CURRENT
iPos = Pos - (m_MaxBytes - m_OffSet) '计算实际的偏移位置
If SetFilePointer(m_Handle, iPos, 0, 1) = &HFFFFFFFF Then
FSeek = False
Else
If ReadFileToBuff = -1 Then
FSeek = False
Else
FSeek = True
End If
End If
End Select
End Function
'取一个字节
'返回 1 表示正确取到字符
'返回 0 表示已到文件尾，并且ch= EOF_CHAR
'返回 -1 表示取字符错误。
Public Function GetByte(ByRef ch As Byte) As Long
Dim fl As Long
If m_LastBuff = False Then
If m_OffSet = MAX_FILE_BUFF Then
fl = ReadFileToBuff
Select Case fl
Case 0
GetByte = 0
Case -1
GetByte = -1
Case Else
ch = m_fb(0)
m_OffSet = 1
GetByte = 1
End Select
Else
ch = m_fb(m_OffSet)
m_OffSet = m_OffSet + 1
GetByte = 1
End If
Else
If m_OffSet < m_MaxBytes Then
ch = m_fb(m_OffSet)
m_OffSet = m_OffSet + 1
GetByte = 1
Else
ch = EOF_CHAR
GetByte = 0
End If
End If
End Function
'写一个字节,如果正确表示1，错误为-1
Public Function PutByte(by As Byte) As Long
If m_OffSet < MAX_FILE_BUFF Then
m_fb(m_OffSet) = by
m_OffSet = m_OffSet + 1
m_DirtyFlag = True
Else '已写满一个缓冲区
WriteBuffToFile
m_fb(0) = by
m_OffSet = 1
m_DirtyFlag = True
End If
End Function
'看当前指针是否到达文件最尾端
Public Function FEof() As Boolean
If m_LastBuff = False Then
FEof = False
Else
If m_OffSet = m_MaxBytes Then
FEof = True
Else
FEof = False
End If
End If
End Function
'///////////////////////////////////////////////////////////////////////////////////////
'预读字节到缓冲区,并返回实际读到的字节,如果返回-1，则表示出错了。
Private Function ReadFileToBuff() As Long
Dim dwReadNum As Long
If ReadFile(m_Handle, m_fb(0), MAX_FILE_BUFF, dwReadNum, 0) = 0 Then
ReadFileToBuff = -1
Else
If dwReadNum <> MAX_FILE_BUFF Then
'最后一个缓冲区
m_LastBuff = True
m_MaxBytes = dwReadNum
m_OffSet = 0
m_DirtyFlag = False
ReadFileToBuff = dwReadNum
Else
m_LastBuff = False
m_MaxBytes = MAX_FILE_BUFF
m_OffSet = 0
m_DirtyFlag = False
ReadFileToBuff = MAX_FILE_BUFF
End If
End If
End Function
'写缓冲区到文件，并返回实际写的字节数
Private Function WriteBuffToFile() As Long
Dim dwWriteNum As Long
If m_OffSet = 0 Or m_DirtyFlag = False Then '如果写入数为0或者写入标志错则不写入
WriteBuffToFile = 0
Else
If WriteFile(m_Handle, m_fb(0), m_OffSet, dwWriteNum, 0) Then
WriteBuffToFile = dwWriteNum
Else
WriteBuffToFile = -1 '出错
End If
End If
m_OffSet = 0
m_DirtyFlag = False
End Function
Private Sub Class_Initialize()
Dim i As Long
m_OffSet = 0
m_Handle = 0
m_DirtyFlag = False
m_FileName = ""
m_LastBuff = False
m_MaxBytes = MAX_FILE_BUFF
End Sub
Private Sub Class_Terminate()
CloseFile
End Sub
