form1.frm

《Delphi5企业级解决方案及应用剖析》参考程序 DELPHI 资料集

            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Left            =   6360
         TabIndex        =   60
         Top             =   2520
         Width           =   135
      End
      Begin VB.Label Label14 
         Caption         =   "A S C I I"
         Height          =   255
         Left            =   -69720
         TabIndex        =   53
         Top             =   840
         Width           =   1335
      End
      Begin VB.Label Label13 
         Caption         =   "H E X A D E C I M A L"
         Height          =   255
         Left            =   -72900
         TabIndex        =   52
         Top             =   840
         Width           =   1935
      End
      Begin VB.Label Label12 
         Caption         =   "Addr(hex)"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   9.75
            Charset         =   204
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Left            =   -74640
         TabIndex        =   51
         Top             =   840
         Width           =   1095
      End
      Begin VB.Label Label8 
         Caption         =   "IRQ :"
         Height          =   255
         Left            =   -73560
         TabIndex        =   14
         Top             =   1260
         Width           =   855
      End
      Begin VB.Label L_IRQ 
         AutoSize        =   -1  'True
         Caption         =   "10"
         Height          =   195
         Left            =   -72600
         TabIndex        =   12
         Top             =   1260
         Width           =   180
      End
      Begin VB.Label L_Han 
         AutoSize        =   -1  'True
         Caption         =   "XX"
         Height          =   195
         Left            =   -72600
         TabIndex        =   6
         Top             =   2340
         Width           =   210
      End
      Begin VB.Label L_Gen 
         AutoSize        =   -1  'True
         Caption         =   "XX"
         Height          =   195
         Left            =   -72600
         TabIndex        =   5
         Top             =   1860
         Width           =   210
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         Caption         =   "Handled:"
         Height          =   255
         Index           =   1
         Left            =   -73560
         TabIndex        =   4
         Top             =   2340
         Width           =   735
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "Generated:"
         Height          =   255
         Index           =   1
         Left            =   -73560
         TabIndex        =   3
         Top             =   1860
         Width           =   855
      End
   End
   Begin VB.Timer Timer1 
      Interval        =   200
      Left            =   7440
      Top             =   3660
   End
   Begin VB.CommandButton Close_Driver 
      Caption         =   "Close_Driver"
      Height          =   495
      Left            =   7440
      TabIndex        =   1
      Top             =   2880
      Width           =   1935
   End
   Begin VB.CommandButton Open_Driver 
      Caption         =   "Open_Driver"
      Height          =   495
      Left            =   7440
      TabIndex        =   0
      Top             =   2160
      Width           =   1935
   End
   Begin TVICHW32Lib.TVicHW32 HwCtrl 
      Left            =   8280
      Top             =   3600
      _Version        =   65536
      _ExtentX        =   1085
      _ExtentY        =   873
      _StockProps     =   0
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Rem =======================================================
Rem =====     Test example for TVicHW32.OCX v.3.0     =====
Rem =======================================================
Rem == Copyright(c) 1998 Victor Ishikeev ([e-mail]) ==
Rem =======================================================

Dim WChecks(17), NumSymbol As Integer
Dim Flag_Intr As Long
Dim FlagPrint As Boolean
Dim IRQCounter As Long
Dim PhysAddr As Long
Dim MappedAddr As Long
Dim IRQ As Integer
Dim Sum_Ticks As Long
Dim CurrTicker As Long
Dim OldTicker As Long
Dim Flag_Tim As Long
Dim Scan_Code  As Byte
Dim Data_Reg  As Byte
Dim Status_Reg  As Byte
Private Declare Function GetTickCount Lib "kernel32" () As Long
Public Sub ShowButtons()
   Dim nPin As Integer
   B_SetMemory.Enabled = HwCtrl.ActiveHW And (MappedAddr = 0)
   If Not HwCtrl.ActiveHW Then B_Unmask.Value = 0
   SpinLPT.Enabled = HwCtrl.ActiveHW
   SpinLPT.Max = HwCtrl.LPTNumPorts
   L_LPTs.Caption = HwCtrl.LPTNumPorts
   L_LPTNumber.Caption = HwCtrl.LPTNumber
   L_Base.Caption = Hex(HwCtrl.LPTBasePort) + "h"
   If HwCtrl.HardAccess Then
   C_Hard.Value = 1
   Else: C_Hard.Value = 0
   End If
   C_Hard.Enabled = HwCtrl.ActiveHW
   SpinIRQ.Enabled = HwCtrl.ActiveHW And (B_Unmask.Value = 0)
   Open_Driver.Enabled = Not HwCtrl.ActiveHW
   Close_Driver.Enabled = HwCtrl.ActiveHW
   Write_All.Enabled = HwCtrl.ActiveHW
   Read_All.Enabled = HwCtrl.ActiveHW
   B_Print.Enabled = HwCtrl.ActiveHW
  B_Stop.Enabled = HwCtrl.ActiveHW
  If Not HwCtrl.ActiveHW Then FlagPrint = False
   B_ReadMemory.Enabled = HwCtrl.ActiveHW And (MappedAddr <> NIL)
   B_Unmask.Enabled = HwCtrl.ActiveHW And (HwCtrl.IRQNumber > 0) And (HwCtrl.IRQNumber < 16)
   C_LPT_IRQ.Enabled = HwCtrl.ActiveHW And (((HwCtrl.IRQNumber = 7) And (HwCtrl.LPTNumber = 1)) Or ((HwCtrl.IRQNumber = 5) And (HwCtrl.LPTNumber = 2)))
   For nPin = 1 To 17
     If Not HwCtrl.ActiveHW Then RCheck(nPin).Value = False
     If Not HwCtrl.ActiveHW Then WCheck(nPin).Value = False
     Rem WCheck(nPin).Value = HwCtrl.ActiveHW
   Next nPin
   WCheck(10).Enabled = False
   WCheck(11).Enabled = False
   WCheck(12).Enabled = False
   WCheck(13).Enabled = False
   WCheck(15).Enabled = False
