467,877 Members | 1,283 Online
Bytes | Developer Community
New Post

Home Posts Topics Members FAQ

Share your developer knowledge by writing an article on Bytes.

Direct File I/O in VBA

NeoPa
Expert Mod 16PB
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.
Expand|Select|Wrap|Line Numbers
  1. Option Explicit
  2.  
  3. Private Const conMaxBufLen As Long = 2 ^ &H14    '1,048,576 or &H100000
  4.  
  5. Private strName As String, strBuffer As String
  6. Private intFileNo As Integer
  7. Private lngBufPos As Long, lngFilePos As Long, lngFileLen As Long
  8.  
  9. 'Initialise() opens the specified save file.
  10. Public Function Initialise(Optional ByVal strFileName As String = "") As Boolean
  11.     lngBufPos = -1
  12.     lngFilePos = -1
  13.     Initialise = OpenSave(strFileName)
  14. End Function
  15.  
  16. 'OpenSave() opens the file for update if not already open.
  17. Private Function OpenSave(Optional ByVal strFileName As String = "") As Boolean
  18.     Dim strMsg As String
  19.  
  20.     On Error GoTo Err_OpenSave
  21.     OpenSave = True
  22.     If strFileName = "" Then Exit Function
  23.     strName = strFileName
  24.     If intFileNo > 0 Then Close #intFileNo
  25.     intFileNo = FreeFile()
  26.     Open strName For Binary Access Read Write Lock Write As #intFileNo
  27.     lngFileLen = LOF(intFileNo)
  28.     Exit Function
  29.  
  30. Err_OpenSave:
  31.     strMsg = MultiReplace(conErr, "%N", Err.Number, _
  32.                                   "%D", Err.Description, _
  33.                                   "%L", vbNewLine) & _
  34.              vbNewLine & vbNewLine & _
  35.              "Retry?"
  36.     If CheckOp(strWarning:=strMsg, strTitle:="clsSave.OpenSave") Then Resume
  37.     OpenSave = False
  38. End Function
  39.  
  40. 'ReadBuf() reads data into the (1MB) buffer.
  41. Private Sub ReadBuf(Optional ByVal lngPos As Long = -1)
  42.     Dim lngBufLen As Long
  43.  
  44.     If lngPos = -1 Then lngPos = IIf(lngBufPos = -1, 0, lngFilePos - conDiskBuf)
  45.     If lngPos = lngBufPos Then Exit Sub
  46.     If intFileNo = 0 Then Stop
  47.     lngPos = lngPos And -conDiskBuf
  48.     lngBufLen = lngFileLen - lngPos
  49.     If lngBufLen < 0 Then Stop
  50.     If lngBufLen > conMaxBufLen Then lngBufLen = conMaxBufLen
  51.     If Len(strBuffer) <> lngBufLen Then strBuffer = String(lngBufLen, Chr(&HFF))
  52.     Get #intFileNo, lngPos + 1, strBuffer
  53.     lngBufPos = lngPos
  54.     lngFilePos = lngPos + lngBufLen
  55. End Sub
  56.  
  57. 'ReadNum() returns a number value from the file.
  58. Public Function ReadNum(lngPos As Long, _
  59.                         Optional intLen As Integer = &H4) As Long
  60.     ReadNum = LongVal(ReadFile(lngPos, intLen))
  61. End Function
  62.  
  63. 'ReadFile() returns an intLen long string from the file.
  64. Public Function ReadFile(lngPos As Long, intLen As Integer) As String
  65.     If intFileNo = 0 Then Stop
  66.     Select Case lngPos
  67.     Case Is < lngBufPos, Is > lngFilePos - intLen
  68.         ReadFile = String(intLen, &HFF)
  69.         Get #intFileNo, lngPos + 1, ReadFile
  70.     Case Else
  71.         ReadFile = Mid(strBuffer, lngPos - lngBufPos + 1, intLen)
  72.     End Select
  73. End Function
  74.  
  75. 'WriteNum() writes a number value to the file at lngPos.
  76. Public Sub WriteNum(ByVal lngPos As Long, ByVal lngVal As Long, _
  77.                     Optional ByVal intLen As Integer = &H4)
  78.     Call WriteFile(lngPos, LongStr(lngVal, intLen))
  79. End Sub
  80.  
  81. 'WriteFile() writes strWrite to the file at lngPos.
  82. Public Sub WriteFile(lngPos As Long, ByVal strWrite As String)
  83.     If intFileNo = 0 Then Stop
  84.     Put #intFileNo, lngPos + 1, strWrite
  85.     'Update buffer if there is any overlap
  86.     If lngPos > (lngBufPos - Len(strWrite)) And lngPos < lngFilePos Then
  87.         Select Case lngPos
  88.         Case Is < lngBufPos
  89.             strWrite = Right(strWrite, lngPos + Len(strWrite) - lngBufPos)
  90.             lngPos = lngBufPos
  91.         Case Is > lngFilePos - Len(strWrite)
  92.             strWrite = Left(strWrite, lngFilePos - lngPos)
  93.         End Select
  94.         Mid(strBuffer, lngPos - lngBufPos + 1) = strWrite
  95.     End If
  96. End Sub
  97.  
  98. 'CloseFile() closes the file and tidies up the variables
  99. Private Sub CloseFile()
  100.     If intFileNo = 0 Then Exit Sub
  101.     Close #intFileNo
  102.     intFileNo = 0
  103. End Sub
  104.  
  105. 'Search() returns the position (in the file) of the next occurrence of strText
  106. 'starting from lngPos where the extra parameter pairs (if passed) are also
  107. 'found in the locations passed.
  108. 'If not found then -1 returned.
  109. Public Function Search(lngPos As Long, ByVal strText As String, _
  110.                        ParamArray avarArgs() As Variant) As Long
  111.     Dim lngSize As Long, lngX As Long, lngY As Long, lngStrPos As Long
  112.     Dim strCheck As String
  113.  
  114.     strText = FromSpecial(strText)
  115.     lngSize = Len(strText)
  116.     For lngX = LBound(avarArgs) To UBound(avarArgs) Step 2
  117.         lngY = avarArgs(lngX) + Len(FromSpecial(avarArgs(lngX + 1)))
  118.         If lngSize < lngY Then lngSize = lngY
  119.     Next lngX
  120.     'Logic relies on shunting by conDiskBuf so would fail if item larger
  121.     If lngSize > conDiskBuf Then Stop
  122.     If lngBufPos = -1 _
  123.     Or lngPos < lngBufPos _
  124.     Or lngPos > (lngFilePos - lngSize) Then Call ReadBuf(lngPos)
  125.     lngStrPos = lngPos - lngBufPos
  126.     Do
  127.         lngStrPos = InStr(lngStrPos + 1, strBuffer, strText, vbBinaryCompare)
  128.         Select Case lngStrPos
  129.         Case 0, Is > (Len(strBuffer) + 1 - lngSize)
  130.             'Not found, or main item found but no room in buffer to check others
  131.             If lngFilePos < lngFileLen Then
  132.                 If lngStrPos = 0 Then lngStrPos = Len(strBuffer) + 1 - lngSize
  133.                 lngStrPos = lngStrPos + conDiskBuf - Len(strBuffer) - 1
  134.                 Call ReadBuf
  135.             Else
  136.                 Search = -1
  137.                 Exit Do
  138.             End If
  139.         Case Else
  140.             For lngX = LBound(avarArgs) To UBound(avarArgs) Step 2
  141.                 lngY = lngStrPos + avarArgs(lngX)
  142.                 strCheck = FromSpecial(avarArgs(lngX + 1))
  143.                 If Mid(strBuffer, lngY, Len(strCheck)) <> strCheck Then Exit For
  144.             Next lngX
  145.             If lngX > UBound(avarArgs) Then
  146.                 Search = lngBufPos + lngStrPos - 1
  147.                 Exit Do
  148.             End If
  149.         End Select
  150.     Loop
  151. End Function
  152.  
  153. 'CheckData() returns True if strCheck NOT found in the file at lngPos.
  154. Public Function CheckData(lngPos As Long, strCheck As String) As Boolean
  155.     If lngPos < lngBufPos _
  156.     Or lngPos > (lngFilePos - Len(strCheck)) Then Call ReadBuf(lngPos)
  157.     CheckData = (ReadFile(lngPos, Len(strCheck)) <> strCheck)
  158. End Function
  159.  
  160. 'Class_Terminate() ensures all is tidied up before terminating.
  161. Private Sub Class_Terminate()
  162.     Call CloseFile
  163.     strName = ""
  164. End Sub
