Improved DataVault

DataVault.cls

Option Compare Binary
Option Explicit

Private Const ModuleName As String = "DataVault"
Private Const NullPtr As LongPtr = &H0

Private Enum ActionTypes
    RunWriteData
    RunReadData
    GetVaultSizeInBytes
    GetVaultSizeInCharacters
    GetLastDllError
    RunReleaseVault
End Enum

Private Enum AllocationTypes
    MEM_COMMIT = &H1000&            'Allocates memory charges (from the overall size of memory and the paging files on disk) for the specified reserved memory pages. The function also guarantees that when the caller later initially accesses the memory, the contents will be zero. Actual physical pages are not allocated unless/until the virtual addresses are actually accessed. To reserve and commit pages in one step, call VirtualAlloc with MEM_COMMIT | MEM_RESERVE. Attempting to commit a specific address range by specifying MEM_COMMIT without MEM_RESERVE and a non-NULL lpAddress fails unless the entire range has already been reserved. The resulting error code is ERROR_INVALID_ADDRESS. An attempt to commit a page that is already committed does not cause the function to fail. This means that you can commit pages without first determining the current commitment state of each page. If lpAddress specifies an address within an enclave, flAllocationType must be MEM_COMMIT.
    MEM_RESERVE = &H2000&           'Reserves a range of the process's virtual address space without allocating any actual physical storage in memory or in the paging file on disk. You can commit reserved pages in subsequent calls to the VirtualAlloc function. To reserve and commit pages in one step, call VirtualAlloc with MEM_COMMIT | MEM_RESERVE. Other memory allocation functions, such as malloc and LocalAlloc, cannot use a reserved range of memory until it is released.
    MEM_RESET = &H80000             'Indicates that data in the memory range specified by lpAddress and dwSize is no longer of interest. The pages should not be read from or written to the paging file. However, the memory block will be used again later, so it should not be decommitted. This value cannot be used with any other value. Using this value does not guarantee that the range operated on with MEM_RESET will contain zeros. If you want the range to contain zeros, decommit the memory and then recommit it. When you specify MEM_RESET, the VirtualAlloc function ignores the value of flProtect. However, you must still set flProtect to a valid protection value, such as PAGE_NOACCESS. VirtualAlloc returns an error if you use MEM_RESET and the range of memory is mapped to a file. A shared view is only acceptable if it is mapped to a paging file.
    MEM_TOP_DOWN = &H100000         'Allocates memory at the highest possible address. This can be slower than regular allocations, especially when there are many allocations.
    MEM_WRITE_WATCH = &H200000      'Causes the system to track pages that are written to in the allocated region. If you specify this value, you must also specify MEM_RESERVE.
    MEM_PHYSICAL = &H400000         'Reserves an address range that can be used to map Address Windowing Extensions (AWE) pages. This value must be used with MEM_RESERVE and no other values.
    MEM_RESET_UNDO = &H1000000      'MEM_RESET_UNDO should only be called on an address range to which MEM_RESET was successfully applied earlier. It indicates that the data in the specified memory range specified by lpAddress and dwSize is of interest to the caller and attempts to reverse the effects of MEM_RESET. If the function succeeds, that means all data in the specified address range is intact. If the function fails, at least some of the data in the address range has been replaced with zeroes. This value cannot be used with any other value. If MEM_RESET_UNDO is called on an address range which was not MEM_RESET earlier, the behavior is undefined. When you specify MEM_RESET, the VirtualAlloc function ignores the value of flProtect. However, you must still set flProtect to a valid protection value, such as PAGE_NOACCESS.
    MEM_LARGE_PAGES = &H20000000    'Allocates memory using large page support. The size and alignment must be a multiple of the large-page minimum. To obtain this value, use the GetLargePageMinimum function. If you specify this value, you must also specify MEM_RESERVE and MEM_COMMIT.
End Enum