End Sub
Public Function HexToInt(strMyString As String) As Long
  Dim lngMyInteger As Long
  lngMyInteger = 0
  On Error Resume Next
  lngMyInteger = "&h" & strMyString
  HexToInt = lngMyInteger
End Function
Public Function IntToHex2(MyVal As Byte) As String
  Dim s As String
  s = Hex(MyVal)
  If Len(s) = 1 Then s = "0" & s
  IntToHex2 = s
End Function
Public Function IntToHex8(MyVal As Long) As String
  Dim s As String
  s = Hex(MyVal)
  While Len(s) < 8
    s = "0" & s
  Wend
  IntToHex8 = s
End Function

Public Sub WriteToPort(Addr As TextBox, ValPort As TextBox, CW As CheckBox)
 Dim NomW As Integer, DatW As Byte
  If CW.Value = Checked Then
    NomW = HexToInt(Addr.Text)
    DatW = HexToInt(ValPort.Text)
    HwCtrl.Port(NomW) = DatW
  End If
End Sub

Public Sub ReadFromPort(Addr As TextBox, ValPort As Label, CR As CheckBox)
 Dim NomR As Integer, DatR As Byte
  
  If CR.Value = Checked Then
    NomR = HexToInt(Addr.Text)
    DatR = HwCtrl.Port(NomR)
    ValPort.Caption = Hex(DatR)
  End If
  
End Sub

Private Sub B_Init_Click()
 HwCtrl.LPTInit
End Sub

Private Sub B_Print_Click()
  If Not FlagPrint Then
    NumLine = 0
    NumSymbol = 1
    FlagPrint = True
  End If
End Sub

Private Sub B_Stop_Click()
  FlagPrint = False
End Sub

Private Sub B_Unmask_Click()
    
    If B_Unmask.Value = 0 Then
      Sum_Ticks = Flag_Tim
      HwCtrl.IRQMasked = True
      HwCtrl.Port(LPTBasePort + 2) = 0
      C_LPT_IRQ.Value = 0
    Else
      IRQ = SpinIRQ.Value
      HwCtrl.IRQNumber = IRQ
      Flag_Intr = 0
      Sum_Ticks = 0
      Flag_Tim = 0
      Scan_Code = 0
      HwCtrl.IRQMasked = False
    End If
    ShowButtons
End Sub

Private Sub B_ReadMemory_Click()

  
  Dim CurrAddr As Long
  Dim s As String
  
  
    ListAddr.Clear
    ListHex.Clear
    ListAscii.Clear
    
    If HwCtrl.ActiveHW Then
    
      CurrAddr = PhysAddr
      Ofs% = 0
      Ofs0% = 0
      
      For i% = 1 To 16
        ListAddr.AddItem IntToHex8(CurrAddr)
        s = ""
        For j% = 1 To 16
          s = s + IntToHex2(HwCtrl.Mem(MappedAddr, Ofs%))
          Ofs% = Ofs% + 1
        Next j%
        ListHex.AddItem (s)
        s = ""
        For j% = 1 To 16
          b% = HwCtrl.Mem(MappedAddr, Ofs0%)
          Ofs0% = Ofs0% + 1
          If b% >= 32 Then
            ch$ = Chr(b%)
          Else: ch$ = "."
          End If

          s = s + ch$
        Next j%
        
        ListAscii.AddItem s
        CurrAddr = CurrAddr + 16
      Next i%
    End If


End Sub

Private Sub B_SetMemory_Click()
  PhysAddr = HexToInt(E_Base.Text)
  E_Base.Text = IntToHex8(PhysAddr)
  MappedAddr = HwCtrl.MapPhysToLinear(PhysAddr, 256)
  ShowButtons
End Sub

Private Sub C_Hard_Click()
  HwCtrl.HardAccess = C_Hard.Value
