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. Expand|Select|Wrap|Line Numbers
- 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
Expand|Select|Wrap|Line Numbers
- '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
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 :
Expand|Select|Wrap|Line Numbers
- Dim objSave = New clsSave
- ...
- lngPtr = objSave.Search(0, "INFO", 8, "John Smith")
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 :
- Give you a basic set of routines that you can use, out of the box, to handle your file manipulation.
- Get you started with the necessary principles and enable you to go further and tweak the code for your own needs.