Как скопировать участок памяти в переменную типа Variant?

Option Explicit
 
Private Declare Function SetFilePointer Lib "kernel32.dll" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileW" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToRead As Long, lpNumberOfByConstesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
 
Const NO_ERROR                  As Long = 0&
Const INVALID_SET_FILE_POINTER  As Long = &HFFFFFFFF
Const FILE_BEGIN                As Long = 0&
Const FILE_CURRENT              As Long = 1&
Const FILE_END                  As Long = 2&
Const GENERIC_READ              As Long = &H80000000
Const GENERIC_WRITE             As Long = &H40000000
Const FILE_SHARE_READ           As Long = 1&
Const FILE_SHARE_WRITE          As Long = 2&
Const OPEN_EXISTING             As Long = 3&
Const INVALID_HANDLE_VALUE      As Long = -1&
 
 
sub form_load()
 
    Dim hFile       As Long
    Dim FileName    As String
    Dim PE_offset   As Long
 
    FileName = "d:\Наши проекты\Check Browsers LNK\Check Browsers LNK.exe"
 
    hFile = CreateFile(StrPtr(FileName), GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, ByVal 0&, ByVal 0&)
    
    If hFile = INVALID_HANDLE_VALUE Then Err.Raise 52
 
    GetW hFile, &H3C, PE_offset
 
    stop
end sub
 
Function GetW(hFile As Long, Pos As Long, vOut As Variant) As Long
    On Error GoTo ErrorHandler
    Dim lBytesRead  As Long
    Dim lVar_       As Long
    Dim iVar_       As Integer
    Dim sVar_       As String
    Dim cVar_       As Currency
    
    If INVALID_SET_FILE_POINTER <> SetFilePointer(hFile, Pos, ByVal 0&, FILE_BEGIN) Then
        If NO_ERROR = Err.LastDllError Then
            Select Case VarType(vOut)
            Case vbString
                If 0 = ReadFile(hFile, StrPtr(sVar_), Len(sVar_), lBytesRead, 0&) Then WriteC "Cannot read file!", cErr: Err.Raise 52
                vOut = sVar_
            Case vbLong
                If 0 = ReadFile(hFile, VarPtr(lVar_), LenB(lVar_), lBytesRead, 0&) Then WriteC "Cannot read file!", cErr: Err.Raise 52
                vOut = lVar_
            Case vbInteger
                If 0 = ReadFile(hFile, VarPtr(iVar_), LenB(iVar_), lBytesRead, 0&) Then WriteC "Cannot read file!", cErr: Err.Raise 52
                vOut = iVar_
            Case vbCurrency
                If 0 = ReadFile(hFile, VarPtr(cVar_), LenB(cVar_), lBytesRead, 0&) Then WriteC "Cannot read file!", cErr: Err.Raise 52
                vOut = cVar_
            Case Else
                WriteC "Error! GetW for type #" & VarType(vOut) & " of buffer is not supported.", cErr
            End Select
        Else
            WriteC "Cannot set file pointer!", cErr: Err.Raise 52
        End If
    Else
        WriteC "Cannot set file pointer!", cErr: Err.Raise 52
    End If
    
    Exit Function
ErrorHandler:
    WriteC "Error #" & Err.Number & ". LastDll=" & Err.LastDllError & ". " & Err.Description, cErr
    'ExitProcess 1
End Function
 
Private Sub WriteC(ByVal txt As String, cHandle As Long)
    'txt = txt & vbNewLine
    'WriteConsole cHandle, ByVal txt, Len(txt), 0&, ByVal 0&
End Sub

Option Explicit
 
' File Mapping example by Comintern (vbforums.com)
'
' Fork by Dragokas
' Added missed CloseHandle & recover of array pointer & some code protections
 
'API DECs
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, _
                                                                     ByVal ByteLen As Long)
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileW" (ByVal lpFileName As Long, _
                                         ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
                                         ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, _
                                         ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
'MEMORY MAPPING APIs
Private Declare Function MapViewOfFile Lib "kernel32.dll" (ByVal hFile As Long, ByVal dwDesiredAccess As Long, _
                                         ByVal dwFileOffsetHigh As Long, ByVal dwFileOffsetLow As Long, _
                                         ByVal dwNumberOfBytesToMap As Long) As Long
Private Declare Function CreateFileMapping Lib "kernel32.dll" Alias "CreateFileMappingA" (ByVal hFile As Long, _
                                         ByVal lpAttributes As Long, ByVal flProtect As Long, _
                                         ByVal dwMaximumSizeHigh As Long, ByVal dwMaximumSizeLow As Long, _
                                         ByVal lpName As String) As Long
Private Declare Function UnmapViewOfFile Lib "kernel32.dll" (ByVal lpBaseAddress As Long) As Boolean
 
'STRUCTS FOR THE SAFEARRAY:
Private Type SafeBound
    cElements As Long
    lLbound As Long
End Type
 
Private Type SafeArray
    cDim As Integer
    fFeature As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    rgsabound As SafeBound
End Type
 
