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

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.

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