frmcomtocom.frm

监控类的开发

         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   420
      IMEMode         =   3  'DISABLE
      Left            =   720
      TabIndex        =   0
      Top             =   960
      Width           =   5775
   End
   Begin VB.Line Line1 
      BorderWidth     =   2
      X1              =   0
      X2              =   6600
      Y1              =   360
      Y2              =   360
   End
   Begin VB.Label Label2 
      Caption         =   "Char:"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   12
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   120
      TabIndex        =   4
      Top             =   1080
      Width           =   975
   End
   Begin VB.Label Label1 
      Caption         =   "Hex:"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   12
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   120
      TabIndex        =   3
      Top             =   600
      Width           =   735
   End
   Begin VB.Line Line2 
      BorderColor     =   &H80000005&
      BorderWidth     =   3
      X1              =   0
      X2              =   6600
      Y1              =   360
      Y2              =   360
   End
   Begin VB.Menu mSystem 
      Caption         =   "&System"
      Begin VB.Menu mSetupMaster 
         Caption         =   "Setup Master"
      End
      Begin VB.Menu mSetupSlave 
         Caption         =   "Setup Slave"
      End
      Begin VB.Menu mLineSystem1 
         Caption         =   "-"
      End
      Begin VB.Menu mProtocols 
         Caption         =   "Protocols"
      End
      Begin VB.Menu mSaveHistory 
         Caption         =   "Save History"
      End
      Begin VB.Menu mLineSystem2 
         Caption         =   "-"
      End
      Begin VB.Menu mExit 
         Caption         =   "Exit"
      End
   End
   Begin VB.Menu mDisplay 
      Caption         =   "&Display"
      Begin VB.Menu mChar 
         Caption         =   "&Char"
      End
      Begin VB.Menu mHex 
         Caption         =   "&Hex"
         Checked         =   -1  'True
      End
      Begin VB.Menu mSound 
         Caption         =   "&Sound"
         Checked         =   -1  'True
      End
   End
   Begin VB.Menu mFunctions 
      Caption         =   "&Functions"
      Begin VB.Menu mGateway 
         Caption         =   "Gateway"
         Checked         =   -1  'True
         Enabled         =   0   'False
      End
      Begin VB.Menu mCapture 
         Caption         =   "Capture"
      End
   End
   Begin VB.Menu mOperate 
      Caption         =   "&Operation"
      Begin VB.Menu mOpen 
         Caption         =   "Open"
      End
      Begin VB.Menu mClose 
         Caption         =   "Close"
      End
      Begin VB.Menu mLineOperation2 
         Caption         =   "-"
      End
   End
   Begin VB.Menu mTools 
      Caption         =   "&Tools"
      Begin VB.Menu mClear 
         Caption         =   "Clear"
      End
      Begin VB.Menu mCharHex 
         Caption         =   "Char/Hex"
      End
      Begin VB.Menu mParity 
         Caption         =   "Parity"
      End
      Begin VB.Menu mFind 
         Caption         =   "Find"
      End
   End
   Begin VB.Menu mHelp 
      Caption         =   "&Help"
      Begin VB.Menu mTopics 
         Caption         =   "Topics"
         Enabled         =   0   'False
      End
      Begin VB.Menu mLineHelp 
         Caption         =   "-"
      End
      Begin VB.Menu mAbout 
         Caption         =   "About ..."
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim nBarStatus As Integer
Dim nID As Integer

Public Sub initialPRJ(nSort As Integer)
  If nSort = 1 Then
    strRecHex1 = ""
    commTimerStartMark1 = False
    commTimer1.Enabled = False
  Else
    strRecHex2 = ""
    commTimerStartMark2 = False
    commTimer2.Enabled = False
  End If
End Sub

Private Sub RefreshProtocols(nID_Num As Integer)
  On Error Resume Next
  
  With AdodcProtocols
    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + _
                        strDataPath + ";Persist Security Info=False"
    .CommandType = adCmdUnknown
    .RecordSource = "select * from Protocols order by ID"
    .Refresh
    With .Recordset
      If .RecordCount > 0 Then .MoveFirst
      If .RecordCount < nID_Num Then Exit Sub
      Do While Not .EOF
        If !ID = nID_Num Then Exit Do
        .MoveNext
        DoEvents
      Loop
    End With
  End With
End Sub

Public Sub SetComStatus()
  If MSComm1.PortOpen = False Then
    imgNotConnected.ZOrder
  Else
    imgConnected.ZOrder
  End If
  
  StatusBar1.Panels("ComStatus").Text = "Status: " + GetComStatus(MSComm1)
End Sub

Private Sub SendDisplay(objComm As MSComm, nSort As Integer)
    Dim strTmp As String
    Dim strData As String
    On Error Resume Next
      
    If objComm.PortOpen = False Then
        MsgBox "The port is close!", vbCritical + vbOKOnly
        Exit Sub
    End If
      
    If nSort = 1 Then  'from slave to master
        strData = PickPurePackage(txtHex.Text, nBlockParity2, nEndMark2)
        strTmp = SendData(objComm, strData, nBlockParity1, nEndMark1)
        ResultString = ResultString + GetTimeStamp(0) + "[Master]>"
    Else               'from master to slave
        strData = PickPurePackage(txtHex.Text, nBlockParity1, nEndMark1)
        strTmp = SendData(objComm, strData, nBlockParity2, nEndMark2)
        ResultString = ResultString + GetTimeStamp(0) + "[Slave]>"
    End If
    
    If nDisplayMode = MODE_CHAR Then
        ResultString = ResultString + HexCharsToString(strTmp)
    Else
        ResultString = ResultString + strTmp
    End If
    
    Call DisplayString(txtResult, ResultString)