End Sub

Private Sub C_LPT_IRQ_Click()
 If C_LPT_IRQ.Value = 1 Then
   HwCtrl.Port(LPTBasePort + 2) = &H10
 Else:
   HwCtrl.Port(LPTBasePort + 2) = 0
 End If
End Sub

Private Sub Close_Driver_Click()
  Timer1.Enabled = False
  HwCtrl.Port(HwCtrl.LPTBasePort + 2) = 0
  C_LPT_IRQ.Value = 0
  HwCtrl.CloseDriver
  B_Unmask.Value = 0
  PointPhys = 0
  B_SetMemory.Enabled = False
  Flag_Intr = 0
  MappedAddr = 0
  ShowButtons
End Sub

Private Sub Command1_Click()
  Close_Driver_Click
  Unload Form1
  End
End Sub

 
Private Sub E_Base_Change()
  MappedAddr = 0
  ShowButtons
End Sub

Private Sub Form_Load()
  ShowButtons
End Sub

Private Sub HwCtrl_OnHwInterrupt(ByVal HwCounter As Long, ByVal LPT_DataReg As Integer, ByVal LPT_StatusReg As Integer, ByVal ScanCode As Integer)
  IRQCounter = HwCounter
  Flag_Intr = Flag_Intr + 1
  Scan_Code = ScanCode
  Status_Reg = LPT_StatusReg
  Data_Reg = LPT_DataReg
End Sub

Private Sub Open_Driver_Click()
  HwCtrl.OpenDriver
  If Not HwCtrl.ActiveHW Then
    MsgBox ("The driver VICHWxx not found")
  Else:
    IRQ = SpinIRQ.Value
    HwCtrl.IRQNumber = IRQ
    B_SetMemory.Enabled = True
    For i = 1 To 17
      HwCtrl.Pin(i) = False
    Next i
  End If
  ShowButtons
End Sub

HwCtrl.LPTPrintChar(

Private Sub Read_All_Click()
  Call ReadFromPort(PortR1, ValR1, CR1)
  Call ReadFromPort(PortR2, ValR2, CR2)
  Call ReadFromPort(PortR3, ValR3, CR3)
  Call ReadFromPort(PortR4, ValR4, CR4)
End Sub


Private Sub Timer1_Timer()
Dim s As String * 255
  L_Gen.Caption = IRQCounter
  L_Han.Caption = Flag_Intr
  L_Data.Caption = IntToHex2(Data_Reg) + "h"
  L_Status.Caption = IntToHex2(Status_Reg) + "h"
  L_Scan.Caption = IntToHex2(Scan_Code) + "h"
    
    L_Time.Caption = Flag_Tim / 1000
    
    If HwCtrl.ActiveHW And (Not HwCtrl.IRQMasked) Then
      CurrTicker = GetTickCount()
      Flag_Tim = Sum_Ticks + CurrTicker - OldTicker
    Else: OldTicker = GetTickCount()
    End If
    For nPin = 1 To 17
      If HwCtrl.Pin(nPin) Then RCheck(nPin).Value = 1 Else RCheck(nPin).Value = 0
    Next nPin
    
    If HwCtrl.LPTAckwl Then C_ACKWL.Value = 1 Else C_ACKWL.Value = 0
    If HwCtrl.LPTBusy Then C_BUSY.Value = 1 Else C_BUSY.Value = 0
    If HwCtrl.LPTError Then C_ERROR.Value = 1 Else C_ERROR.Value = 0
    If HwCtrl.LPTPaperEnd Then C_PE.Value = 1 Else C_PE.Value = 0
    If HwCtrl.LPTSlct Then C_SLCT.Value = 1 Else C_SLCT.Value = 0
    

    If FlagPrint Then
      s = E_Line.Text + Str(&HD) + Str(&HA)
      If NumSymbol > Len(s) Then FlagPrint = False
      If FlagPrint And (HwCtrl.LPTPrintChar(Val(Mid(s, NumSymbol, 1)))) Then NumSymbol = NumSymbol + 1
    End If
    B_Stop.Enabled = FlagPrint
    B_Print.Enabled = Not FlagPrint

End Sub

Private Sub SpinIRQ_Change()
  HwCtrl.IRQNumber = SpinIRQ.Value
  L_IRQ.Caption = SpinIRQ.Value
  ShowButtons
End Sub

Private Sub WCheck_Click(Index As Integer)
  If WCheck(Index).Value <> WChecks(Index) Then
    WChecks(Index) = WCheck(Index).Value
    HwCtrl.Pin(Index) = CBool(WCheck(Index).Value = 1)
  End If
End Sub

Private Sub Write_All_Click()
  WriteToPort PortW1, ValW1, CW1
  WriteToPort PortW2, ValW2, CW2
  WriteToPort PortW3, ValW3, CW3
  WriteToPort PortW4, ValW4, CW4
End Sub