'MISC CONSTs
Private Const VT_BY_REF = &H4000&
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const MOVEFILE_REPLACE_EXISTING = &H1
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_BEGIN = 0
Private Const CREATE_NEW = 1
Private Const OPEN_EXISTING = 3
Private Const OPEN_ALWAYS = 4
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const PAGE_READWRITE = 4
Private Const FILE_MAP_WRITE = &H2
Private Const FILE_MAP_READ = &H4
Private Const FADF_FIXEDSIZE = &H10
Private Const INVALID_HANDLE_VALUE As Long = -1&
 
Public Sub MapFileMemory()
    Dim hFile As Long, sFile As String, lPointer As Long, hFileMap As Long, lFileLen As Long, uTemp As SafeArray, oldTemp As SafeArray
    Dim bBytes() As Byte
 
    sFile = "c:\temp\Test2.txt"                         'Set the filename.
    
    lFileLen = FileLen(sFile)                           'Find the length of the target file.
    
    If lFileLen = 0 Then Exit Sub                       'dwMaximumSizeLow of CreateFileMapping cannot be 0, if file size is 0.
    
                                                        'Map it.
    hFile = CreateFile(StrPtr(sFile), GENERIC_READ Or GENERIC_WRITE, 0&, 0&, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0&)
    If hFile = INVALID_HANDLE_VALUE Then Exit Sub
    
    hFileMap = CreateFileMapping(hFile, 0&, PAGE_READWRITE, 0&, 0&, "MySharedMapping")
    If hFileMap = 0 Then Exit Sub
    
    lPointer = MapViewOfFile(hFileMap, FILE_MAP_WRITE, 0&, 0&, 0&)
    If lPointer = 0 Then Exit Sub
 
    bBytes = StrConv("TestTestTest", vbFromUnicode)     'Create an array.
    
    If GetArrayInfo(bBytes, uTemp) Then                 'Load the UDT with the array info.
        oldTemp = uTemp                                 'Backup old array struct
        uTemp.cbElements = 1                            'Set element size to a byte.
        uTemp.rgsabound.cElements = lFileLen            'Set the UBound of the array.
        uTemp.fFeature = uTemp.fFeature And FADF_FIXEDSIZE  'Set the "Fixed size" flag, SHOULD MAKE REDIM FAIL!
        uTemp.pvData = lPointer                         'Point it to the memory mapped file as it's data.
        Call AlterArray(bBytes, uTemp)                  'Write the UDT over the old array.
    End If
 
    For lFileLen = LBound(bBytes) To UBound(bBytes)     'This should be reading from the file.
        Debug.Print bBytes(lFileLen)
    Next lFileLen
 
    bBytes(0) = 61                                      'Change the first char to a "=" to see if it worked.
    
    Call AlterArray(bBytes, oldTemp)                    'Recover array struct
    UnmapViewOfFile lPointer                            'Release the memory map.
    CloseHandle hFileMap                                'Close File Mapping
    CloseHandle hFile                                   'Close the opened file.
 
End Sub
 
Private Function GetArrayInfo(vArray As Variant, uInfo As SafeArray) As Boolean
    
    'NOTE, the array is passed as a variant so we can get it's absolute memory address.  This function
    'loads a copy of the SafeArray structure into the UDT.
    
    Dim lPointer As Long, iVType As Integer
    
    If Not IsArray(vArray) Then Exit Function               'Need to work with a safearray here.
 
    With uInfo
        CopyMemory iVType, vArray, 2                        'First 2 bytes are the subtype.
        CopyMemory lPointer, ByVal VarPtr(vArray) + 8, 4    'Get the pointer.
 
        If (iVType And VT_BY_REF) <> 0 Then                 'Test for subtype "pointer"
            CopyMemory lPointer, ByVal lPointer, 4          'Get the real address.
        End If
        
        CopyMemory uInfo.cDim, ByVal lPointer, 16           'Write the safearray to the passed UDT.
        
        If uInfo.cDim = 1 Then                              'Can't do multi-dimensional
            CopyMemory .rgsabound, ByVal lPointer + 16, LenB(.rgsabound)
            GetArrayInfo = True
        End If
    End With
 
End Function
 
Private Function AlterArray(vArray As Variant, uInfo As SafeArray) As Boolean
    
    'NOTE, the array is passed as a variant so we can get it's absolute memory address.  This function
    'writes the SafeArray UDT information into the actual memory address of the passed array.
    
    Dim lPointer As Long, iVType As Integer
 
    If Not IsArray(vArray) Or uInfo.cDim <> 1 Then Exit Function
 
    With uInfo
        CopyMemory iVType, vArray, 2                        'Get the variant subtype
        CopyMemory lPointer, ByVal VarPtr(vArray) + 8, 4    'Get the pointer.
 
        If (iVType And VT_BY_REF) <> 0 Then                 'Test for subtype "pointer"
            CopyMemory lPointer, ByVal lPointer, 4          'Get the real address.
        End If
 
        CopyMemory ByVal lPointer, uInfo.cDim, 16           'Overwrite the array with the UDT.
 
        If uInfo.cDim = 1 Then                              'Multi-dimensions might wipe out other memory.
            CopyMemory ByVal lPointer + 16, .rgsabound, LenB(.rgsabound)
            AlterArray = True
        End If
 
    End With
 
End Function