startup.frm

来自「利用psoc进行usb及capsense的程序编写」· FRM 代码 · 共 641 行 · 第 1/2 页

   End
   Begin VB.Shape Box2 
      BorderColor     =   &H00FFFFFF&
      Height          =   615
      Left            =   1920
      Top             =   2880
      Width           =   2055
   End
   Begin VB.Shape Box1 
      BorderColor     =   &H0000FFFF&
      FillColor       =   &H000000FF&
      Height          =   615
      Left            =   1920
      Top             =   480
      Width           =   2055
   End
   Begin VB.Label Name 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "4"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   12
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   3
      Left            =   5280
      TabIndex        =   6
      Top             =   2520
      Width           =   1695
   End
   Begin VB.Label Name 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "3"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   12
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   2
      Left            =   5280
      TabIndex        =   5
      Top             =   2160
      Width           =   1695
   End
   Begin VB.Label Name 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "1"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   12
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   0
      Left            =   5280
      TabIndex        =   4
      Top             =   1440
      Width           =   1695
   End
   Begin VB.Label Name 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "2"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   12
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   1
      Left            =   5280
      TabIndex        =   3
      Top             =   1800
      Width           =   1695
   End
   Begin VB.Label Label1 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "LEDs"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   15.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   0
      Left            =   5400
      TabIndex        =   2
      Top             =   960
      Width           =   975
   End
   Begin VB.Shape LED 
      FillStyle       =   0  'Solid
      Height          =   255
      Index           =   3
      Left            =   5400
      Top             =   2520
      Width           =   495
   End
   Begin VB.Shape LED 
      FillStyle       =   0  'Solid
      Height          =   255
      Index           =   2
      Left            =   5400
      Top             =   2160
      Width           =   495
   End
   Begin VB.Shape LED 
      FillStyle       =   0  'Solid
      Height          =   255
      Index           =   1
      Left            =   5400
      Top             =   1800
      Width           =   495
   End
   Begin VB.Shape LED 
      FillStyle       =   0  'Solid
      Height          =   255
      Index           =   0
      Left            =   5400
      Top             =   1440
      Width           =   495
   End
End
Attribute VB_Name = "StartUp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' This program searches for a specific device then waits for button changes
' I use overlapped IO so that the program does not appear to hang
'
' It also detects if the remote device is attached and/or removed
'
' Copyright 2005, John Hyde, USB Design By Example
' You may use this program for development but you may not sell or publish it
' without written permission from the author
'
Dim DeviceName As String    ' The system name for the remote button device
Dim WriteHandle As Long     ' Needed to write to a system device
Dim ReadHandle As Long      ' Needed to read a system device
Dim ReadEvent As Long       ' Needed to do overlapped (asynchronous) IO
Dim ReadOverlap As OVERLAPPED
Dim PollCounter As Integer  ' A local timer
Dim ButtonReport(1) As Byte ' Data read from ButtonsAndLights device
Dim LightsReport(1) As Byte ' Data written to ButtonsAndLights device
Dim Openned As Boolean      ' Is the ButtonsAndLights device operational?
Dim SoftButtonValue As Byte ' Local display value
Dim RealButtonValue As Byte ' Local display value
Dim Bit(3) As Byte          ' Used as a bit mask
Dim Operation As Integer    ' The LED display is a function of Soft and Real buttons
Dim PleaseAttach As String  ' A common message

Private Sub Form_Load()
PleaseAttach = "Please attach ButtonsAndLights Device"
Message.Text = PleaseAttach
' I do asyncnronous reads so I need an object to wait on
ReadEvent = CreateEvent(0, False, False, 0)
If (ReadEvent = 0) Then ErrorExit ("Could not create ReadEvent")
ReadOverlap.Offset = 0
ReadOverlap.OffsetHigh = 0
ReadOverlap.hEvent = ReadEvent
Bit(0) = 1: Bit(1) = 2: Bit(2) = 4: Bit(3) = 8
PollCounter = 100           ' Force an initial search for the IO device
End Sub

Sub UpdateLEDs()
' LED display = SoftButtonValue Operation RealButtonValue
Dim Value As Byte
Dim i As Integer
Select Case Operation
    Case 0: Value = SoftButtonValue
    Case 1: Value = RealButtonValue
    Case 2: Value = SoftButtonValue And RealButtonValue
    Case 3: Value = SoftButtonValue Or RealButtonValue
    End Select
