frmcomtocom.frm

监控类的开发

  Else
    mCapture.Checked = True
  End If
  
  bCapture = mCapture.Checked
  
  SaveSetting App.Title, "Commons", "Capture", bCapture
End Sub

Private Sub mChar_Click()
  If mChar.Checked = True Then
    mChar.Checked = False
    mHex.Checked = True
  Else
    mChar.Checked = True
    mHex.Checked = False
  End If
  
  nDisplayMode = IIf(mChar.Checked, MODE_CHAR, MODE_HEX)
  SaveSetting App.Title, "Commons", "DisplayMode", Str(nDisplayMode)
End Sub

Private Sub mCharHex_Click()
  If txtChars.Text = "" And txtHex.Text = "" Then
    MsgBox "Please input some chars in either Hex or Char TextBox!", vbCritical + vbOKOnly
    Exit Sub
  End If
    
  If txtChars.Text <> "" And txtHex.Text <> "" Then
    MsgBox "Please input some chars in only one TextBox!", vbCritical + vbOKOnly
    Exit Sub
  End If
    
  If txtHex.Text = "" Then
    txtHex.Text = StringToHexChars(txtChars.Text)
  Else
    If CheckLegalChars(UCase(txtHex.Text), HEX_CHAR_SET) = False Then
      MsgBox "Error chars in Hex TextBox!", vbCritical + vbOKOnly
      Exit Sub
    Else
      txtChars.Text = HexCharsToString(txtHex.Text)
    End If
  End If
End Sub

Private Sub mClear_Click()
  If Len(Trim(txtHex.SelText)) > 0 Then
    txtHex.Text = ""
    Exit Sub
  End If
    
  If Len(Trim(txtChars.SelText)) > 0 Then
    txtChars.Text = ""
    Exit Sub
  End If
    
  If Len(Trim(txtResult.SelText)) > 0 Then
    txtResult.Text = ""
    ResultString = ""
    Exit Sub
  End If
    
  txtHex.Text = ""
  txtChars.Text = ""
  txtResult.Text = ""
  ResultString = ""
  strHistory = ""
End Sub

Private Sub ClosePort(objComm As MSComm)
  Dim Settings As String
  
  CloseMsComm objComm, 50
  Settings = objComm.Settings
  ResultString = ResultString + GetTimeStamp(0) + "Serial port settings: " + _
            "COM" + Trim(Str(objComm.CommPort)) + "; " + Settings + "; " + _
            IIf(objComm.PortOpen = True, "Open", "Close")
    
  Call DisplayString(txtResult, ResultString)
    
  SetComStatus
End Sub

Private Sub mClose_Click()
  ClosePort MSComm1
  ClosePort MSComm2
End Sub

Private Sub mExit_Click()
  Unload Me
End Sub

Private Sub mFind_Click()
  Dim strTmp As String
  Dim nTmp As Integer
  Dim nCursor As Integer
  On Error Resume Next
    
  If txtResult.Text = "" Then
    MsgBox "There is no content in txtResult!", vbExclamation + vbOKOnly
    Exit Sub
  End If
    
  If txtResult.SelText <> "" Then
    txtHex.Text = txtResult.SelText
  End If
  strTmp = Trim(txtHex.Text)
    
  If strTmp = "" Then
    MsgBox "Please input some characters in Hex Box!", vbExclamation + vbOKOnly
    Exit Sub
  End If
    
  txtResult.SetFocus
  nCursor = txtResult.SelStart + 2
  nTmp = InStr(nCursor, txtResult.Text, strTmp)
  If nTmp = 0 Then
    txtResult.SelStart = Len(txtResult.Text)
    MsgBox "Cannot find 【" + strTmp + "】!", vbExclamation + vbOKOnly
    Exit Sub
  Else
    nTmp = nTmp - 1
    txtResult.SelStart = nTmp
  End If
End Sub

Private Sub mGateway_Click()
  If mGateway.Checked = True Then
    mGateway.Checked = False
    bGateWay = False
  Else
    mGateway.Checked = True
    bGateWay = True
  End If
End Sub

Private Sub mHex_Click()
  mChar_Click
End Sub

