Direct File I/O in VBA

[NeoPa]

Introduction

By default VBA makes direct file I/O very hard to find. So much so that many will swear it isn't even supported. It is. AND, it does the job extremely fast. This Class Module handles direct file I/O as well as buffering. It even provides a routine for searching through a file for a simple string, as well as a simple string followed by a list of other data at specified offsets from where the original string was found.

Option Explicit
 
Private Const conMaxBufLen As Long = 2 ^ &H14    '1,048,576 or &H100000
 
Private strName As String, strBuffer As String
Private intFileNo As Integer
Private lngBufPos As Long, lngFilePos As Long, lngFileLen As Long
 
'Initialise() opens the specified save file.
Public Function Initialise(Optional ByVal strFileName As String = "") As Boolean
    lngBufPos = -1
    lngFilePos = -1
    Initialise = OpenSave(strFileName)
End Function
 
'OpenSave() opens the file for update if not already open.
Private Function OpenSave(Optional ByVal strFileName As String = "") As Boolean
    Dim strMsg As String
 
    On Error GoTo Err_OpenSave
    OpenSave = True
    If strFileName = "" Then Exit Function
    strName = strFileName
    If intFileNo > 0 Then Close #intFileNo
    intFileNo = FreeFile()
    Open strName For Binary Access Read Write Lock Write As #intFileNo
    lngFileLen = LOF(intFileNo)
    Exit Function
 
Err_OpenSave:
    strMsg = MultiReplace(conErr, "%N", Err.Number, _
                                  "%D", Err.Description, _
                                  "%L", vbNewLine) & _
             vbNewLine & vbNewLine & _
             "Retry?"
    If CheckOp(strWarning:=strMsg, strTitle:="clsSave.OpenSave") Then Resume
    OpenSave = False
End Function
 
'ReadBuf() reads data into the (1MB) buffer.
Private Sub ReadBuf(Optional ByVal lngPos As Long = -1)
    Dim lngBufLen As Long
 
    If lngPos = -1 Then lngPos = IIf(lngBufPos = -1, 0, lngFilePos - conDiskBuf)
    If lngPos = lngBufPos Then Exit Sub
    If intFileNo = 0 Then Stop
    lngPos = lngPos And -conDiskBuf
    lngBufLen = lngFileLen - lngPos
    If lngBufLen < 0 Then Stop
    If lngBufLen > conMaxBufLen Then lngBufLen = conMaxBufLen
    If Len(strBuffer) <> lngBufLen Then strBuffer = String(lngBufLen, Chr(&HFF))
    Get #intFileNo, lngPos + 1, strBuffer
    lngBufPos = lngPos
    lngFilePos = lngPos + lngBufLen
End Sub
 
'ReadNum() returns a number value from the file.
Public Function ReadNum(lngPos As Long, _
                        Optional intLen As Integer = &H4) As Long
    ReadNum = LongVal(ReadFile(lngPos, intLen))
End Function
 
'ReadFile() returns an intLen long string from the file.
Public Function ReadFile(lngPos As Long, intLen As Integer) As String
    If intFileNo = 0 Then Stop
    Select Case lngPos
    Case Is < lngBufPos, Is > lngFilePos - intLen
        ReadFile = String(intLen, &HFF)
        Get #intFileNo, lngPos + 1, ReadFile
    Case Else
        ReadFile = Mid(strBuffer, lngPos - lngBufPos + 1, intLen)
    End Select
End Function
 
'WriteNum() writes a number value to the file at lngPos.
Public Sub WriteNum(ByVal lngPos As Long, ByVal lngVal As Long, _
                    Optional ByVal intLen As Integer = &H4)
    Call WriteFile(lngPos, LongStr(lngVal, intLen))
End Sub
 
'WriteFile() writes strWrite to the file at lngPos.
Public Sub WriteFile(lngPos As Long, ByVal strWrite As String)
    If intFileNo = 0 Then Stop
    Put #intFileNo, lngPos + 1, strWrite
    'Update buffer if there is any overlap
    If lngPos > (lngBufPos - Len(strWrite)) And lngPos < lngFilePos Then
        Select Case lngPos
        Case Is < lngBufPos
            strWrite = Right(strWrite, lngPos + Len(strWrite) - lngBufPos)
            lngPos = lngBufPos
        Case Is > lngFilePos - Len(strWrite)
            strWrite = Left(strWrite, lngFilePos - lngPos)
        End Select
        Mid(strBuffer, lngPos - lngBufPos + 1) = strWrite
    End If
End Sub
 
'CloseFile() closes the file and tidies up the variables
Private Sub CloseFile()
    If intFileNo = 0 Then Exit Sub
    Close #intFileNo
    intFileNo = 0
End Sub
 
