Win32 File API in VBA

Question

Win32 File API Wrapper

Based on a few fundamental frustrations with VBA (namely the lack of ability to work with files larger than 2GB, the lack of encapsulation of the file functions and the lack of intellisense to guide my use of the file statements) I put together a wrapper for the Win32 File API. This includes 64-bit functions which allow reading and writing past the 4GB limit of 32 bit addressing.

Concerns

One issue with this wrapper is that for the 32 bit functions, offsets larger than 2GB are negative numbers in VBA since it doesn't have unsigned longs, which I suppose is fine as long as you're aware of it, but it does make use of the API less intuitive and you have to be careful of offset math.

Another issue is the use of Currency for the 64 bit functions - it's kind of a hack and it again makes the math awkward. I would love to incorporate the GB, MB, KB consts into the class somehow, but Enum only supports longs and Const variables can't be public.

I'd appreciate any style advice, corrections to mistakes I've made or suggestions for how to make the wrapper more intuitive.

clsFile

Option Compare Database
Option Explicit
'Based on the example on msdn:
'http://support.microsoft.com/kb/189981
'Some of the constants come from Winnt.h
Public Enum SeekOrigin
 so_Begin = 0
 so_Current = 1
 so_End = 2
End Enum
Public Enum FileAccess
' FILE_READ_DATA = &H1 ' winnt.h:1801
' 'FILE_LIST_DIRECTORY = &H1 ' winnt.h:1802
' FILE_WRITE_DATA = &H2 ' winnt.h:1804
' 'FILE_ADD_FILE = &H2 ' winnt.h:1805
' FILE_APPEND_DATA = &H4 ' winnt.h:1807
' 'FILE_ADD_SUBDIRECTORY = &H4 ' winnt.h:1808
' 'FILE_CREATE_PIPE_INSTANCE = &H4 ' winnt.h:1809
' FILE_READ_EA = &H8 ' winnt.h:1811
' FILE_READ_PROPERTIES = &H8 ' winnt.h:1812
' FILE_WRITE_EA = &H10 ' winnt.h:1814
' FILE_WRITE_PROPERTIES = &H10 ' winnt.h:1815
' FILE_EXECUTE = &H20 ' winnt.h:1817
' 'FILE_TRAVERSE = &H20 ' winnt.h:1818
' 'FILE_DELETE_CHILD = &H40 ' winnt.h:1820
' FILE_READ_ATTRIBUTES = &H80 ' winnt.h:1822
' FILE_WRITE_ATTRIBUTES = &H100 ' winnt.h:1824
 FILE_ALL_ACCESS = &H1F01FF ' winnt.h:1826
 FILE_GENERIC_READ = &H120089 ' winnt.h:1828
 FILE_GENERIC_WRITE = &H120116 ' winnt.h:1835
' FILE_GENERIC_EXECUTE = &H1200A0 ' winnt.h:1843
' FILE_SHARE_READ = &H1 ' winnt.h:1848
' FILE_SHARE_WRITE = &H2 ' winnt.h:1849
' FILE_NOTIFY_CHANGE_FILE_NAME = &H1 ' winnt.h:1860
' FILE_NOTIFY_CHANGE_DIR_NAME = &H2 ' winnt.h:1861
' FILE_NOTIFY_CHANGE_ATTRIBUTES = &H4 ' winnt.h:1862
' FILE_NOTIFY_CHANGE_SIZE = &H8 ' winnt.h:1863
' FILE_NOTIFY_CHANGE_LAST_WRITE = &H10 ' winnt.h:1864
' FILE_NOTIFY_CHANGE_SECURITY = &H100 ' winnt.h:1865
' 'MAILSLOT_NO_MESSAGE = -1 ' winnt.h:1866
' 'MAILSLOT_WAIT_FOREVER = -1 ' winnt.h:1867
' FILE_CASE_SENSITIVE_SEARCH = &H1 ' winnt.h:1868
' FILE_CASE_PRESERVED_NAMES = &H2 ' winnt.h:1869
' FILE_UNICODE_ON_DISK = &H4 ' winnt.h:1870
' FILE_PERSISTENT_ACLS = &H8 ' winnt.h:1871
' FILE_FILE_COMPRESSION = &H10 ' winnt.h:1872
' FILE_VOLUME_IS_COMPRESSED = &H8000 ' winnt.h:1873
' IO_COMPLETION_MODIFY_STATE = &H2 ' winnt.h:1874
' IO_COMPLETION_ALL_ACCESS = &H1F0003 ' winnt.h:1875
' DUPLICATE_CLOSE_SOURCE = &H1 ' winnt.h:1876
' DUPLICATE_SAME_ACCESS = &H2 ' winnt.h:1877
' DELETE = &H10000 ' winnt.h:1935
' READ_CONTROL = &H20000 ' winnt.h:1936
' WRITE_DAC = &H40000 ' winnt.h:1937
' WRITE_OWNER = &H80000 ' winnt.h:1938
' SYNCHRONIZE = &H100000 ' winnt.h:1939
' STANDARD_RIGHTS_REQUIRED = &HF0000 ' winnt.h:1941
' STANDARD_RIGHTS_READ = &H20000 ' winnt.h:1943
' STANDARD_RIGHTS_WRITE = &H20000 ' winnt.h:1944
' STANDARD_RIGHTS_EXECUTE = &H20000 ' winnt.h:1945
' STANDARD_RIGHTS_ALL = &H1F0000 ' winnt.h:1947
' SPECIFIC_RIGHTS_ALL = &HFFFF ' winnt.h:1949
' ACCESS_SYSTEM_SECURITY = &H1000000
End Enum
Public Enum FileShare
 NONE = &H0
 FILE_SHARE_DELETE = &H4
 FILE_SHARE_READ = &H1
 FILE_SHARE_WRITE = &H2