Private Enum ProtectTypes
    PAGE_NOACCESS = &H1&                'Disables all access to the committed region of pages. An attempt to read from, write to, or execute the committed region results in an access violation.
    PAGE_READONLY = &H2&                'Enables read-only access to the committed region of pages. An attempt to write to the committed region results in an access violation. If Data Execution Prevention is enabled, an attempt to execute code in the committed region results in an access violation.
    PAGE_READWRITE = &H4&               'Enables read-only or read/write access to the committed region of pages. If Data Execution Prevention is enabled, attempting to execute code in the committed region results in an access violation.
    PAGE_WRITECOPY = &H8&               'Enables read-only or copy-on-write access to a mapped view of a file mapping object. An attempt to write to a committed copy-on-write page results in a private copy of the page being made for the process. The private page is marked as PAGE_READWRITE, and the change is written to the new page. If Data Execution Prevention is enabled, attempting to execute code in the committed region results in an access violation.
    PAGE_EXECUTE = &H10&                'Enables execute access to the committed region of pages. An attempt to write to the committed region results in an access violation.
    PAGE_EXECUTE_READ = &H20&           'Enables execute or read-only access to the committed region of pages. An attempt to write to the committed region results in an access violation.
    PAGE_EXECUTE_READWRITE = &H40&      'Enables execute, read-only, or read/write access to the committed region of pages.
    PAGE_EXECUTE_WRITECOPY = &H80&      'Enables execute, read-only, or copy-on-write access to a mapped view of a file mapping object. An attempt to write to a committed copy-on-write page results in a private copy of the page being made for the process. The private page is marked as PAGE_EXECUTE_READWRITE, and the change is written to the new page.
    PAGE_GUARD = &H100&                 'Pages in the region become guard pages. Any attempt to access a guard page causes the system to raise a STATUS_GUARD_PAGE_VIOLATION exception and turn off the guard page status. Guard pages thus act as a one-time access alarm.
    PAGE_NOCACHE = &H200                'Sets all pages to be non-cachable. Applications should not use this attribute except when explicitly required for a device. Using the interlocked functions with memory that is mapped with SEC_NOCACHE can result in an EXCEPTION_ILLEGAL_INSTRUCTION exception.
    PAGE_WRITECOMBINE = &H400&          'Sets all pages to be write-combined. Applications should not use this attribute except when explicitly required for a device. Using the interlocked functions with memory that is mapped as write-combined can result in an EXCEPTION_ILLEGAL_INSTRUCTION exception.
    PAGE_TARGETS_INVALID = &H40000000   'Sets all locations in the pages as invalid targets for CFG. Used along with any execute page protection like PAGE_EXECUTE, PAGE_EXECUTE_READ, PAGE_EXECUTE_READWRITE and PAGE_EXECUTE_WRITECOPY. Any indirect call to locations in those pages will fail CFG checks and the process will be terminated. The default behavior for executable pages allocated is to be marked valid call targets for CFG.
    PAGE_TARGETS_NO_UPDATE = &H40000000 'Pages in the region will not have their CFG information updated while the protection changes for VirtualProtect. For example, if the pages in the region was allocated using PAGE_TARGETS_INVALID, then the invalid information will be maintained while the page protection changes. This flag is only valid when the protection changes to an executable type like PAGE_EXECUTE, PAGE_EXECUTE_READ, PAGE_EXECUTE_READWRITE and PAGE_EXECUTE_WRITECOPY. The default behavior for VirtualProtect protection change to executable is to mark all locations as valid call targets for CFG.
End Enum

Private Enum FreeTypes
    MEM_DECOMMIT = &H4000&  'Decommits the specified region of committed pages. After the operation, the pages are in the reserved state. The function does not fail if you attempt to decommit an uncommitted page. This means that you can decommit a range of pages without first determining the current commitment state. Do not use this value with MEM_RELEASE. The MEM_DECOMMIT value is not supported when the lpAddress parameter provides the base address for an enclave.
    MEM_RELEASE = &H8000&   'Releases the specified region of pages. After this operation, the pages are in the free state. If you specify this value, dwSize must be 0 (zero), and lpAddress must point to the base address returned by the VirtualAlloc function when the region is reserved. The function fails if either of these conditions is not met. If any pages in the region are committed currently, the function first decommits, and then releases them. The function does not fail if you attempt to release pages that are in different states, some reserved and some committed. This means that you can release a range of pages without first determining the current commitment state. Do not use this value with MEM_DECOMMIT.
End Enum

Private Declare PtrSafe Function VirtualAlloc Lib "kernel32" ( _
    ByVal lpAddress As LongPtr, _
    ByVal dwSize As LongPtr, _
    ByVal flAllocationType As AllocationTypes, _
    ByVal flProtect As ProtectTypes _
) As LongPtr

Private Declare PtrSafe Function VirtualProtect Lib "kernel32" ( _
    ByVal lpAddress As LongPtr, _
    ByVal dwSize As LongPtr, _
    ByVal flNewProtect As ProtectTypes, _
    ByRef lpflOldProtect As ProtectTypes _
) As Boolean

Private Declare PtrSafe Function VirtualFree Lib "kernel32" ( _
    ByVal lpAddress As LongPtr, _
    ByVal dwSize As LongPtr, _
    ByVal dwFreeType As FreeTypes _
) As Boolean

Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByVal Destination As LongPtr, _
    ByVal Source As LongPtr, _
    ByVal Length As LongPtr _
)

