专案二 请自行新增物件模组MemString.Clx
'需一个Command Button, 一个Label
Option Explicit

'取出记忆体对应档内专案一所设的字串
Private Sub Command1_Click()
Dim mf As New MemString
Dim B As Boolean
B = mf.Create("MyMem")
Label1.Caption = mf.Data
End Sub

'以下在MemString.Cls
Option Explicit

Const SECTION_MAP_WRITE = &H2
Const SECTION_MAP_READ = &H4
Const FILE_MAP_WRITE = SECTION_MAP_WRITE
Const FILE_MAP_READ = SECTION_MAP_READ
Const PAGE_READONLY = &H2
Const PAGE_READWRITE = &H4
Const ERROR_ALREADY_EXISTS = 183&
Const ERROR_INVALID_DATA = 13&

Private Declare Function CreateFileMapping Lib "KERNEL32" Alias "CreateFileMappingA" _
        (ByVal hFile As Long, lpFileMappigAttributes As Any, _
        ByVal flProtect As Long, ByVal dwMaximumSizeHigh As Long, ByVal dwMaximumSizeLow As Long, ByVal lpName As String) As Long
Private Declare Function MapViewOfFile Lib "KERNEL32" (ByVal hFileMappingObject As Long, ByVal dwDesiredAccess As Long, ByVal dwFileOffsetHigh As Long, ByVal dwFileOffsetLow As Long, ByVal dwNumberOfBytesToMap As Long) As Long
Private Declare Function UnmapViewOfFile Lib "KERNEL32" (lpBaseAddress As Any) As Long
Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" ( _
   lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private h As Long, p As Long, e As Long
Const MEM_HANDLE As Long = -1&
'产生一个记忆体对应档，名称为sName
'该记忆体对应档里面存的资料分成两部份
'一个Long值，代表字串的长度，另一为字串，这字串才是要Share部份
Function Create(sName As String) As Boolean
    Create = False
    If sName = "" Then Exit Function
    ' Try to create file mapping of 65535 (only used pages matter)
    h = CreateFileMapping(MEM_HANDLE, ByVal 0, PAGE_READWRITE, _
                          0, 65535, sName)
    '如果sName原本就存在，则传回的h值是先前Call CreateFileMapping的handle of file Mapping Object
    '而且Err.LastDllError 传回的是ERROR_ALREADY_EXISTS，如果sName原来不存在，则传回新的Handle值
    '且Err.LastDllError = 0
    e = Err.LastDllError
    ' Unknown error, bail out
    If h = 0 Then Destroy: Exit Function

    ' Get pointer to mapping
    p = MapViewOfFile(h, FILE_MAP_WRITE, 0, 0, 0)
    If p = 0 Then e = Err.LastDllError: Exit Function
    If e <> ERROR_ALREADY_EXISTS Then
        ' Set size of new file mapping to 0 by copying first 4 bytes
        Dim c As Long ' = 0
        '将0放入记忆体对应档中的前4个Byte
        CopyMemory ByVal p, c, 4
    ' Else
        ' Existing file mapping
    End If
    e = 0
    Create = True
End Function
Property Get Data() As String
    If h = 0 Or p = 0 Then e = ERROR_INVALID_DATA: Exit Property
    Dim c As Long, sData As String
    CopyMemory c, ByVal p, 4
    ' Copy rest of memory into string
    If c = 0 Then Exit Property ' Data = sEmpty
    sData = String$(c, 0)
    '将字串放入记忆体对应档中的第4个Byte之後
    CopyMemory ByVal sData, ByVal (p + 4), c
    Data = sData
End Property

Property Let Data(s As String)
    If h = 0 Or p = 0 Then e = ERROR_INVALID_DATA: Exit Property
    Dim c As Long
    c = Len(s)
    ' Copy length to first 4 bytes and string to remainder
    CopyMemory ByVal p, c, 4
    CopyMemory ByVal (p + 4), ByVal s, c
End Property

Property Get LastErr() As Long
    LastErr = e
End Property
Private Sub Destroy()
   Dim i As Long
    i = UnmapViewOfFile(p)
    i = CloseHandle(h)
    h = 0
    p = 0
End Sub

Private Sub Class_Terminate()
    If h <> 0 Then Destroy
End Sub