End Enum
Public Enum FileCreationDisposition
 CREATE_ALWAYS = &H2
 CREATE_NEW = &H1
 OPEN_ALWAYS = &H4
 OPEN_EXISTING = &H3
 TRUNCATE_EXISTING = &H5
End Enum
'Public Enum FileFlagsAndAttributes
' 'Attributes
' FILE_ATTRIBUTE_ENCRYPTED = &H4000
' FILE_ATTRIBUTE_READONLY = &H1 ' winnt.h:1850
' FILE_ATTRIBUTE_HIDDEN = &H2 ' winnt.h:1851
' FILE_ATTRIBUTE_SYSTEM = &H4 ' winnt.h:1852
' FILE_ATTRIBUTE_DIRECTORY = &H10 ' winnt.h:1853
' FILE_ATTRIBUTE_ARCHIVE = &H20 ' winnt.h:1854
' FILE_ATTRIBUTE_NORMAL = &H80 ' winnt.h:1855
' FILE_ATTRIBUTE_TEMPORARY = &H100 ' winnt.h:1856
' FILE_ATTRIBUTE_ATOMIC_WRITE = &H200 ' winnt.h:1857
' FILE_ATTRIBUTE_XACTION_WRITE = &H400 ' winnt.h:1858
' FILE_ATTRIBUTE_COMPRESSED = &H800 ' winnt.h:1859
' 'Flags
' FILE_FLAG_BACKUP_SEMANTICS = &H2000000
' FILE_FLAG_DELETE_ON_CLOSE = &H4000000
' FILE_FLAG_NO_BUFFERING = &H20000000
' FILE_FLAG_OPEN_NO_RECALL = &H100000
' FILE_FLAG_OPEN_REPARSE_POINT = &H200000
' FILE_FLAG_OVERLAPPED = &H40000000
' FILE_FLAG_POSIX_SEMANTICS = &H100000
'End Enum
Private Const INVALID_FILE_HANDLE = -1 '&HFFFFFFFF
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const INVALID_FILE_SIZE As Long = -1 '&HFFFFFFFF
Private Const INVALID_SET_FILE_POINTER As Long = -1 '&HFFFFFFFF
Private Declare Function FormatMessage Lib "Kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, _
 lpSource As Long, _
 ByVal dwMessageId As Long, _
 ByVal dwLanguageId As Long, _
 ByVal lpBuffer As String, _
 ByVal nSize As Long, _
 Arguments As Any) As Long
Private Declare Function CreateFile Lib "Kernel32" Alias "CreateFileA" (ByVal lpFileName As String, _
 ByVal dwDesiredAccess As Long, _
 ByVal dwShareMode As Long, _
 lpSecurityAttributes As Long, _
 ByVal dwCreationDisposition As Long, _
 ByVal dwFlagsAndAttributes As Long, _
 hTemplateFile As Long) As Long
Private Declare Function SetFilePointer Lib "Kernel32" (ByVal hFile As Long, _
 ByVal lDistanceToMove As Long, _
 lpDistanceToMoveHigh As Long, _
 ByVal dwMoveMethod As Long) As Long
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 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 FlushFileBuffers Lib "Kernel32" (ByVal hFile As Long) As Long
Private Declare Function GetFileSize Lib "Kernel32" (ByVal hFile As Long, _
 lpFileSizeHigh As Long) As Long