End Sub

Private Sub commTimer1_Timer()
    On Error Resume Next
    
    commTimer1.Enabled = False
    commTimerStartMark1 = False
    txtHex.Text = strRecHex1
    txtChars.Text = HexCharsToString(strRecHex1)
      
    If bSoundMark = True Then PlaySound strSoundPath, 0, SND_ASYNC
    If strDataPath = "" Then GoTo EndMark
  
    If (bCapture = True) And CheckPackage(txtHex.Text, nBlockParity1, nEndMark1) Then
        If Len(txtHex.Text) < nMaxProtocolBytes * 2 + 1 Then
            With AdodcProtocols.Recordset
                If .RecordCount > 0 Then .MoveFirst
                Do While Not .EOF
                    If ![MasterProtocol] = PickPurePackage(txtHex.Text, nBlockParity1, nEndMark1) Then Exit Do
                    .MoveNext
                    DoEvents
                Loop
                
                If .EOF Then
                    .AddNew
                    !ID = .RecordCount
                    ![MasterProtocol] = PickPurePackage(txtHex.Text, nBlockParity1, nEndMark1)
                    .Update
                    .Requery
                    .MoveLast
                End If
            End With
        Else
            MsgBox "The protocol must be less than 128！", vbExclamation + vbOKOnly
        End If
    End If
  
EndMark:
    SendDisplay MSComm2, 2
End Sub

Private Sub commTimer2_Timer()
  On Error Resume Next
  
  commTimer2.Enabled = False
  commTimerStartMark2 = False
  txtHex.Text = strRecHex2
  txtChars.Text = HexCharsToString(strRecHex2)
    
  If bSoundMark = True Then PlaySound strSoundPath, 0, SND_ASYNC
  If strDataPath = "" Then GoTo EndMark
  
  If (bCapture = True) And CheckPackage(txtHex.Text, nBlockParity2, nEndMark2) Then
    If Len(txtHex.Text) < nMaxProtocolBytes * 2 + 1 Then
      With AdodcProtocols.Recordset
        If (Not .EOF And Not .BOF) And .RecordCount > 0 Then
          ![SlaveProtocol] = PickPurePackage(txtHex.Text, nBlockParity2, nEndMark2)
          .Update
          .Requery
        End If
      End With
    Else
      MsgBox "The protocol must be less than 128！", vbExclamation + vbOKOnly
    End If
  End If

EndMark:
  SendDisplay MSComm1, 1
End Sub

Private Sub Form_Load()
  Dim strTmp As String
  On Error Resume Next
    
  App.Title = "Serial Protocols Capture and Converter"
  
  strTmp = App.Path + "\PortBytes.mdb"
  If CheckFile(strTmp) Then
    strDataPath = strTmp
    RefreshProtocols 1
  Else
    'MsgBox "Cannot find database ！", vbExclamation + vbOKOnly
    mProtocols.Enabled = False
  End If
  
  strTmp = App.Path + "\Ding.wav"
  If CheckFile(strTmp) Then
    strSoundPath = strTmp
  Else
    'MsgBox "Cannot find Ding.WAV ！", vbExclamation + vbOKOnly
  End If
    
  initialPRJ 1
  initialPRJ 2
    
  txtResult.ForeColor = vbBlue
  nDisplayMode = Val(GetSetting(App.Title, "Commons", "DisplayMode", ""))
  If nDisplayMode = MODE_CHAR Then
    mChar.Checked = True
    mHex.Checked = False
  Else
    mChar.Checked = False
    mHex.Checked = True
  End If
  bSoundMark = IIf(GetSetting(App.Title, "Commons", "Sound", "") = "", False, True)
  If strSoundPath = "" Then bSoundMark = False
  mSound.Checked = bSoundMark
  bCapture = IIf(GetSetting(App.Title, "Commons", "Capture", "") = "", False, True)
  mCapture.Checked = bCapture

  RestoreComData 1, MSComm1
  RestoreComData 2, MSComm2
  
  SetComStatus
End Sub

Private Sub Form_Resize()
   Frame1.Left = ScaleWidth - Frame1.Width * 2
End Sub

Private Sub Form_Unload(Cancel As Integer)
  CloseMsComm MSComm1, 50
  CloseMsComm MSComm2, 50
  commTimer1.Enabled = False
  commTimer2.Enabled = False
  
  Unload frmProtocols
  Unload frmParity
End Sub

Private Sub imgConnected_Click()
  mClose_Click
End Sub

Private Sub imgNotConnected_Click()
  mOpen_Click
End Sub

Private Sub mAbout_Click()
  frmAbout.Show vbModal
End Sub

Private Sub mCapture_Click()
  If mCapture.Checked = True Then
    mCapture.Checked = False