'Search() returns the position (in the file) of the next occurrence of strText
'starting from lngPos where the extra parameter pairs (if passed) are also
'found in the locations passed.
'If not found then -1 returned.
Public Function Search(lngPos As Long, ByVal strText As String, _
                       ParamArray avarArgs() As Variant) As Long
    Dim lngSize As Long, lngX As Long, lngY As Long, lngStrPos As Long
    Dim strCheck As String
 
    strText = FromSpecial(strText)
    lngSize = Len(strText)
    For lngX = LBound(avarArgs) To UBound(avarArgs) Step 2
        lngY = avarArgs(lngX) + Len(FromSpecial(avarArgs(lngX + 1)))
        If lngSize < lngY Then lngSize = lngY
    Next lngX
    'Logic relies on shunting by conDiskBuf so would fail if item larger
    If lngSize > conDiskBuf Then Stop
    If lngBufPos = -1 _
    Or lngPos < lngBufPos _
    Or lngPos > (lngFilePos - lngSize) Then Call ReadBuf(lngPos)
    lngStrPos = lngPos - lngBufPos
    Do
        lngStrPos = InStr(lngStrPos + 1, strBuffer, strText, vbBinaryCompare)
        Select Case lngStrPos
        Case 0, Is > (Len(strBuffer) + 1 - lngSize)
            'Not found, or main item found but no room in buffer to check others
            If lngFilePos < lngFileLen Then
                If lngStrPos = 0 Then lngStrPos = Len(strBuffer) + 1 - lngSize
                lngStrPos = lngStrPos + conDiskBuf - Len(strBuffer) - 1
                Call ReadBuf
            Else
                Search = -1
                Exit Do
            End If
        Case Else
            For lngX = LBound(avarArgs) To UBound(avarArgs) Step 2
                lngY = lngStrPos + avarArgs(lngX)
                strCheck = FromSpecial(avarArgs(lngX + 1))
                If Mid(strBuffer, lngY, Len(strCheck)) <> strCheck Then Exit For
            Next lngX
            If lngX > UBound(avarArgs) Then
                Search = lngBufPos + lngStrPos - 1
                Exit Do
            End If
        End Select
    Loop
End Function
 
'CheckData() returns True if strCheck NOT found in the file at lngPos.
Public Function CheckData(lngPos As Long, strCheck As String) As Boolean
    If lngPos < lngBufPos _
    Or lngPos > (lngFilePos - Len(strCheck)) Then Call ReadBuf(lngPos)
    CheckData = (ReadFile(lngPos, Len(strCheck)) <> strCheck)
End Function
 
'Class_Terminate() ensures all is tidied up before terminating.
Private Sub Class_Terminate()
    Call CloseFile
    strName = ""
End Sub

And, some supporting procedures from another module that are referenced by the above code :

'ToSpecial() converts unprintable characters in strFrom into special Hex string
Public Function ToSpecial(strFrom) As String
    Dim strChar As String
    Dim lngX As Long
 
    For lngX = 1 To Len(strFrom)
        strChar = Mid(strFrom, lngX, 1)
        If strChar < " " _
        Or strChar > "~" _
        Or strChar = "\" Then _
            strChar = "\" & ToSpChr(strChar)
        ToSpecial = ToSpecial & strChar
    Next lngX
End Function
 
'ToSpChr() converts a character into its two representative hex characters
Private Function ToSpChr(strChar As String) As String
    Dim intChar As Integer
 
    ToSpChr = "0"
    If Asc(strChar) > &HF Then _
        ToSpChr = Right(ToSpChr(Chr(Asc(strChar) \ &H10)), 1)
    intChar = Asc(strChar) Mod &H10
    If intChar > 9 Then intChar = intChar + 7
    ToSpChr = ToSpChr & Chr(Asc("0") + intChar)
End Function
 
'FromSpecial() converts \nn hex characters in a string to their char equivalent
Public Function FromSpecial(strFrom) As String
    Dim strChar As String
    Dim lngX As Long
 
    For lngX = 1 To Len(strFrom)
        strChar = Mid(strFrom, lngX, 1)
        If strChar = "\" Then
            strChar = FromSpChr(UCase(Mid(strFrom, lngX + 1, 2)))
            lngX = lngX + 2
        End If
        FromSpecial = FromSpecial & strChar
    Next lngX
End Function
 
'FromSpChr() converts two hex digits into their character equivalent
Private Function FromSpChr(strVal As String) As String
    FromSpChr = Chr(0)
    If Left(strVal, 1) > "0" Then FromSpChr = FromSpChr(Left("0" & strVal, 2))
    If Right(strVal, 1) > "9" Then strVal = Chr(Asc(Right(strVal, 1)) - 7)
    FromSpChr = Chr(&H10 * Asc(FromSpChr) + Asc(Right(strVal, 1)) - Asc("0"))