Private Declare Function CloseHandle Lib "Kernel32" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (ByVal dest As Long, ByVal src As Long, ByVal size As Long)
Private m_Handle As Long
Private Sub Class_Terminate()
 If Not m_Handle = 0 Then
 Flush
 CloseFile
 End If
End Sub
Public Sub OpenFile(path As String, Optional access As FileAccess = FileAccess.FILE_GENERIC_READ, Optional share As FileShare = FileShare.NONE, Optional CreationDisposition As FileCreationDisposition = FileCreationDisposition.OPEN_ALWAYS)
 Dim Ret As Long
 Ret = CreateFile(path, access, share, ByVal 0&, CreationDisposition, 0&, ByVal 0&)
 If Ret = INVALID_FILE_HANDLE Then
 Err.Raise vbObjectError + Err.LastDllError, "clsFile.OpenFile", DecodeAPIErrors(Err.LastDllError)
 Else
 m_Handle = Ret
 End If
End Sub
'Properties
Public Property Get Length() As Double
 Dim Ret As Currency
 Dim FileSizeHigh As Long
 Ret = GetFileSize(m_Handle, FileSizeHigh)
 If Not Ret = INVALID_FILE_SIZE Then
 Length = Ret
 Else
 Err.Raise vbObjectError + Err.LastDllError, "clsFile.Length", DecodeAPIErrors(Err.LastDllError)
 End If
End Property
Public Property Get Position() As Long
 Dim Ret As Long
 Dim DistanceToMoveHigh As Long
 Ret = SetFilePointer(m_Handle, 0&, DistanceToMoveHigh, 1&) '1 is FILE_CURRENT
 If DistanceToMoveHigh = 0 Then
 If Ret = -1 Then
 Position = -1 'EOF'
 Else
 Position = Ret
 End If
 Else
 Class_Terminate
 Err.Raise vbObjectError + Err.LastDllError, "clsFile.Position", DecodeAPIErrors(Err.LastDllError)
 End If
End Property
Public Property Get Handle() As Long
 Handle = m_Handle
End Property
'Functions
Public Function ReadBytes(ByRef buffer() As Byte, ByVal buffer_offset As Long, ByVal count As Long) As Long
 Dim Ret As Long
 Dim BytesRead As Long
 Ret = ReadFile(m_Handle, buffer(buffer_offset), count, BytesRead, 0&)
 If Ret = 1 Then
 ReadBytes = BytesRead
 Else
 Class_Terminate
 Err.Raise vbObjectError + Err.LastDllError, "clsFile.ReadBytes", DecodeAPIErrors(Err.LastDllError)
 End If
End Function
Public Function ReadBytesPtr(ByVal ptrBuf As Long, ByVal buffer_offset As Long, ByVal count As Long) As Long
 Dim Ret As Long
 Dim BytesRead As Long
 Ret = ReadFile(m_Handle, ByVal ptrBuf + buffer_offset, count, BytesRead, 0&)
 If Ret = 1 Then
 ReadBytesPtr = BytesRead
 Else
 Class_Terminate
 Err.Raise vbObjectError + Err.LastDllError, "clsFile.ReadBytesPtr", DecodeAPIErrors(Err.LastDllError)
 End If
End Function
Public Function WriteBytes(ByRef buffer() As Byte, ByVal buffer_offset As Long, ByVal count As Long) As Long
 Dim Ret As Long
 Dim BytesWritten As Long
 Ret = WriteFile(m_Handle, buffer(buffer_offset), count, BytesWritten, 0&)
 If Ret = 1 Then
 WriteBytes = BytesWritten
 Else
 Class_Terminate
 Err.Raise vbObjectError + Err.LastDllError, "clsFile.WriteBytes", DecodeAPIErrors(Err.LastDllError)
 End If
End Function
Public Function WriteBytesPtr(ByVal ptrBuf As Long, ByVal buffer_offset As Long, ByVal count As Long) As Long
 Dim Ret As Long
 Dim BytesWritten As Long
 Ret = WriteFile(m_Handle, ByVal ptrBuf + buffer_offset, count, BytesWritten, 0&)
 If Ret = 1 Then
 WriteBytesPtr = BytesWritten
 Else
 Class_Terminate
 Err.Raise vbObjectError + Err.LastDllError, "clsFile.WriteBytes", DecodeAPIErrors(Err.LastDllError)
 End If
