如何使用VBA中的CopyMemory存儲數據並從內存映射文件中獲取數據？

Question

我正在嘗試構建一個分佈式計算系統，它使用內存映射文件通過VBA協調多臺聯網的PC之間的工作。換句話說，我想讓一組網絡計算機同時以協調的方式在單個項目上工作，這個項目可以很容易地劃分爲不同的部分。一臺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 

作爲一個小例子上面的代碼試圖把在文件test1.txt的字符串「testing1」然後檢索該字符串，並將其存儲在可變緩衝器2和最後通過msgbox顯示該字符串。超級簡單。但是，我不知道我在做什麼。

我們的電腦全部是64位的Windows 7，辦公/ Excel的2013年

問題/疑問：

1. 的MSGBOX是空白的，當我運行IntoMemoryFileOutOfMemoryFile
2. 子完成後，我打開test1.txt，我得到：「進程無法訪問文件，因爲它正在被另一個進程使用。」這告訴我我沒有正確使用UnmapViewOfFile和/或CloseHandle。
3. 我想讓這些內存文件保持不變，所以如果所有的PC都被中斷，我可以重新啓動進程並在我離開的地方取回。

下面是一些我用的鏈接來獲得現在的我：

• https://msdn.microsoft.com/en-us/library/dd997372%28v=vs.110%29.aspx

• http://www.vbforums.com/showthread.php?404085-VB6-Treat-a-file-like-an-array-without-reading-to-memory

• http://vb.mvps.org/hardcore/html/sharedmemorythroughmemory-mappedfiles.htm

• http://www.tushar-mehta.com/publish_train/xl_vba_cases/1016%20Office%202010%20VBA.shtml

有趣但並不重要的信息：「項目」是針對對衝基金客戶的。我是一個走向根本定量的金融傢伙。我們每日分析超過1250多個數據領域的2000多隻股票，以制定宏觀經濟信號/預測以購買和出售股票，期貨和期權。

更新：如果我改變兩個CopyMemory的線像這樣分別（通過pMemFile由值）：

CopyMemory ByVal pMemFile, buffer, 128 

和...

CopyMemory buffer2, ByVal pMemFile, 128 

我在文件test1.txt和excel崩潰中得到了一堆瘋狂的字符。

Answer 1

對於你的第一個問題（沒有太多探索），這與你如何試圖將你的buffer傳遞給RtlMoveMemory有關。它期待着一個指針，但你傳遞一個BSTR的副本。還要記住，VBA中的字符串是Unicode，所以你會得到交織的空字符。我通常使用Byte數組或變體（他們將編組到CSTR）。

對於你的第二個問題，該文件被鎖定，因爲你永遠不會釋放到hFile的句柄。實際上，只要您將它傳遞給CreateFileMappingA，您可以致電上的CloseHandle。

對於第三個問題，當您進行第二個調用時，您將覆蓋您的句柄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）。