' First update the local display
For i = 0 To 3
    If (Value And Bit(i)) Then LED(i).FillColor = vbGreen Else LED(i).FillColor = vbBlack
    Next i
' Now update the remote display
If (WriteHandle) Then
    LightsReport(1) = Value
    Call SendReport(LightsReport(0), 2)
    End If
End Sub

Sub UpdateRealButtons(Value As Byte)
Dim i As Integer
RealButtonValue = Value
For i = 0 To 3
    If (RealButtonValue And Bit(i)) Then RealButton(i).FillColor = vbWhite Else RealButton(i).FillColor = vbBlack
    Next i
Call UpdateLEDs
End Sub

Private Sub SetOperation_Click()
' Cycle through the operations
Operation = (Operation + 1) And 3
' Graphics are held off screen, copy the correct one to the display
FunctionGraphic(0).Picture = FunctionGraphic(Operation + 1).Picture
Call UpdateLEDs
End Sub

Sub SoftButton_click(index As Integer)
' Toggle its value and change it's color
If (SoftButtonValue And Bit(index)) Then
    SoftButtonValue = SoftButtonValue - Bit(index)
    SoftButton(index).BackColor = vbBlack
Else
    SoftButtonValue = SoftButtonValue + Bit(index)
    SoftButton(index).BackColor = vbWhite
End If
Call UpdateLEDs
End Sub

Private Sub Poll_Timer()
' I check for remote button presses every 100msec
Dim Result As Long
PollCounter = PollCounter + 1
If (PollCounter > 30) Then
' I check for the IO device attach or removal every 3 seconds
' I do this by closing the device and reopenning it
    PollCounter = 0
    If (Openned) Then Call CloseHIDDevice
    DeviceName = OpenButtonsAndLightsDevice()
    If (DeviceName = "") Then
        Message.Text = PleaseAttach
    Else
        If (Message.Text = PleaseAttach) Then Message.Text = "ButtonsAndLights device found"
        ReadHandle = OpenForRead(DeviceName)
        WriteHandle = OpenForWrite(DeviceName)
        Openned = True
        End If
    End If
If (ReadHandle) Then
' Start an asynchronous read, only wait up to 80msec
    Call StartRead(ButtonReport(0), 2)
    Result = WaitForSingleObject(ReadEvent, 80)
    Call ResetEvent(ReadEvent)
    If (Result = WAIT_TIMEOUT) Then
' Read was not successful, so cancel the request
        Result = CancelIo(ReadHandle)
    Else
' Read was successful and a change of button state was reported
        Call UpdateRealButtons(ButtonReport(1))
        End If
    End If
End Sub

Public Sub StartRead(Buffer As Byte, Count As Integer)
' Note that this HID report has a 0 byte as the first byte that is not sent on the bus
' Windows uses this as a ReportID
Dim Success, BytesRead As Long
Success = ReadFile(ReadHandle, Buffer, Count, BytesRead, ReadOverlap)
Exit Sub
StartReadError:
ErrorExit ("Error in StartRead")
End Sub

Public Sub SendReport(Buffer As Byte, Count As Integer)
' Note that this HID report has a 0 byte as the first byte that is not sent on the bus
' Windows uses this as a ReportID
Dim Success, BytesWritten As Long
Success = WriteFile(WriteHandle, Buffer, Count, BytesWritten, 0)
If ((Success = 0) Or (BytesWritten <> Count)) Then ErrorExit ("Error is SendReport")
End Sub

Private Sub Exit_Click()
Message.Text = "Closing ButtonsAndLights device"
Call CloseHIDDevice
Stop
End Sub

Public Function OpenButtonsAndLightsDevice() As String
' I know this is a HID device with a specific VID and PID.
' I also search for the UsagePage that defines the data reports
' I return the system name for the device or NULL if the device is not plugged in
Dim SystemName As String
' Check for examples 1 and 4
SystemName = FindHIDInterface(&H4242, &HEE01, &HFF00)
If (SystemName = "") Then SystemName = FindHIDInterface(&H4242, &HEE04, &HFF00)
OpenButtonsAndLightsDevice = SystemName
End Function

Sub CloseHIDDevice()
If (ReadHandle) Then Call CloseHandle(ReadHandle)
ReadHandle = 0
If (WriteHandle) Then Call CloseHandle(WriteHandle)
WriteHandle = 0
Openned = False
End Sub