End Function
Public Function SeekFile(ByVal LoBytesOffset As Long, origin As SeekOrigin) As Long
 Dim Ret As Long
 Dim HiBytesOffset As Long
 Ret = SetFilePointer(m_Handle, LoBytesOffset, HiBytesOffset, origin)
 If Not Ret = INVALID_SET_FILE_POINTER Then
 SeekFile = Ret
 Else
 Err.Raise vbObjectError + Err.LastDllError, "clsFile.SeekFile", DecodeAPIErrors(Err.LastDllError)
 End If
End Function
Public Function SeekFile64bit(ByVal offset As Currency, origin As SeekOrigin) As Currency
'Take care with this function. A Currency variable is an 8-byte (64-bit) scaled (by 10,000) fixed-point number.'
'This means that setting a Currency variable to 0.0001 is the equivalent of a binary value of 1.'
'If you want to set an offset with an immediate value, write it like so:'
'1073741824 Bytes (1 GB) would be 107374.1824@, where @ is the symbol for an immediate Currency value.'
'Refer to http://support.microsoft.com/kb/189862 for hints on how to do 64-bit arithmetic'
 Dim Ret As Long
 Dim curFilePosition As Currency
 Dim LoBytesOffset As Long, HiBytesOffset As Long
 CopyMemory VarPtr(HiBytesOffset), VarPtr(offset) + 4, 4
 CopyMemory VarPtr(LoBytesOffset), VarPtr(offset), 4
 Ret = SetFilePointer(m_Handle, LoBytesOffset, HiBytesOffset, origin)
 CopyMemory VarPtr(curFilePosition) + 4, VarPtr(HiBytesOffset), 4
 CopyMemory VarPtr(curFilePosition), VarPtr(Ret), 4
 SeekFile64bit = curFilePosition
End Function
Public Sub CloseFile()
 Dim Ret As Long
 Ret = CloseHandle(m_Handle)
 m_Handle = 0
End Sub
Public Sub Flush()
 Dim Ret As Long
 Ret = FlushFileBuffers(m_Handle)
End Sub
 '***********************************************************************************
' Helper function, from Microsoft page as noted at top
Private Function DecodeAPIErrors(ByVal ErrorCode As Long) As String
 Dim sMessage As String, MessageLength As Long
 sMessage = Space$(256)
 MessageLength = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, _
 ErrorCode, 0&, sMessage, 256&, 0&)
 If MessageLength > 0 Then
 DecodeAPIErrors = Left(sMessage, MessageLength)
 Else
 DecodeAPIErrors = "Unknown Error."
 End If
End Function

And a example:

mdlMain

Option Compare Database
Option Explicit
Const GB As Currency = 107374.1824@
Const MB As Currency = 104.8576@
Const KB As Currency = 0.1024@
Public Sub Main()
 Dim oFile As New clsFile
 oFile.OpenFile "largefilepath"
 oFile.SeekFile64bit 6 * GB, so_Begin
End Sub

• RubberDuck: Man, every time I think I write some hardcore stuff in VBA, you show up. ++
• Blackhawk: @RubberDuck Coming from you, that's a HUGE compliment, thanks!

Answer 1

I'm not overly familiar with using WinApi calls from VBA, but I'll do my best here, because this is a cool piece of code. Let's get started.

Option Compare Database

This line ties your class to access. It won't compile in any other host app. I try to keep utility classes like this host agnostic. Removing this option will allow you to use this class in any app that supports VBA. I honestly don't like this option anyway. It ties how the code behaves to the environment it's running in by letting Access determine how string comparisons are made. If you're going to use an Option Compare, choose either Text or Binary depending on your needs. Both of those are available in any of the host apps by the way. (I know, Access probably inserted this line for you, moving on...)

'Based on the example on msdn:
'http://support.microsoft.com/kb/189981

I love comments like this. Awesome. Well done!, but MS is notorious for killing urls on a whim with no redirect. It would help to leave the title of the article so it can be searched for if the link goes dead.

Public Enum FileAccess
' FILE_READ_DATA = &H1 ' winnt.h:1801
' 'FILE_LIST_DIRECTORY = &H1 ' winnt.h:1802
' FILE_WRITE_DATA = &H2 ' winnt.h:1804
' 'FILE_ADD_FILE = &H2 ' winnt.h:1805
' FILE_APPEND_DATA = &H4 ' winnt.h:1807