And, some supporting procedures from another module that are referenced by the above code :
Expand|Select|Wrap|Line Numbers
  1. 'ToSpecial() converts unprintable characters in strFrom into special Hex string
  2. Public Function ToSpecial(strFrom) As String
  3.     Dim strChar As String
  4.     Dim lngX As Long
  5.  
  6.     For lngX = 1 To Len(strFrom)
  7.         strChar = Mid(strFrom, lngX, 1)
  8.         If strChar < " " _
  9.         Or strChar > "~" _
  10.         Or strChar = "\" Then _
  11.             strChar = "\" & ToSpChr(strChar)
  12.         ToSpecial = ToSpecial & strChar
  13.     Next lngX
  14. End Function
  15.  
  16. 'ToSpChr() converts a character into its two representative hex characters
  17. Private Function ToSpChr(strChar As String) As String
  18.     Dim intChar As Integer
  19.  
  20.     ToSpChr = "0"
  21.     If Asc(strChar) > &HF Then _
  22.         ToSpChr = Right(ToSpChr(Chr(Asc(strChar) \ &H10)), 1)
  23.     intChar = Asc(strChar) Mod &H10
  24.     If intChar > 9 Then intChar = intChar + 7
  25.     ToSpChr = ToSpChr & Chr(Asc("0") + intChar)
  26. End Function
  27.  
  28. 'FromSpecial() converts \nn hex characters in a string to their char equivalent
  29. Public Function FromSpecial(strFrom) As String
  30.     Dim strChar As String
  31.     Dim lngX As Long
  32.  
  33.     For lngX = 1 To Len(strFrom)
  34.         strChar = Mid(strFrom, lngX, 1)
  35.         If strChar = "\" Then
  36.             strChar = FromSpChr(UCase(Mid(strFrom, lngX + 1, 2)))
  37.             lngX = lngX + 2
  38.         End If
  39.         FromSpecial = FromSpecial & strChar
  40.     Next lngX
  41. End Function
  42.  
  43. 'FromSpChr() converts two hex digits into their character equivalent
  44. Private Function FromSpChr(strVal As String) As String
  45.     FromSpChr = Chr(0)
  46.     If Left(strVal, 1) > "0" Then FromSpChr = FromSpChr(Left("0" & strVal, 2))
  47.     If Right(strVal, 1) > "9" Then strVal = Chr(Asc(Right(strVal, 1)) - 7)
  48.     FromSpChr = Chr(&H10 * Asc(FromSpChr) + Asc(Right(strVal, 1)) - Asc("0"))
  49. End Function
  50.  
  51. 'LongVal() returns the value of a string
  52. Public Function LongVal(strVal) As Long
  53.     If Len(strVal) < &H4 Then _
  54.         strVal = strVal & String(&H4 - Len(strVal), vbNullChar)
  55.     LongVal = ((Asc(Mid(strVal, 4)) And &H7F) * &H1000000) Or _
  56.               (Asc(Mid(strVal, 3)) * &H10000) Or _
  57.               (Asc(Mid(strVal, 2)) * &H100&) Or _
  58.               Asc(Mid(strVal, 1))
  59.     If Asc(Mid(strVal, 4)) And &H80 Then LongVal = LongVal Or &H80000000
  60. End Function
  61.  
  62. 'LongStr() returns the string equivalent of a numeric value.
  63. Public Function LongStr(lngVal As Long, _
  64.                         Optional intLen As Integer = &H4) As String
  65.     LongStr = Chr(lngVal And &HFF) & _
  66.               Chr((lngVal And &HFF00&) \ 2 ^ &H8) & _
  67.               Chr((lngVal And &HFF0000) \ 2 ^ &H10) & _
  68.               Chr(((lngVal And &HFF000000) \ 2 ^ &H18) And &HFF)
  69.     If intLen < &H4 Then LongStr = Left(LongStr, intLen)
  70. 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 :
Expand|Select|Wrap|Line Numbers
  1. Dim objSave = New clsSave
  2. ...
  3. 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.
1 Week Ago #1
  • viewed: 1118
Share:

Sign in to post your reply or Sign up for a free account.

Similar topics

4 posts views Thread by Ravi J | last post: by
3 posts views Thread by Zahid | last post: by
3 posts views Thread by Joseph Geretz | last post: by
2 posts views Thread by SharpCoderMP | last post: by
6 posts views Thread by raymond_b_jimenez | last post: by
reply views Thread by jack112 | last post: by
reply views Thread by MrMoon | last post: by
By using this site, you agree to our Privacy Policy and Terms of Use.