Private Sub OpenPort(objComm As MSComm)
  Dim Settings As String
  On Error Resume Next
    
  OpenAndAdjustPort objComm
  If Err.Number <> 0 Then
    MsgBox Error$, vbCritical + vbOKOnly
    GoTo END_MARK
  End If
  
  Settings = objComm.Settings
  ResultString = ResultString + GetTimeStamp(0) + "Serial port settings: " + _
            "COM" + Trim(Str(objComm.CommPort)) + "; " + Settings + "; " + _
            IIf(objComm.PortOpen = True, "Open", "Close")
    
  Call DisplayString(txtResult, ResultString)
  
END_MARK:
  SetComStatus
End Sub

Private Sub mOpen_Click()
  OpenPort MSComm1
  OpenPort MSComm2
End Sub

Private Sub mParity_Click()
  frmParity.Show
End Sub

Private Sub mProtocols_Click()
  frmProtocols.Show
End Sub

Private Sub mSaveHistory_Click()
  WriteStringToTxt strHistory + ResultString, App.Path + "\History.txt"
End Sub

Private Sub MSComm1_OnComm()
  Dim vInBuffer As Variant
  On Error Resume Next
    
  Select Case MSComm1.CommEvent
    'Events
    Case comEvReceive
      If commTimerStartMark1 = False Then
        initialPRJ 1  'This is the first package
        commTimerStartMark1 = True
      End If
      
      vInBuffer = MSComm1.Input
      strRecHex1 = strRecHex1 + VariantToHexChars(vInBuffer)
                
      'There is another package, so reset the commTimer1.
      If commTimerStartMark1 = True Then
        commTimer1.Enabled = False
        commTimer1.Enabled = True
      End If
                
      If nDisplayMode = MODE_CHAR Then
        ResultString = ResultString + GetTimeStamp(0) + "[Master]<" + HexCharsToString(strRecHex1)
      Else
        ResultString = ResultString + GetTimeStamp(0) + "[Master]<" + strRecHex1
      End If
            
    Case comEvSend
            
    Case comEvCTS
      ResultString = ResultString + GetTimeStamp(0) + ":Change in the CTS line."
    Case comEvDSR
      ResultString = ResultString + GetTimeStamp(0) + ":Change in the DSR line."
    Case comEvCD
      'ResultString = ResultString + GetTimeStamp(0) + ":Change in the CD line."
    Case comEvRing
      ResultString = ResultString + GetTimeStamp(0) + ":Change in the Ring Indicator."
            
    ' Errors
    Case comEventBreak
      ResultString = ResultString + GetTimeStamp(0) + ":A Break was received."
    Case comEventCDTO
      ResultString = ResultString + GetTimeStamp(0) + ":CD (RLSD) Timeout."
    Case comEventCTSTO
      ResultString = ResultString + GetTimeStamp(0) + ":CTS Timeout."
    Case comEventDSRTO
      ResultString = ResultString + GetTimeStamp(0) + ":DSR Timeout."
    Case comEventFrame
      ResultString = ResultString + GetTimeStamp(0) + ":Framing Error."
    Case comEventOverrun
      ResultString = ResultString + GetTimeStamp(0) + ":Data Lost."
    Case comEventRxOver
      ResultString = ResultString + GetTimeStamp(0) + ":Receive buffer overflow."
    Case comEventRxParity
      ResultString = ResultString + GetTimeStamp(0) + ":Parity Error."
    Case comEventTxFull
      ResultString = ResultString + GetTimeStamp(0) + ":Transmit buffer full."
    Case comEventDCB
      ResultString = ResultString + GetTimeStamp(0) + ":Unexpected error retrieving DCB."
  End Select
        
  Call DisplayString(txtResult, ResultString)
End Sub

