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 theGB,MB,KB consts into the class somehow, butEnum only supports longs andConst 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 DatabaseOption Explicit'Based on the example on msdn:'http://support.microsoft.com/kb/189981'Some of the constants come from Winnt.hPublic Enum SeekOrigin so_Begin = 0 so_Current = 1 so_End = 2End EnumPublic 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 = &H1000000End EnumPublic Enum FileShare NONE = &H0 FILE_SHARE_DELETE = &H4 FILE_SHARE_READ = &H1 FILE_SHARE_WRITE = &H2End EnumPublic Enum FileCreationDisposition CREATE_ALWAYS = &H2 CREATE_NEW = &H1 OPEN_ALWAYS = &H4 OPEN_EXISTING = &H3 TRUNCATE_EXISTING = &H5End 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 EnumPrivate Const INVALID_FILE_HANDLE = -1 '&HFFFFFFFFPrivate Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000Private Const INVALID_FILE_SIZE As Long = -1 '&HFFFFFFFFPrivate Const INVALID_SET_FILE_POINTER As Long = -1 '&HFFFFFFFFPrivate 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 LongPrivate 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 LongPrivate Declare Function SetFilePointer Lib "Kernel32" (ByVal hFile As Long, _ ByVal lDistanceToMove As Long, _ lpDistanceToMoveHigh As Long, _ ByVal dwMoveMethod As Long) As LongPrivate Declare Function ReadFile Lib "Kernel32" (ByVal hFile As Long, _ lpBuffer As Any, _ ByVal nNumberOfBytesToRead As Long, _ lpNumberOfBytesRead As Long, _ ByVal lpOverlapped As Long) As LongPrivate Declare Function WriteFile Lib "Kernel32" (ByVal hFile As Long, _ lpBuffer As Any, _ ByVal nNumberOfBytesToWrite As Long, _ lpNumberOfBytesWritten As Long, _ ByVal lpOverlapped As Long) As LongPrivate Declare Function FlushFileBuffers Lib "Kernel32" (ByVal hFile As Long) As LongPrivate Declare Function GetFileSize Lib "Kernel32" (ByVal hFile As Long, _ lpFileSizeHigh As Long) As LongPrivate Declare Function CloseHandle Lib "Kernel32" (ByVal hObject As Long) As LongPrivate Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (ByVal dest As Long, ByVal src As Long, ByVal size As Long)Private m_Handle As LongPrivate Sub Class_Terminate() If Not m_Handle = 0 Then Flush CloseFile End IfEnd SubPublic 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 IfEnd Sub'PropertiesPublic 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 IfEnd PropertyPublic 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 IfEnd PropertyPublic Property Get Handle() As Long Handle = m_HandleEnd Property'FunctionsPublic 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 IfEnd FunctionPublic 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 IfEnd FunctionPublic 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 IfEnd FunctionPublic 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 IfEnd FunctionPublic 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 IfEnd FunctionPublic 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 = curFilePositionEnd FunctionPublic Sub CloseFile() Dim Ret As Long Ret = CloseHandle(m_Handle) m_Handle = 0End SubPublic Sub Flush() Dim Ret As Long Ret = FlushFileBuffers(m_Handle)End Sub '***********************************************************************************' Helper function, from Microsoft page as noted at topPrivate 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 IfEnd FunctionAnd a example:
mdlMain
Option Compare DatabaseOption ExplicitConst 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_BeginEnd Sub
- 4\$\begingroup\$Man, every time I think I write some hardcore stuff in VBA, you show up. ++\$\endgroup\$RubberDuck– RubberDuck2015-08-28 23:27:17 +00:00CommentedAug 28, 2015 at 23:27
- 2\$\begingroup\$@RubberDuck Coming from you, that's a HUGE compliment, thanks!\$\endgroup\$Blackhawk– Blackhawk2015-08-31 12:29:42 +00:00CommentedAug 31, 2015 at 12:29
2 Answers2
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 toaccess. 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 anOption Compare, choose eitherText orBinary 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
Ilove 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 '&HFFFFFFFFPrivate Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000Private Const INVALID_FILE_SIZE As Long = -1 '&HFFFFFFFFPrivate 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 = &H1000Private Const INVALID_FILE_SIZE As Long = &HFFFFFFFF Private Const INVALID_SET_FILE_POINTER As Long = &HFFFFFFFFI 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 SubThere's a magic number inSeekFile64bit.
CopyMemory VarPtr(HiBytesOffset), VarPtr(offset) + 4, 4CopyMemory VarPtr(LoBytesOffset), VarPtr(offset), 4Ret = SetFilePointer(m_Handle, LoBytesOffset, HiBytesOffset, origin)CopyMemory VarPtr(curFilePosition) + 4, VarPtr(HiBytesOffset), 4CopyMemory VarPtr(curFilePosition), VarPtr(Ret), 4
I'm not terribly familiar with directly working with pointers this way, so I have no idea why this uses4. 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 ofneeding to use theCurrency 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 youmay 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 theLongLong 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 havetwo APIs for the same class.
- \$\begingroup\$the 4's are for the length, in bytes, of the memory to copy. 4 bytes being the size of a Long.\$\endgroup\$ThunderFrame– ThunderFrame2016-05-22 07:41:09 +00:00CommentedMay 22, 2016 at 7:41
- \$\begingroup\$If that's true @ThunderFrame, then the
sizeof()function would be a good option too.\$\endgroup\$RubberDuck– RubberDuck2016-05-22 10:39:07 +00:00CommentedMay 22, 2016 at 10:39 - \$\begingroup\$AFAIK,
sizeofdoesn'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 likeConst SIZE_OF_LONG as Long = 4, might be better.\$\endgroup\$ThunderFrame– ThunderFrame2016-05-22 12:48:52 +00:00CommentedMay 22, 2016 at 12:48 - \$\begingroup\$Oops. Wrong language @ThunderFrame. My bad.\$\endgroup\$RubberDuck– RubberDuck2016-05-22 13:12:23 +00:00CommentedMay 22, 2016 at 13:12
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 IfEnd Function
You mustlog in to answer this question.
Explore related questions
See similar questions with these tags.