busclass.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 = "BusClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
Dim Sysinf As New SysInfClass

'Private Const ERROR_ALREADY_EXISTS = 183&
'Private Const ERROR_BAD_ARGUMENTS = 160&
'Private Const ERROR_INVALID_DATA = 13&
Private Const PAGE_READWRITE = 4
Private Const FILE_MAP_WRITE = 2

Private mapping As Long '内存映射句柄
Private viewmem As Long '映射视图指针
Private viewmemABus As Long
Private viewmemDBus As Long
Private viewmemCBus As Long

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 mvarDataBus As Byte '局部复制
'Private mvarAddressBus As Integer '局部复制
'Private mvarControlBus As Integer '局部复制
'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent DataChange[(arg1, arg2, ... , argn)]
'Public Event DataChange()
'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent AddChange[(arg1, arg2, ... , argn)]
'Public Event AddChange()
'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent CtrlChange[(arg1, arg2, ... , argn)]
'Public Event CtrlChange()

Public Property Let ControlBus(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.ControlBus = 5
    CopyMemory ByVal viewmemCBus, vData, 2
    'RaiseEvent CtrlChange
    'mvarControlBus = vData
End Property


Public Property Get ControlBus() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.ControlBus
    CopyMemory ControlBus, ByVal viewmemCBus, 2
    'ControlBus = mvarControlBus
End Property



Public Property Let AddressBus(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.AddressBus = 5
    CopyMemory ByVal viewmemABus, vData, 2
    'RaiseEvent AddChange
    'mvarAddressBus = vData
End Property


Public Property Get AddressBus() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.AddressBus
    CopyMemory AddressBus, ByVal viewmemABus, 2
    'AddressBus = mvarAddressBus
End Property



Public Property Let DataBus(ByVal vData As Byte)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.DataBus = 5
    CopyMemory ByVal viewmemDBus, vData, 1
    'RaiseEvent DataChange
    'mvarDataBus = vData
End Property


Public Property Get DataBus() As Byte
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.DataBus
    CopyMemory DataBus, ByVal viewmemDBus, 1
    'DataBus = mvarDataBus
End Property




Private Sub Class_Initialize()
    Dim precision As Long
    precision = Sysinf.AllocationGranularity
    If precision > 4 Then
        'Dim errorpoint As Long
        
        mapping = CreateFileMapping(-1, ByVal 0, PAGE_READWRITE, 0, precision - 1, "6974B6FCF8524eddBF351E8C16FD3DAC")
        
        '保存错误描述，因其不一定真是错误，此处可能是正常的文件已存在信息，
        '   具体可参见CreateFileMapping的帮助文件
        'errorpoint = Err.LastDllError
        If mapping Then
            viewmem = MapViewOfFile(mapping, FILE_MAP_WRITE, 0, 0, 0)
            'errorpoint = Err.LastDllError
            If viewmem Then
                viewmemABus = viewmem
                viewmemDBus = viewmem + 2
                viewmemCBus = viewmem + 3
            Else
                'UnmapViewOfFile viewmem
                CloseHandle mapping   '一定要注意
                Err.Raise vbObjectError + Err.LastDllError, , "建立试图映射失败！"
            End If
        Else
            Err.Raise vbObjectError + Err.LastDllError, , "申请文件映像失败！"
        End If '当然对CreateFileMapping这API，我们可以认为返回0才是错误。
    End If
    
    ' 取得映射文件的视图指针p，它指向就是从共享内存文件中映射来的进程可用的内存。
    'If viewmemABus = 0 And viewmemDBus = 0 Then
    '    CloseHandle mapping   '一定要注意
    '    Err.Raise vbObjectError + Err.LastDllError
    'Else
    '    If viewmemABus = 0 And viewmemDBus Then
    '        UnmapViewOfFile viewmemDBus
    '        CloseHandle mapping   '一定要注意
    '        Err.Raise vbObjectError + Err.LastDllError
    '    End If
    '    If viewmemABus And viewmemDBus = 0 Then
    '        UnmapViewOfFile viewmemABus
    '        CloseHandle mapping   '一定要注意
    '        Err.Raise vbObjectError + Err.LastDllError
    '    End If
    'End If
End Sub

Private Sub Class_Terminate()
    viewmemABus = 0
    viewmemDBus = 0
    viewmemCBus = 0
    UnmapViewOfFile viewmem
    CloseHandle mapping
    Set Sysinf = Nothing
End Sub