Gigabyte file read/write: Binary I/O on very large disk files

Option Explicit
'
'HugeBinaryFile
'==============
'
'A class for doing simple binary I/O on very large disk files
'(well over the usual 2GB limit).  It only does I/O using Byte
'arrays, and makes use of Currency values that are scaled to
'whole numbers in places:
'
'   For a file of one byte the FileLen property returns 1.0000 as
'   its value.
'
'Operation is similar in many ways to native VB Get#/Put# I/O, for
'example the EOF property must be checked after a ReadBytes() call.
'You must also Dim/Redim buffers to desired sizes before calling
'ReadBytes() or WriteBytes().
'
'Short (signed Long) relative seeks and long (unsigned Currency)
'absolute seeks from 0 may be done.
'
'AutoFlush may be set True to force buffer flushes on every write.
'The Flush() method may be called explicitly if necessary.
'

Public Enum HBF_Errors
  HBF_UNKNOWN_ERROR =45600
  HBF_FILE_ALREADY_OPEN
  HBF_OPEN_FAILURE
  HBF_SEEK_FAILURE
  HBF_FILELEN_FAILURE
  HBF_READ_FAILURE
  HBF_WRITE_FAILURE
  HBF_FILE_ALREADY_CLOSED
End Enum

PrivateConst HBF_SOURCE ="HugeBinaryFile"

PrivateConst GENERIC_WRITE AsLong=&H40000000
PrivateConst GENERIC_READ AsLong=&H80000000
PrivateConst FILE_ATTRIBUTE_NORMAL AsLong=&H80&
PrivateConst CREATE_ALWAYS =2
PrivateConst OPEN_ALWAYS =4
PrivateConst INVALID_HANDLE_VALUE =-1
PrivateConst INVALID_SET_FILE_POINTER =-1
PrivateConst INVALID_FILE_SIZE =-1

PrivateConst FILE_BEGIN =0, FILE_CURRENT =1, FILE_END =2

Private Type MungeCurr
    Value AsCurrency
End Type

Private Type Munge2Long
    LowVal AsLong
    HighVal AsLong
End Type

Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA"(_
ByVal dwFlags AsLong,_
    lpSource AsLong,_
ByVal dwMessageId AsLong,_
ByVal dwLanguageId AsLong,_
ByVal lpBuffer AsString,_
ByVal nSize AsLong,_
    Arguments As Any)AsLong

Private Declare Function ReadFile Lib "kernel32"(_
ByVal hFile AsLong,_
    lpBuffer As Any,_
ByVal nNumberOfBytesToRead AsLong,_
    lpNumberOfBytesRead AsLong,_
ByVal lpOverlapped AsLong)AsLong

Private Declare Function CloseHandle Lib "kernel32"(_
ByVal hObject AsLong)AsLong

Private Declare Function GetFileSize Lib "kernel32"(_
ByVal hFile AsLong,_
    lpFileSizeHigh AsLong)AsLong

Private Declare Function WriteFile Lib "kernel32"(_
ByVal hFile AsLong,_
    lpBuffer As Any,_
ByVal nNumberOfBytesToWrite AsLong,_
    lpNumberOfBytesWritten AsLong,_
ByVal lpOverlapped AsLong)AsLong

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA"(_
ByVal lpFileName AsString,_
ByVal dwDesiredAccess AsLong,_
ByVal dwShareMode AsLong,_
ByVal lpSecurityAttributes AsLong,_
ByVal dwCreationDisposition AsLong,_
ByVal dwFlagsAndAttributes AsLong,_
ByVal hTemplateFile AsLong)AsLong

Private Declare Function SetFilePointer Lib "kernel32"(_
ByVal hFile AsLong,_
ByVal lDistanceToMove AsLong,_
    lpDistanceToMoveHigh AsLong,_
ByVal dwMoveMethod AsLong)AsLong

Private Declare Function FlushFileBuffers Lib "kernel32"(_
ByVal hFile AsLong)AsLong

Private hFile AsLong
Private sFName AsString
Private fAutoFlush AsBoolean
Private fEOF AsBoolean
Private C As MungeCurr
Private L As Munge2Long

PublicPropertyGet AutoFlush()AsBoolean
    RaiseErrorIfClosed
    AutoFlush = fAutoFlush
EndProperty

PublicPropertyLet AutoFlush(ByVal NewVal AsBoolean)
    RaiseErrorIfClosed
    fAutoFlush = NewVal
EndProperty

