memcontr.ctl

简单的操作系统程序

VERSION 5.00
Begin VB.UserControl MemContr 
   AutoRedraw      =   -1  'True
   CanGetFocus     =   0   'False
   ClientHeight    =   960
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   7680
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   10.5
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ScaleHeight     =   64
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   512
   ToolboxBitmap   =   "MemContr.ctx":0000
End
Attribute VB_Name = "MemContr"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Dim Shows As New DrawClass
Dim IBox As EURWBox
Private Type EURWBox 'Empty,Used,Read,Write
    ReadPosition As Integer
    WritePosition As Integer
    Data(0 To 1023) As Byte
    'Used(0 To 1023) As Boolean
End Type
'Default Property Values:
Const m_def_DataOnLine = 0
Const m_def_IOAddress = 0
Private Const CRed = 255 'RGB(255, 0, 0)Writing
Private Const CGreen = 65280 'RGB(0, 255, 0)Reading
Private Const CBlue = 16711680 'RGB(0, 0, 255)Using
Private Const CWhite = 16777215 'RGB(255,255,255)Unusing
Const m_def_ID = 1024

'Property Variables:
Dim m_DataOnLine As Byte
Dim m_IOAddress As Integer
Dim m_ID As Long

Private Declare Function setHigh Lib "bitChng" (ByVal sources As Byte, ByVal irQ As Byte) As Byte 'A|B
Private Declare Function setLow Lib "bitChng" (ByVal sources As Byte, ByVal irQ As Byte) As Byte 'A&(~B)
Private Declare Function setHigh2 Lib "bitChng" (ByVal sources As Integer, ByVal irQ As Integer) As Integer 'A|B
Private Declare Function setLow2 Lib "bitChng" (ByVal sources As Integer, ByVal irQ As Integer) As Integer 'A&(~B)
Private Declare Function setHigh4 Lib "bitChng" (ByVal sources As Long, ByVal irQ As Long) As Long 'A|B
Private Declare Function setLow4 Lib "bitChng" (ByVal sources As Long, ByVal irQ As Long) As Long 'A&(~B)

Private Bus As BusClass
Private WithEvents Timm As clsXTimer
Attribute Timm.VB_VarHelpID = -1
Dim timUnLock As Boolean
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=1
Public Function ReadData(Optional ByVal IOAddress As Integer) As Byte
    If (Not IsMissing(IOAddress)) And IOAddress > -1 And IOAddress < 1024 Then
        m_IOAddress = IOAddress
        'MsgBox "传递参数=" + CStr(Not IsMissing(IOAddress))
    End If
    If IBox.ReadPosition > -1 Then
        If IBox.Data(IBox.ReadPosition) = 0 Then
            Call Shows.Draw(IBox.ReadPosition + 1, CWhite)
        Else
            Call Shows.Draw(IBox.ReadPosition + 1, CBlue)
        End If
    End If
    m_DataOnLine = IBox.Data(m_IOAddress)
    IBox.ReadPosition = m_IOAddress
    Call Shows.Draw(m_IOAddress + 1, CGreen)
    UserControl.Refresh
    ReadData = m_DataOnLine
End Function

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0
Public Function WriteData(Optional ByVal IOAddress As Integer, Optional ByVal Datas As Byte) As Boolean
    WriteData = False
    If (Not IsMissing(IOAddress)) And IOAddress > -1 And IOAddress < 1024 Then
        m_IOAddress = IOAddress
    End If
    If Not IsMissing(Datas) Then
        m_DataOnLine = Datas
    End If
    If IBox.WritePosition > -1 Then
        If IBox.Data(IBox.WritePosition) = 0 Then
            Call Shows.Draw(IBox.WritePosition + 1, CWhite)
        Else
            Call Shows.Draw(IBox.WritePosition + 1, CBlue)
        End If
    End If
    IBox.Data(m_IOAddress) = m_DataOnLine
    IBox.WritePosition = m_IOAddress
    Call Shows.Draw(m_IOAddress + 1, CRed)
    UserControl.Refresh
    WriteData = True
