如何使用VBA中的CopyMemory在内存映射文件中存储数据并获取数据？

Question

如何使用VBA中的CopyMemory在内存映射文件中存储数据并获取数据？

vbaexceldistributed-computingmemory-mapping

8

我正在尝试构建一个分布式计算系统，使用内存映射文件在多台网络PC之间协调工作，所有操作都通过VBA进行。换句话说，我想让一组网络计算机在同一时间协调完成单个项目的工作，该项目可以轻松地分成不同的部分。其中一台PC需要13个小时以上才能完成该项目，这对我的客户来说是不切实际的。

我希望将信息存储在内存映射文件中，以帮助PC协调完成项目（即避免重复工作、避免竞争问题等）。我已经尝试使用其他类型的文件来实现这一点，但会导致文件竞争问题或者耗时过长。因此，如此论坛上建议的，我正在尝试使用内存映射文件。

我对内存映射文件和分布式计算都很陌生，必须在VBA中完成。据我所知，我必须指定文件保存在我们网络上的目录（这里是Z驱动器），所有PC都可以访问。我从各种地方拼凑了一些代码：

Option Explicit

Private Const PAGE_READWRITE As Long = &H4
Private Const FILE_MAP_WRITE As Long = &H2
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_ALWAYS = 4
Private Const FILE_ATTRIBUTE_NORMAL = &H80

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, _
                                         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 CreateFileMapping Lib "kernel32.dll" Alias "CreateFileMappingA" ( _
     ByVal hFile As Long, _
     ByVal lpFileMappigAttributes As Long, _
     ByVal flProtect As Long, _
     ByVal dwMaximumSizeHigh As Long, _
     ByVal dwMaximumSizeLow As Long, _
     ByVal lpName As String) As Long

Private Declare Function MapViewOfFile Lib "kernel32.dll" ( _
     ByVal hFileMappingObject As Long, _
     ByVal dwDesiredAccess As Long, _
     ByVal dwFileOffsetHigh As Long, _
     ByVal dwFileOffsetLow As Long, _
     ByVal dwNumberOfBytesToMap As Long) As Long

#If VBA7 Then
Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias _
    "RtlMoveMemory" (destination As Any, source As Any, _
    ByVal length As Long)
#Else
Public Declare Sub CopyMemory Lib "kernel32" Alias _
    "RtlMoveMemory" (destination As Any, source As Any, _
    ByVal length As Long)
    #End If

Private Declare Function UnmapViewOfFile Lib "kernel32.dll" ( _
     ByRef lpBaseAddress As Any) As Long

Private Declare Function CloseHandle Lib "kernel32.dll" ( _
     ByVal hObject As Long) As Long

Private hMMF As Long
Private pMemFile As Long

Sub IntoMemoryFileOutOfMemoryFile()

    Dim sFile As String
    Dim hFile As Long

    sFile = "Z:\path\test1.txt"

    hFile = CreateFile(sFile, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
    hMMF = CreateFileMapping(hFile, 0, PAGE_READWRITE, 0, 1000000, "MyMemoryMappedFile")

    pMemFile = MapViewOfFile(hMMF, FILE_MAP_WRITE, 0, 0, 0)

    Dim buffer As String

    buffer = "testing1"
    CopyMemory pMemFile, ByVal buffer, 128

    hMMF = CreateFileMapping(-1, 0, PAGE_READWRITE, 0, 1000000, "MyMemoryMappedFile")
    pMemFile = MapViewOfFile(hMMF, FILE_MAP_WRITE, 0, 0, 0)

     Dim buffer2 As String

    buffer2 = String$(128, vbNullChar)

     CopyMemory ByVal buffer2, pMemFile, 128

     MsgBox buffer2 & " < - it worked?"

     UnmapViewOfFile pMemFile
     CloseHandle hMMF
End Sub

作为一个小例子，上面的代码尝试将字符串“testing1”放入文件test1.txt中，然后检索该字符串并将其存储在变量buffer2中，最后通过msgbox显示该字符串。非常简单。但是，我不知道我在做什么。

我们所有的电脑都是64位的，Windows 7，Office/Excel 2013。

问题/疑问：

当我运行IntoMemoryFileOutOfMemoryFile时，msgbox为空白。
在子程序完成后，我打开test1.txt并得到：“由于正在被另一个进程使用，因此无法访问该文件。”这告诉我我没有正确使用UnmapViewOfFile和/或CloseHandle。
我想使这些内存文件持久化，以便如果所有计算机中断，我可以重新启动进程并从上次离开的地方继续。

这是我用来到达现在位置的一些链接：

有趣但不重要的信息：这个“项目”是为一个对冲基金客户而做的。我是一名金融人员转型为基本量化分析师。我们每天分析2000多只股票和1250多个数据字段，以制定宏观经济信号/预测来买卖股票、期货和期权。

更新：如果我将两个CopyMemory行改成这样（通过值传递pMemFile），则：

CopyMemory ByVal pMemFile, buffer, 128

和……

CopyMemory buffer2, ByVal pMemFile, 128

我在文件test1.txt中得到了一堆奇怪的字符，导致Excel崩溃。

- mountainclimber11

3

为什么这一定要用VBA？虽然我很喜欢VBA，但这似乎有点像用锤子解决需要螺丝刀的问题。 - RubberDuck

1

@RubberDuck 可能是客户需求（我对于一个更简单的工具也遇到了同样的问题），需要有人能够使用VBA维护，而不是其他语言。这个项目超出了我的能力范围，但很有趣，我会研究一下，但不能保证能完成！;) - R3uK