PublicPropertyGet FileHandle()AsLong
    RaiseErrorIfClosed
    FileHandle = hFile
EndProperty

PublicPropertyGetFileLen()AsCurrency
    RaiseErrorIfClosed
    L.LowVal = GetFileSize(hFile, L.HighVal)
If L.LowVal = INVALID_FILE_SIZE Then
IfErr.LastDllError Then RaiseError HBF_FILELEN_FAILURE
EndIf
LSet C = L
FileLen= C.Value *10000@
EndProperty

PublicPropertyGet FileName()AsString
    RaiseErrorIfClosed
    FileName = sFName
EndProperty

PublicPropertyGetEOF()AsBoolean
    RaiseErrorIfClosed
EOF= fEOF
EndProperty

PublicPropertyGet IsOpen()AsBoolean
    IsOpen = hFile <> INVALID_HANDLE_VALUE
EndProperty

PublicSub CloseFile()
    RaiseErrorIfClosed
    CloseHandle hFile
    sFName =""
    fAutoFlush =False
    fEOF =False
    hFile = INVALID_HANDLE_VALUE
EndSub

PublicSub Flush()
    RaiseErrorIfClosed
    FlushFileBuffers hFile
EndSub

PublicSub OpenFile(ByVal OpenFileName AsString)
If hFile <> INVALID_HANDLE_VALUE Then
        RaiseError HBF_FILE_ALREADY_OPEN
EndIf
    hFile = CreateFile(OpenFileName, GENERIC_WRITE Or GENERIC_READ,0,_
0, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL,0)
If hFile = INVALID_HANDLE_VALUE Then
        RaiseError HBF_OPEN_FAILURE
EndIf
    sFName = OpenFileName
EndSub

PublicFunction ReadBytes(ByRef Buffer()AsByte)AsLong
    RaiseErrorIfClosed
If ReadFile(hFile,_
                Buffer(LBound(Buffer)),_
UBound(Buffer)-LBound(Buffer)+1,_
                ReadBytes,_
0)Then
If ReadBytes =0Then
            fEOF =True
EndIf
Else
        RaiseError HBF_READ_FAILURE
EndIf
EndFunction

PublicSub SeekAbsolute(ByVal Position AsCurrency)
    RaiseErrorIfClosed
    C.Value = Position /10000@
LSet L = C
If SetFilePointer(hFile, L.LowVal, L.HighVal, FILE_BEGIN)_
= INVALID_SET_FILE_POINTER Then
IfErr.LastDllError Then RaiseError HBF_SEEK_FAILURE
EndIf
EndSub

PublicSub SeekEnd()
    RaiseErrorIfClosed
If SetFilePointer(hFile,0&,ByVal0&, FILE_END)_
= INVALID_SET_FILE_POINTER Then
            RaiseError HBF_SEEK_FAILURE
EndIf
EndSub

PublicSub SeekRelative(ByVal Offset AsLong)
'Offset is signed.
    RaiseErrorIfClosed
If SetFilePointer(hFile, Offset,ByVal0&, FILE_CURRENT)_
= INVALID_SET_FILE_POINTER Then
            RaiseError HBF_SEEK_FAILURE
EndIf
EndSub

PublicFunction WriteBytes(Buffer()AsByte)AsLong
    RaiseErrorIfClosed
If WriteFile(hFile,_
                 Buffer(LBound(Buffer)),_
UBound(Buffer)-LBound(Buffer)+1,_
                 WriteBytes,_
0)Then
If fAutoFlush Then Flush
Else
        RaiseError HBF_WRITE_FAILURE
EndIf
EndFunction

PrivateSub Class_Initialize()
    hFile = INVALID_HANDLE_VALUE
EndSub

PrivateSub Class_Terminate()
If hFile <> INVALID_HANDLE_VALUE Then CloseHandle hFile
EndSub

PrivateSub RaiseError(ByVal ErrorCode As HBF_Errors)
Dim Win32Err AsLong, Win32Text AsString

    Win32Err =Err.LastDllError
If Win32Err Then
        Win32Text = vbNewLine &"Error "& Win32Err & vbNewLine _