End Function

Private Sub Timm_Tick()
    If timUnLock Then
        timUnLock = False
        Dim Ctrl14_13 As Integer
        Ctrl14_13 = setLow2(Bus.ControlBus, &H9FFF)
        If Ctrl14_13 = 8192 Then
            Bus.ControlBus = setLow2(Bus.ControlBus, &H6000)
            If Bus.AddressBus > -1 And Bus.AddressBus < 1024 Then
                m_IOAddress = Bus.AddressBus
            End If
            Bus.DataBus = ReadData(m_IOAddress)
            Bus.ControlBus = setHigh2(Bus.ControlBus, &H4000)
        End If
        timUnLock = True
    End If
End Sub

'**********************************************************************
'以下是这个类的构造函数和析构函数
'**********************************************************************
Private Sub UserControl_Initialize()
    Dim i As Integer
    For i = 0 To 1023
        IBox.Data(i) = 0
        'IBox.Used(I) = False
    Next i
    IBox.ReadPosition = -1
    IBox.WritePosition = -1
    Shows.TotalNumber = 1024
    Shows.HeightNum = 4
    Shows.WidthNum = 256
    Shows.hDC = UserControl.hDC
    Call Shows.Create(256, 64)
    UserControl.Refresh
    Set Bus = New BusClass
    Set Timm = New clsXTimer
    Timm.Interval = 10
    Timm.Enabled = True
    timUnLock = True
End Sub

Private Sub UserControl_Terminate()
Set Shows = Nothing
Set Bus = Nothing
Set Timm = Nothing
End Sub

Private Sub UserControl_InitProperties()
    m_ID = m_def_ID
    m_DataOnLine = m_def_DataOnLine
    m_IOAddress = m_def_IOAddress
End Sub

Private Sub UserControl_Resize()
UserControl.Height = 960
UserControl.Width = 3840
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,1,1,1024
Public Property Get ID() As Long
    ID = m_ID
End Property

Public Property Let ID(ByVal New_ID As Long)
    If Ambient.UserMode = False Then Err.Raise 387
    If Ambient.UserMode Then Err.Raise 382
    m_ID = New_ID
    PropertyChanged "ID"
End Property

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_ID = PropBag.ReadProperty("ID", m_def_ID)
    m_DataOnLine = PropBag.ReadProperty("DataOnLine", m_def_DataOnLine)
    m_IOAddress = PropBag.ReadProperty("IOAddress", m_def_IOAddress)
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("ID", m_ID, m_def_ID)
    Call PropBag.WriteProperty("DataOnLine", m_DataOnLine, m_def_DataOnLine)
    Call PropBag.WriteProperty("IOAddress", m_IOAddress, m_def_IOAddress)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=1,0,2,0
Public Property Get DataOnLine() As Byte
Attribute DataOnLine.VB_MemberFlags = "400"
    DataOnLine = m_DataOnLine
End Property

Public Property Let DataOnLine(ByVal New_DataOnLine As Byte)
    If Ambient.UserMode = False Then Err.Raise 387
    m_DataOnLine = New_DataOnLine
    PropertyChanged "DataOnLine"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,2,0
Public Property Get IOAddress() As Integer
Attribute IOAddress.VB_MemberFlags = "400"
    IOAddress = m_IOAddress
End Property

Public Property Let IOAddress(ByVal New_IOAddress As Integer)
    If Ambient.UserMode = False Then Err.Raise 387
    If New_IOAddress > -1 And New_IOAddress < 1024 Then
        m_IOAddress = New_IOAddress
        PropertyChanged "IOAddress"
    End If
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0
Public Function Halt() As Boolean
    Timm.Enabled = False
End Function

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0
Public Function GoOn() As Boolean
    Timm.Enabled = True
End Function

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0
Public Function Resets() As Boolean
    Dim i As Integer
    For i = 0 To 1023
        Call WriteData(i, 0)
    Next i
    m_DataOnLine = m_def_DataOnLine
    m_IOAddress = m_def_IOAddress
End Function