End Function
 
'LongVal() returns the value of a string
Public Function LongVal(strVal) As Long
    If Len(strVal) < &H4 Then _
        strVal = strVal & String(&H4 - Len(strVal), vbNullChar)
    LongVal = ((Asc(Mid(strVal, 4)) And &H7F) * &H1000000) Or _
              (Asc(Mid(strVal, 3)) * &H10000) Or _
              (Asc(Mid(strVal, 2)) * &H100&) Or _
              Asc(Mid(strVal, 1))
    If Asc(Mid(strVal, 4)) And &H80 Then LongVal = LongVal Or &H80000000
End Function
 
'LongStr() returns the string equivalent of a numeric value.
Public Function LongStr(lngVal As Long, _
                        Optional intLen As Integer = &H4) As String
    LongStr = Chr(lngVal And &HFF) & _
              Chr((lngVal And &HFF00&) \ 2 ^ &H8) & _
              Chr((lngVal And &HFF0000) \ 2 ^ &H10) & _
              Chr(((lngVal And &HFF000000) \ 2 ^ &H18) And &HFF)
    If intLen < &H4 Then LongStr = Left(LongStr, intLen)
End Function

Explanations

Initialise()
Unlike Class_Initialize() this must be called directly and is not an Event Procedure of the class. This needs to be called only once per session. The class can be re-used for closing and opening files once it's been initialised. It will call OpenSave() for you though, if passed.

OpenSave()
Named thus as in my usage it's working with Save files from a game. It simply opens the specified file in the appropriate way.

ReadBuf()
This procedure manages reading from the file into the File Buffer for later work. It ensures that the buffer has the correct data to cover the position in the file specified by lngPos.

ReadNum()
Reads a number and converts it to Long. Numbers can be variable lengths so this can be specified to ensure only the right number of Bytes are included in the number.

ReadFile()
This reads the specified data from either the file or the buffer. In most cases this will read from the buffer and be as efficient as possible. However, when the data read crosses a buffer boundary it reads it directly from the file itself. The number of times this happens will depend on the data and the work, but generally speaking will be vanishingly rare.

WriteNum()
Converts the number into a string of the correct number of Bytes then writes it.

WriteFile()
This manages writing the value to the file. This is done directly (Unbuffered) in order to avoid the danger of any writes being left in the buffer should the system crash, or even your code crashing elsewhere. However, it also handles ensuring the buffer currently loaded, should it contain any part of the written data (Overlapping at the start, somewhere in the middle, or overlapping at the end.), is updated to include the changes.

CloseFile()
Closes up the file but leaves the class available for another if required.

Class_Terminate()
This one IS an Event Procedure and handles tidying up the class variables and data when the calling code finishes with it.

Search()
This code is used to search for patterns where the recognised data may not be contiguous.

An example might be for data where each record is preceded by a certain tag (EG "INFO".) but that's followed by something like a record number (4 bytes), followed by a name. So, if I'm looking for an record INFO record for John Smith I may call it as :

Dim objSave = New clsSave
...
lngPtr = objSave.Search(0, "INFO", 8, "John Smith")

It first finds the first instance of "INFO" then checks for the occurrence of "John Smith" 8 bytes later. If not found then it finds the next occurrence of "INFO" and tries again. If the data is found it returns the address of the matching "INFO" text.

CheckData()
This allows the caller to determine if the specified text is found at the position indicated. Often used to check that a particular data structure is a valid example and not some other/random occurrence of the data.

EG. In the example above using "INFO", it may be that "INFO" is found elsewhere in the file as a random occurrence of that text. It could even be a numeric value that just happens to match. CheckData() enables the caller to check for other indicators that ensure it's a valid record found.

FromSpecial() & ToSpecial()
These allow numbers to be specified in strings directly and mixed with other text. For instance if you know the record number of "John Smith" is actually 49623 (Hex = 0000C1D7) then you could do a simpler search for "INFO\D7\C1\00\00" as these function procedures convert "\nn", where nn are two valid hexadecimal digits, to & from the characters that they represent in ASCII.

Conclusion
I hope that this can do either of two things for you :

1. Give you a basic set of routines that you can use, out of the box, to handle your file manipulation.
2. Get you started with the necessary principles and enable you to go further and tweak the code for your own needs.

Attribution is not necessary. I claim copyright, but I only insist nobody tries to claim copyright themselves for this code or any minor derivative thereof - thus restricting its free use.

[jimatqsi]

Thanks so much. I suspect your list of benefits is far too short. I've used the file I/O quite a bit, but there's a lot to learn here. The first compile attempt introduced me to the WebClient class. I've got a lot of reading to do.

Thank you!

Jim