& DecodeAPIErrors(Win32Err)
EndIf
If IsOpen Then CloseFile
SelectCase ErrorCode
Case HBF_FILE_ALREADY_OPEN
Err.Raise HBF_FILE_ALREADY_OPEN, HBF_SOURCE,_
"File already open."
Case HBF_OPEN_FAILURE
Err.Raise HBF_OPEN_FAILURE, HBF_SOURCE,_
"Error opening file."& Win32Text
Case HBF_SEEK_FAILURE
Err.Raise HBF_SEEK_FAILURE, HBF_SOURCE,_
"Seek Error."& Win32Text
Case HBF_FILELEN_FAILURE
Err.Raise HBF_FILELEN_FAILURE, HBF_SOURCE,_
"GetFileSize Error."& Win32Text
Case HBF_READ_FAILURE
Err.Raise HBF_READ_FAILURE, HBF_SOURCE,_
"Read failure."& Win32Text
Case HBF_WRITE_FAILURE
Err.Raise HBF_WRITE_FAILURE, HBF_SOURCE,_
"Write failure."& Win32Text
Case HBF_FILE_ALREADY_CLOSED
Err.Raise HBF_FILE_ALREADY_CLOSED, HBF_SOURCE,_
"File must be open for this operation."
CaseElse
Err.Raise HBF_UNKNOWN_ERROR, HBF_SOURCE,_
"Unknown error."& Win32Text
EndSelect
EndSub

PrivateSub RaiseErrorIfClosed()
If hFile = INVALID_HANDLE_VALUE Then RaiseError HBF_FILE_ALREADY_CLOSED
EndSub

PrivateFunction DecodeAPIErrors(ByVal ErrorCode AsLong)AsString
Const FORMAT_MESSAGE_FROM_SYSTEM AsLong=&H1000&
Dim strMsg AsString, lngMsgLen AsLong

    strMsg =Space$(256)
    lngMsgLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,0&,_
                              ErrorCode,0&, strMsg,256&,0&)
If lngMsgLen >0Then
        DecodeAPIErrors =Left(strMsg, lngMsgLen)
Else
        DecodeAPIErrors ="Unknown Error."
EndIf
EndFunction

Option Explicit
'
'Timer-driven demo of HugeBinaryFile class.
'

Private hbfFile As HugeBinaryFile
Private blnWriting AsBoolean
Private bytBuf(1To1000000)AsByte
Private lngBlocks AsLong
PrivateConst MAX_BLOCKS AsLong=5000

PrivateSub cmdRead_Click()
    cmdWrite.Enabled =False
    cmdRead.Enabled =False
    lngBlocks =0
    lblRead.Caption =""
    blnWriting =False
Set hbfFile =New HugeBinaryFile
    hbfFile.OpenFile "test.dat"
    lblStatus =" Reading "_
&Format$(hbfFile.FileLen,"##,###,###,###,##0")_
&" bytes"
    Timer1.Enabled =True
EndSub

PrivateSub cmdWrite_Click()
    cmdWrite.Enabled =False
    cmdRead.Enabled =False
OnErrorResumeNext
Kill"test.dat"
OnErrorGoTo0
    lngBlocks =0
    lblWritten.Caption =""
    lblStatus =" Writing "_
&Format$(CCur(MAX_BLOCKS)*CCur(UBound(bytBuf)),"##,###,###,###,##0")_
&" bytes"
    blnWriting =True
Set hbfFile =New HugeBinaryFile
    hbfFile.OpenFile "test.dat"
    Timer1.Enabled =True
EndSub

PrivateSub Form_Unload(Cancel AsInteger)
IfNot(hbfFile Is Nothing)Then
If hbfFile.IsOpen Then hbfFile.CloseFile
Set hbfFile =Nothing
EndIf
EndSub

PrivateSub Timer1_Timer()
If blnWriting Then
        hbfFile.WriteBytes bytBuf
        lngBlocks = lngBlocks +1
        lblWritten.Caption =_
Format$(CCur(lngBlocks)*CCur(UBound(bytBuf)),"##,###,###,###,##0")_
&" bytes written"
If lngBlocks >= MAX_BLOCKS Then
            Timer1.Enabled =False
            hbfFile.CloseFile
Set hbfFile =Nothing
            lblStatus =""
            cmdWrite.Enabled =True
            cmdRead.Enabled =True
EndIf
Else
        hbfFile.ReadBytes bytBuf
If hbfFile.EOFThen
            Timer1.Enabled =False
            hbfFile.CloseFile
Set hbfFile =Nothing
            lblStatus =""
            cmdWrite.Enabled =True
            cmdRead.Enabled =True
Else
            lngBlocks = lngBlocks +1
            lblRead.Caption =_
Format$(CCur(lngBlocks)*CCur(UBound(bytBuf)),"##,###,###,###,##0")_
&" bytes read"
EndIf
EndIf
EndSub