1

@RubberDuck - 这也不是我的选择。 - mountainclimber11

1

我没有说它是。只是在说它可能与解决方案有关。也许VBA并不像我们想象的那样重要。了解原因可能会有所帮助。 - RubberDuck

1

@RubberDuck - R3uk是正确的。这是一项业务运营决策。但这并没有阻止我完成他们想要的事情...至少目前还没有。 - mountainclimber11

1个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Comintern · Accepted Answer

对于您的第一个问题（我没有深入研究），这与如何将buffer传递给RtlMoveMemory有关。它期望一个指针，但您正在传递BSTR的副本。还要记住，VBA中的字符串是Unicode编码，因此您会得到交织的null字符。我通常使用字节数组或变体（它们将被降级为CSTR）。

对于您的第二个问题，文件被锁定是因为您从未释放对hFile的句柄。实际上，一旦你将它传递给CreateFileMappingA，你就可以调用CloseHandle关闭hFile。

对于第三个问题，当您进行第二次调用时，您正在覆盖您的句柄hMMF和指针pMemFile。理论上，它们应该返回相同的句柄和指针，因为您在同一个进程中，但这并不能真正测试您是否获得了映射视图。

至于内存访问，我可能会建议将整个过程封装在一个类中，并将指针映射到比调用RtlMoveMemory更有用的内容。我将您在问题中链接的代码改编成了一个类，应该使其更安全、可靠和方便使用（尽管仍需要添加错误检查）。

'Class MemoryMap
Option Explicit

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

Private Const VT_BY_REF = &H4000&
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const OPEN_ALWAYS = &H4
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const PAGE_READWRITE = &H4
Private Const FILE_MAP_WRITE = &H2
Private Const FADF_FIXEDSIZE = &H10

Private cached As SafeArray
Private buffer() As Byte
Private hFileMap As Long
Private hMM As Long
Private mapped_file As String
Private bound As Long

Public Property Get FileName() As String
    FileName = mapped_file
End Property

Public Property Get length() As Long
    length = bound
End Property

Public Sub WriteData(inVal As String, offset As Long)
    Dim temp() As Byte
    temp = StrConv(inVal, vbFromUnicode)

    Dim index As Integer
    For index = 0 To UBound(temp)
        buffer(index + offset) = temp(index)
    Next index
End Sub

Public Function ReadData(offset, length) As String
    Dim temp() As Byte
    ReDim temp(length)

    Dim index As Integer
    For index = 0 To length - 1
        temp(index) = buffer(index + offset)
    Next index

    ReadData = StrConv(temp, vbUnicode)
End Function