Private Type TDataVault
    BaseAddress As LongPtr
    VaultSizeInCharacter As LongPtr
    VaultSizeInBytes As LongPtr
    LastDllError As Long
    OldProtectType As ProtectTypes
End Type
    
Private Function Execute(Action As ActionTypes, Optional PrivateString As String) As Variant
    Static This As TDataVault
    
    Select Case Action
        Case ActionTypes.RunWriteData
            Dim BufferPointer As LongPtr
        
            This.VaultSizeInCharacter = Len(PrivateString)
            This.VaultSizeInBytes = LenB(PrivateString)
            This.BaseAddress = VirtualAlloc(NullPtr, This.VaultSizeInBytes, MEM_COMMIT, PAGE_READWRITE)
            If This.BaseAddress Then
                BufferPointer = StrPtr(PrivateString)
                CopyMemory This.BaseAddress, BufferPointer, This.VaultSizeInBytes
                This.LastDllError = Err.LastDllError
            End If
        
            If This.LastDllError = NullPtr Then
                If VirtualProtect(This.BaseAddress, This.VaultSizeInBytes, PAGE_NOACCESS, This.OldProtectType) = False Then
                    This.LastDllError = Err.LastDllError
                End If
        
                If This.LastDllError = NullPtr Then
                    PrivateString = vbNullString
                End If
            End If
        
            If This.LastDllError Then
                'No point in checking the return because we are in an
                'error state
                ReleaseVault
            End If
        
            Execute = ((This.BaseAddress <> NullPtr) And (This.LastDllError = NullPtr))
        Case ActionTypes.RunReadData
            Dim OutputBuffer As String
            Dim OutputPointer As LongPtr
        
            If This.BaseAddress = NullPtr Then
                Err.Raise 5, ModuleName, "Cannot read data; not initialized."
            End If
        
            OutputBuffer = Space$(This.VaultSizeInCharacter)
            OutputPointer = StrPtr(OutputBuffer)
        
            If VirtualProtect(This.BaseAddress, This.VaultSizeInBytes, PAGE_READONLY, This.OldProtectType) = False Then
                This.LastDllError = Err.LastDllError
            End If
        
            If This.LastDllError = NullPtr Then
                CopyMemory OutputPointer, This.BaseAddress, This.VaultSizeInBytes
                This.LastDllError = Err.LastDllError
            End If
        
            If This.LastDllError = NullPtr Then
                If VirtualProtect(This.BaseAddress, This.VaultSizeInBytes, PAGE_NOACCESS, This.OldProtectType) = False Then
                    This.LastDllError = Err.LastDllError
                End If
            End If
        
            If This.LastDllError = NullPtr Then
                PrivateString = OutputBuffer
                Execute = Len(PrivateString)
            Else
                'No point in checking the return because we are in an
                'error state
                ReleaseVault
                Execute = False
            End If
        Case ActionTypes.GetVaultSizeInBytes
            Execute = This.VaultSizeInBytes
        Case ActionTypes.GetVaultSizeInCharacters
            Execute = This.VaultSizeInCharacter
        Case ActionTypes.GetLastDllError
            Execute = This.LastDllError
        Case ActionTypes.RunReleaseVault
            Execute = VirtualFree(This.BaseAddress, NullPtr, MEM_RELEASE)
            This.BaseAddress = NullPtr
            This.VaultSizeInBytes = NullPtr
            This.VaultSizeInCharacter = NullPtr
    End Select
End Function

Friend Property Get VaultSizeInBytes() As LongPtr
    VaultSizeInBytes = Execute(ActionTypes.GetVaultSizeInBytes)
End Property

Friend Property Get VaultSizeInCharacters() As LongPtr
    VaultSizeInCharacters = Execute(ActionTypes.GetVaultSizeInCharacters)
End Property

Friend Property Get LastDllError() As Long
    LastDllError = Execute(ActionTypes.GetLastDllError)
End Property

Friend Function WriteData(ByRef PrivateString As String) As Boolean
    WriteData = Execute(ActionTypes.RunWriteData, PrivateString)
End Function

Friend Function ReadData(ByRef PrivateString) As Boolean
    Dim TempString As String
    If Execute(ActionTypes.RunReadData, TempString) Then
        ReadData = True
        PrivateString = TempString
    Else
        ReadData = False
        PrivateString = Null
    End If
End Function

Private Function ReleaseVault() As Boolean
    ReleaseVault = Execute(ActionTypes.RunReleaseVault)
End Function

Private Sub Class_Terminate()
    ReleaseVault
End Sub