www.pudn.com > VBSendText.zip > ShareStr2.cls

VERSION 1.0 CLASS 
BEGIN 
  MultiUse = -1  'True 
  Persistable = 0  'NotPersistable 
  DataBindingBehavior = 0  'vbNone 
  DataSourceBehavior  = 0  'vbNone 
  MTSTransactionMode  = 0  'NotAnMTSObject 
END 
Attribute VB_Name = "CSharedString2" 
Attribute VB_GlobalNameSpace = False 
Attribute VB_Creatable = True 
Attribute VB_PredeclaredId = False 
Attribute VB_Exposed = False 
Option Explicit 
'*********************************************************************** 
'Class Module Name: CShareString 
'Refactored by AdamBear 2002-1-31 22:00 
'Originally Created By Bruce Meckinney, HardCore Visual Basic 
'Purpose: Demostrate the FileMapping and Inter-Process Community 
'************************************************************************ 
 
 
Private Const ERROR_ALREADY_EXISTS = 183& 
Private Const ERROR_BAD_ARGUMENTS = 160& 
Private 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 CloseHandle Lib "kernel32" (ByVal hObject As Long) 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long) 
Private Declare Sub CopyMemoryToStr Lib "kernel32" Alias "RtlMoveMemory" (ByVal strDst As String, pScr As Long, ByVal length As Long) 
Private Declare Sub CopyMemoryStr Lib "kernel32" Alias "RtlMoveMemory" (strDst As Long, ByVal pScr As String, ByVal length As Long) 
 
 
Private Const PAGE_READWRITE = 4 
Private Const FILE_MAP_WRITE = 2 
 
 
 
Private h As Long                      '内存映射句柄 
Private p As Long                      '映射视图指针 
 
 
 
 
Sub Create(strName As String) 
    Dim e As Long 
    If strName = "" Then ApiRaise ERROR_BAD_ARGUMENTS 
    ' 尝试建立一个大小为64K内存文件映射，不要怕设得大了，因为使用时是按4K为单位分配的。 
    h = CreateFileMapping(-1, ByVal pNull, PAGE_READWRITE, _ 
                          0, 65535, strName) 
     
    '保存错误描述，因其不一定真是错误，此处可能是正常的文件已存在信息， 
    '   具体可参见CreateFileMapping的帮助文件 
    e = Err.LastDllError 
    If h = 0 Then ApiRaise e    '当然对CreateFileMapping这API，我们可以认为返回0才是错误。 
     
    ' 取得映射文件的视图指针p，它指向就是从共享内存文件中映射来的进程可用的内存。 
    p = MapViewOfFile(h, FILE_MAP_WRITE, 0, 0, 0) 
    If p = pNull Then 
        CloseHandle h   '一定要注意 
        ApiRaise Err.LastDllError 
    End If 
    ' 
    If e <> ERROR_ALREADY_EXISTS Then 
        'HACK BSTR 保存p的前四个字节作为BSTR的长度存放处。 
        CopyMemory ByVal p, 0, 4 
    Else 
        '返回的是已经存在的FileMapping的句柄，不是错误 
    End If 
End Sub 
 
Private Sub Class_Terminate() 
    '清理 
    UnmapViewOfFile p 
    CloseHandle h 
End Sub 
 
'NOTE:为了让本类能做为String类型处理，须将本过程属性设为缺省。 
Property Get item() As String 
Attribute item.VB_UserMemId = 0 
    '此处Bruce MecKinney原来的代码存在极大的错误,对于Unicode的处理有问题 
   If h = 0 Then ErrRaise ERROR_INVALID_DATA 
    BugAssert p <> pNull 
    Dim c As Long 
    CopyMemory c, ByVal p, 4 
    If c Then 
        ' 用内存指针p第四个字节以后的东西构造返回的BSTR 
        item = String$(c, 0) 
        CopyMemoryToStr item, ByVal (p + 4), c * 2 
    End If 
End Property 
 
Property Let item(s As String) 
    If h = 0 Then ErrRaise ERROR_INVALID_DATA 
    BugAssert p <> pNull 
    Dim c As Long, cb As Long 
    c = Len(s) 
    ' 重新将BSTR放回内存中 
    CopyMemory ByVal p, c, 4 
    CopyMemoryStr ByVal (p + 4), s, c * 2 
End Property 
' 
 
' 
 
 
Private Sub ErrRaise(e As Long) 
    Dim sSource As String 
    If e > 1000 Then 
        sSource = App.EXEName & ".SharedString" 
        Err.Raise COMError(e), sSource 
    Else 
        sSource = App.EXEName & ".VBError" 
        Err.Raise e, sSource 
    End If 
End Sub