Public Function OpenMapView(file_path As String, size As Long, mapName As String) As Boolean
    bound = size
    mapped_file = file_path

    Dim hFile As Long
    hFile = CreateFile(file_path, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
    hFileMap = CreateFileMapping(hFile, 0, PAGE_READWRITE, 0, size, mapName)
    CloseHandle hFile
    hMM = MapViewOfFile(hFileMap, FILE_MAP_WRITE, 0, 0, 0)

    ReDim buffer(2)
    'Cache the original SafeArray structure to allow re-mapping for garbage collection.
    If Not ReadSafeArrayInfo(buffer, cached) Then
        'Something's wrong, close our handles.
        CloseOpenHandles
        Exit Function
    End If

    Dim temp As SafeArray
    If ReadSafeArrayInfo(buffer, temp) Then
        temp.cbElements = 1
        temp.rgsabound.cElements = size
        temp.fFeature = temp.fFeature And FADF_FIXEDSIZE
        temp.pvData = hMM
        OpenMapView = SwapArrayInfo(buffer, temp)
    End If    
End Function

Private Sub Class_Terminate()
    'Point the member array back to its own data for garbage collection.
    If UBound(buffer) = 2 Then
        SwapArrayInfo buffer, cached
    End If
    SwapArrayInfo buffer, cached
    CloseOpenHandles
End Sub

Private Sub CloseOpenHandles()
    If hMM > 0 Then UnmapViewOfFile hMM
    If hFileMap > 0 Then CloseHandle hFileMap
End Sub

Private Function GetBaseAddress(vb_array As Variant) As Long
    Dim vtype As Integer
    'First 2 bytes are the VARENUM.
    CopyMemory vtype, vb_array, 2
    Dim lp As Long
    'Get the data pointer.
    CopyMemory lp, ByVal VarPtr(vb_array) + 8, 4
    'Make sure the VARENUM is a pointer.
    If (vtype And VT_BY_REF) <> 0 Then
        'Dereference it for the actual data address.
        CopyMemory lp, ByVal lp, 4
        GetBaseAddress = lp
    End If
End Function

Private Function ReadSafeArrayInfo(vb_array As Variant, com_array As SafeArray) As Boolean
    If Not IsArray(vb_array) Then Exit Function

    Dim lp As Long
    lp = GetBaseAddress(vb_array)
    If lp > 0 Then
        With com_array
            'Copy it over the passed structure
            CopyMemory .cDim, ByVal lp, 16
            'Currently doesn't support multi-dimensional arrays.
            If .cDim = 1 Then
                CopyMemory .rgsabound, ByVal lp + 16, LenB(.rgsabound)
                ReadSafeArrayInfo = True
            End If
        End With
    End If
End Function

Private Function SwapArrayInfo(vb_array As Variant, com_array As SafeArray) As Boolean
    If Not IsArray(vb_array) Then Exit Function
    Dim lp As Long
    lp = GetBaseAddress(vb_array)

    With com_array
        'Overwrite the passed array with the SafeArray structure.
        CopyMemory ByVal lp, .cDim, 16
        If .cDim = 1 Then
            CopyMemory ByVal lp + 16, .rgsabound, LenB(.rgsabound)
            SwapArrayInfo = True
        End If
    End With    
End Function

使用方法如下：

Private Sub MMTest()
    Dim mm As MemoryMap

    Set mm = New MemoryMap
    If mm.OpenMapView("C:\Dev\test.txt", 1000, "TestMM") Then
        mm.WriteData "testing1", 0
        Debug.Print mm.ReadData(0, 8)
    End If

    Set mm = Nothing
End Sub

您还需要在某个地方添加以下声明：

Public Declare Function MapViewOfFile Lib "kernel32.dll" ( _
    ByVal hFileMappingObject As Long, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwFileOffsetHigh As Long, _
    ByVal dwFileOffsetLow As Long, _
    ByVal dwNumberOfBytesToMap As Long) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias _
    "RtlMoveMemory" (Destination As Any, Source As Any, _
    ByVal length As Long)

Public Declare Function CloseHandle Lib "kernel32.dll" ( _
    ByVal hObject As Long) As Long

Public Declare Function UnmapViewOfFile Lib "kernel32.dll" ( _
    ByVal lpBaseAddress As Any) As Long

还有一件事需要注意 - 因为您正在使用网络驱动器，所以要确保缓存机制不会干扰对文件的访问。具体来说，您需要确保所有客户端都关闭了网络文件缓存。您还可以确定性地刷新内存映射，而不是依赖于操作系统（请参见FlushViewOfFile）。