VB二進位快速讀寫類

利用自建的檔案緩衝區來提高檔案讀寫速度，下面是與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