資訊好好玩

0愛的鼓勵 0訂閱站台

專案二 請自行新增物件模組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