Normally, I'd say that this is dead code and you should kill it, but I get why you've done this. It's good documentation and all the work is already done should you decide that you need any of these additional values. I'd leave a comment threatening a psychotic episode should anyone ever "be helpful" and remove it, because, let's face it, someone like me could easily come along and wipe out all this "dead code" without batting an eye about it.

Private Const INVALID_FILE_HANDLE = -1 '&HFFFFFFFF
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const INVALID_FILE_SIZE As Long = -1 '&HFFFFFFFF
Private Const INVALID_SET_FILE_POINTER As Long = -1 '&HFFFFFFFF

It's petty, and doesn't really matter, but I might do this the other way round for consistency, or better yet, leave a single explanatory comment.

' &HFFFFFFFF == -1
' &H1000 == 4096 
Private Const INVALID_FILE_HANDLE = &HFFFFFFFF 
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const INVALID_FILE_SIZE As Long = &HFFFFFFFF 
Private Const INVALID_SET_FILE_POINTER As Long = &HFFFFFFFF

I like the way you're handling errors, but you could extract a method to reduce the duplication.

Private Sub RaiseError(ByVal caller As String)
 Err.Raise vbObjectError + Err.LastDllError, TypeName(Me) & "." & caller, DecodeAPIErrors(Err.LastDllError)
End Sub

There's a magic number in SeekFile64bit.

CopyMemory VarPtr(HiBytesOffset), VarPtr(offset) + 4, 4
CopyMemory VarPtr(LoBytesOffset), VarPtr(offset), 4
Ret = SetFilePointer(m_Handle, LoBytesOffset, HiBytesOffset, origin)
CopyMemory VarPtr(curFilePosition) + 4, VarPtr(HiBytesOffset), 4
CopyMemory VarPtr(curFilePosition), VarPtr(Ret), 4

I'm not terribly familiar with directly working with pointers this way, so I have no idea why this uses 4. A well named constant would help a schmuck like me understand what's happening here.

---

And that's all very minor really. This is good code. Unfortunately, I've no better ideas about how to simplify the API. It's a side effect of needing to use the Currency type to get large enough values. I've got.... nothing. I think the best you can do is add some example code inside of the class and document the use of the class's API as best you can.

What you may be able to do is some precompiler directive magic. You're using currency to get a 64bit integer, right? Well, on 64bit installs, there's the LongLong type. So, you might be able to clean this up for use in that environment, but in my experience, very people are actually running 64bit installs of office, so it may not be worth the effort. Particularly when it would mean that you would effectively have two APIs for the same class.

• ThunderFrame: the 4's are for the length, in bytes, of the memory to copy. 4 bytes being the size of a Long.
• RubberDuck: If that's true @ThunderFrame, then the sizeof() function would be a good option too.
• ThunderFrame: AFAIK, sizeof doesn't exist in VBA, but in any case, neither the size of the destination variable, or the size of the source variable are useful, as CopyMemory permits you to copy fewer bytes than the source or the destination variables actually hold (which is, for example, why CopyMemory can copy partial arrays). I do see your point about magic numbers, but in this case a constant like Const SIZE_OF_LONG as Long = 4, might be better.
• RubberDuck: Oops. Wrong language @ThunderFrame. My bad.

Answer 2

This was a great find while looking for FileSeek capability from VBA. The only issue I had was when trying to go backwards from the current position. It turns out there's a simple trick to tell SetFilePointer that you want to go backwards. I modified your SeekFile routine to this and it works great now when passing a negative offset.

Public Function SeekFile(ByVal LoBytesOffset As Long, origin As SeekOrigin) As Long
 Dim Ret As Long
 Dim HiBytesOffset As Long
 ' Modified from Notes at http://www.jasinskionline.com/windowsapi/ref/s/setfilepointer.html
 ' On how to handle Negative Seeks
 ' Note how the lowbyte and highbyte numbers must be manipulated to represent a negative value.
 If LoBytesOffset < 0 Then
 LoBytesOffset = (Not Abs(LoBytesOffset)) + 1
 HiBytesOffset = Not 0
 End If
 Ret = SetFilePointer(m_Handle, LoBytesOffset, HiBytesOffset, origin)
 If Not Ret = INVALID_SET_FILE_POINTER Then
 SeekFile = Ret
 Else
 Err.Raise vbObjectError + Err.LastDllError, "clsFile.SeekFile", DecodeAPIErrors(Err.LastDllError)
 End If
End Function