Private Sub MSComm2_OnComm()
  Dim vInBuffer As Variant
  On Error Resume Next
    
  Select Case MSComm2.CommEvent
    'Events
    Case comEvReceive
      If commTimerStartMark2 = False Then
        initialPRJ 2  'This is the first package
        commTimerStartMark2 = True
      End If
      
      vInBuffer = MSComm2.Input
      strRecHex2 = strRecHex2 + VariantToHexChars(vInBuffer)
                
      'There is another package, so reset the commTimer2.
      If commTimerStartMark2 = True Then
        commTimer2.Enabled = False
        commTimer2.Enabled = True
      End If
                
      If nDisplayMode = MODE_CHAR Then
        ResultString = ResultString + GetTimeStamp(0) + "[Slave]<" + HexCharsToString(strRecHex2)
      Else
        ResultString = ResultString + GetTimeStamp(0) + "[Slave]<" + strRecHex2
      End If
            
    Case comEvSend
            
    Case comEvCTS
      ResultString = ResultString + GetTimeStamp(0) + ":Change in the CTS line."
    Case comEvDSR
      ResultString = ResultString + GetTimeStamp(0) + ":Change in the DSR line."
    Case comEvCD
      'ResultString = ResultString + GetTimeStamp(0) + ":Change in the CD line."
    Case comEvRing
      ResultString = ResultString + GetTimeStamp(0) + ":Change in the Ring Indicator."
            
    ' Errors
    Case comEventBreak
      ResultString = ResultString + GetTimeStamp(0) + ":A Break was received."
    Case comEventCDTO
      ResultString = ResultString + GetTimeStamp(0) + ":CD (RLSD) Timeout."
    Case comEventCTSTO
      ResultString = ResultString + GetTimeStamp(0) + ":CTS Timeout."
    Case comEventDSRTO
      ResultString = ResultString + GetTimeStamp(0) + ":DSR Timeout."
    Case comEventFrame
      ResultString = ResultString + GetTimeStamp(0) + ":Framing Error."
    Case comEventOverrun
      ResultString = ResultString + GetTimeStamp(0) + ":Data Lost."
    Case comEventRxOver
      ResultString = ResultString + GetTimeStamp(0) + ":Receive buffer overflow."
    Case comEventRxParity
      ResultString = ResultString + GetTimeStamp(0) + ":Parity Error."
    Case comEventTxFull
      ResultString = ResultString + GetTimeStamp(0) + ":Transmit buffer full."
    Case comEventDCB
      ResultString = ResultString + GetTimeStamp(0) + ":Unexpected error retrieving DCB."
  End Select
        
  Call DisplayString(txtResult, ResultString)
End Sub

Private Sub mSetupMaster_Click()
  frmSetupCOM1.Show vbModal
End Sub

Private Sub mSetupSlave_Click()
  frmSetupCOM2.Show vbModal
End Sub

Private Sub mSound_Click()
  If mSound.Checked = True Then
    mSound.Checked = False
  Else
    mSound.Checked = True
  End If
  
  If mSound.Checked = True And strSoundPath <> "" Then
    bSoundMark = True
  Else
    bSoundMark = False
  End If

  SaveSetting App.Title, "Commons", "Sound", bSoundMark
End Sub

Private Sub mTopics_Click()
  SendKeys "{F1}"
End Sub

Private Sub StatusBar1_PanelClick(ByVal Panel As MSComctlLib.Panel)
  If nBarStatus = 0 Then
    StatusBar1.Panels("ComStatus").Text = "Status: " + GetComStatus(MSComm2)
    nBarStatus = 1
  Else
    StatusBar1.Panels("ComStatus").Text = "Status: " + GetComStatus(MSComm1)
    nBarStatus = 0
  End If
End Sub

Private Sub tbrToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)
  Select Case Button.Key
    Case "SetupMaster"
      mSetupMaster_Click
    Case "SetupSlave"
      mSetupSlave_Click
    Case "Protocols"
      mProtocols_Click
    Case "Clear"
      mClear_Click
    Case "Char-Hex"
      mCharHex_Click
    Case "Exit"
      mExit_Click
  End Select
End Sub

Private Sub txtResult_KeyDown(KeyCode As Integer, Shift As Integer)
  '114 for 【F3】
  If KeyCode = 114 And txtHex.Text <> "" Then Call mFind_Click

  If KeyCode = 65 And Shift = 2 Then
    txtResult.SelStart = 0
    txtResult.SelLength = Len(txtResult.Text)
  End If
End Sub