frmmain.frm

RS485服务器程序,实现设置Nodes,检测Nodes以及传输数据

VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.1#0"; "RICHTX32.OCX"
Begin VB.Form frmMain 
   Caption         =   "Serial Port Complete"
   ClientHeight    =   4296
   ClientLeft      =   132
   ClientTop       =   420
   ClientWidth     =   7032
   LinkTopic       =   "Form1"
   ScaleHeight     =   4296
   ScaleWidth      =   7032
   StartUpPosition =   2  'CenterScreen
   Begin VB.Timer tmrTransferInterval 
      Enabled         =   0   'False
      Left            =   1560
      Top             =   4560
   End
   Begin VB.Frame fraTransfer 
      Caption         =   "Transfer"
      Height          =   1812
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   6732
      Begin VB.Frame fraStart 
         Height          =   1452
         Left            =   4560
         TabIndex        =   11
         Top             =   240
         Width           =   1932
         Begin VB.CommandButton cmdStart 
            Caption         =   "Start"
            Height          =   492
            Left            =   120
            TabIndex        =   13
            Top             =   240
            Width           =   1692
         End
         Begin VB.CommandButton cmdStop 
            Caption         =   "Stop"
            Height          =   492
            Left            =   120
            TabIndex        =   12
            Top             =   840
            Width           =   1692
         End
      End
      Begin VB.Frame fraInterval 
         Caption         =   "Interval"
         Height          =   1332
         Left            =   120
         TabIndex        =   3
         Top             =   360
         Width           =   4332
         Begin VB.Frame fraSingleOrContinuous 
            Height          =   732
            Left            =   2640
            TabIndex        =   8
            Top             =   360
            Width           =   1572
            Begin VB.OptionButton optSingleOrContinuous 
               Caption         =   "Continuous"
               Height          =   252
               Index           =   1
               Left            =   240
               TabIndex        =   10
               Top             =   360
               Width           =   1212
            End
            Begin VB.OptionButton optSingleOrContinuous 
               Caption         =   "Single"
               Height          =   252
               Index           =   0
               Left            =   240
               TabIndex        =   9
               Top             =   120
               Width           =   1212
            End
         End
         Begin VB.OptionButton optIntervalUnits 
            Caption         =   "Hours"
            Height          =   252
            Index           =   2
            Left            =   1560
            TabIndex        =   7
            Top             =   840
            Width           =   972
         End
         Begin VB.OptionButton optIntervalUnits 
            Caption         =   "Minutes"
            Height          =   252
            Index           =   1
            Left            =   1560
            TabIndex        =   6
            Top             =   600
            Width           =   972
         End
         Begin VB.OptionButton optIntervalUnits 
            Caption         =   "Seconds"
            Height          =   252
            Index           =   0
            Left            =   1560
            TabIndex        =   5
            Top             =   360
            Width           =   972
         End
         Begin VB.ComboBox cboIntervalValue 
            Height          =   288
            Left            =   240
            Style           =   2  'Dropdown List
            TabIndex        =   4
            Top             =   600
            Width           =   1212
         End
      End
   End
   Begin VB.CommandButton cmdTest 
      Caption         =   "Test"
      Height          =   372
      Left            =   5760
      TabIndex        =   1
      Top             =   4440
      Width           =   972
   End
   Begin RichTextLib.RichTextBox rtxStatus 
      Height          =   2172
      Left            =   120
      TabIndex        =   0
      Top             =   2040
      Width           =   6732
      _ExtentX        =   11875
      _ExtentY        =   3831
      _Version        =   327680
      TextRTF         =   $"frmMain.frx":0000
   End
   Begin VB.Timer tmrTimeout 
      Enabled         =   0   'False
      Left            =   960
      Top             =   4560
   End
   Begin MSCommLib.MSComm MSComm1 
      Left            =   240
      Top             =   4440
      _ExtentX        =   804
      _ExtentY        =   804
      _Version        =   327680
      DTREnable       =   -1  'True
   End
   Begin VB.Menu mnuSetup 
      Caption         =   "Setup"
      Index           =   0
      Begin VB.Menu mnuPortSettings 
         Caption         =   "Port Settings"
         Index           =   0
         Shortcut        =   ^P
      End
      Begin VB.Menu mnuNodes 
         Caption         =   "Nodes"
         Index           =   1
         Shortcut        =   ^N
      End
      Begin VB.Menu mnuDataFile 
         Caption         =   "Data File"
         Index           =   2
         Shortcut        =   ^D
      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
'A master node communicates with up to 7 slave nodes
'over a half-duplex RS-485 interface.
'Each node has an address.
'Each message consists of the receiver's address, followed by
'4 ASCII hex bytes representing 2 binary values.
'Each reply consists of the sender's address,
'followed by 4 ASCII hex bytes representing 2 binary values.
Option Base 0
'Delay (milliseconds) to ensure RTS has toggled (Windows delay):
Const RTSDelay = 200
'Delay (milliseconds) before enabling transmitter,
'to allow the slave to disable its transmitter.
Const EnableDelay = 500
'Delay (milliseconds) to wait for a reply from a slave.
Const ReplyDelay = 3000
'Node 0 is the master; other nodes are slaves.
Const HighestNodeNumber = 7
'With each message, the master sends and receives 4 ASCII hex bytes.
Const NumberOfDataBytesOut = 4
Const NumberOfDataBytesIn = 4

Private Type typNodes
    Address(0 To HighestNodeNumber) As Byte
    DataOut1(0 To HighestNodeNumber) As Byte
    DataOut2(0 To HighestNodeNumber) As Byte
    DataIn1(0 To HighestNodeNumber) As Byte
    DataIn2(0 To HighestNodeNumber) As Byte
    Status(0 To HighestNodeNumber) As String
    Cpu(0 To HighestNodeNumber) As String
    Active(0 To HighestNodeNumber) As Integer
    LastAccess(0 To HighestNodeNumber) As String
End Type
Private Type typDataTransferFormat
    SingleOrContinuous As String
    IntervalUnits As String
    IntervalValue As Single
End Type

Dim Nodes As typNodes
Dim SelectedNode As Integer
Dim PollInterval As Integer
Dim DataOut(NumberOfDataBytesOut - 1) As Byte
Dim DataIn(NumberOfDataBytesIn - 1) As Byte
Dim DataTransferFormat As typDataTransferFormat
Dim PreviousTime As Date
Dim TimeOfTransfer As String
Dim TransferInProgress As Boolean

Private Function fncConfirmTransmittedData _
    (Buffer As Variant) _
    As Integer
'Ensure that all data has transmitted by reading it back.
'Receiver must be enabled!
'Returned values:
'-1 = Data read back successfully
'0 = Data didn't match
'1 = Timeout
Dim DataReadBack As String
'Estimate the time to transmit the data:
tmrTimeout.Interval = OneByteDelay * LenB(Buffer) + 500
tmrTimeout.Enabled = True
TimedOut = False
Do
    DoEvents
Loop Until MSComm1.InBufferCount >= Len(Buffer) Or TimedOut = True
DataReadBack = MSComm1.Input
If StrComp(DataReadBack, Buffer, vbBinaryCompare) = 0 Then
    fncConfirmTransmittedData = -1
Else
    If TimedOut = False Then
        fncConfirmTransmittedData = 0
    Else
        fncConfirmTransmittedData = 1
    End If
End If
tmrTimeout.Enabled = False
TimedOut = False
End Function

Private Function fncCreateMessage(NodeNumber As Integer) As String
'A message consists of four bytes in ASCII hex format.
'Each ASCII hex pair represents the value of a byte.
Dim MessageLength As Integer
Dim MessageToSend As String
    MessageLength = NumberOfDataBytesOut - 1
    Call GetDataToSend(NodeNumber)
    'Create the message, consisting of
    '4 bytes that contain the 2 data bytes in ASCII hex format.
    'Each byte represents 1 hex digit (4 bits).
    'Convert the 2 data bytes to ASCII hex
    'and store in the Message string.
    MessageToSend = fncByteToAsciiHex(Nodes.DataOut1(NodeNumber)) & _
        fncByteToAsciiHex(Nodes.DataOut2(NodeNumber))
    fncCreateMessage = MessageToSend
End Function
Private Function fncDisplayDateAndTime() As String
'Date and time formatting.
fncDisplayDateAndTime = _
    CStr(Format(Date, "General Date")) & ", " & _
        (Format(Time, "Long Time"))
End Function

Private Function fncWaitForAck(NodeNumber As Integer) As Boolean
'End on receiving Acknowledge from the slave or timeout.
Dim Ack As Boolean
Dim NodeAddress As String
Dim ReceivedData As String
'The Acknowledge is the node address.
NodeAddress = Chr(Nodes.Address(NodeNumber))
Ack = False
tmrTimeout.Interval = ReplyDelay
'Disable the transmitter until Ack is received or timeout.
Call DisableTransmitter
'Wait for Acknowledge.
Do
    tmrTimeout.Enabled = True
    TimedOut = False
    Do
        DoEvents
    Loop Until (MSComm1.InBufferCount >= 1) Or (TimedOut = True)
    If TimedOut = False Then
        tmrTimeout.Enabled = False
        'Read the byte & compare to what was sent.
        ReceivedData = MSComm1.Input
        If StrComp _
            (ReceivedData, NodeAddress, vbBinaryCompare) = 0 Then
                Ack = True
            Nodes.DataIn1(NodeNumber) = Asc(ReceivedData)
        Else
            'if the Ack doesn't match the node address:
            Ack = False
            Call SaveResults(NodeNumber, 0, 0, "Ack Error")
         End If
    Else
        Ack = False
        Call SaveResults(NodeNumber, 0, 0, "No Ack")
    End If
Loop Until Ack = True Or TimedOut = True
tmrTimeout.Enabled = False
fncWaitForAck = Ack
TimedOut = False
Call EnableTransmitter(EnableDelay)
End Function

Private Function fncWaitForReply(NodeNumber As Integer) As Boolean
'From the slave, read the node address & 4 ASCII hex bytes.
Dim Ack As Boolean
Dim Reply As Boolean
Dim ReceivedData As String
Ack = False
Reply = False
TimedOut = False
tmrTimeout.Interval = ReplyDelay
'Disable the transmitter until bytes are received or timeout.
Call DisableTransmitter
tmrTimeout.Enabled = True
Do
    'Wait for reply
    TimedOut = False
    Do
        DoEvents
    Loop Until (MSComm1.InBufferCount > 4) Or (TimedOut = True)
    If TimedOut = False Then
        tmrTimeout.Enabled = False
        ReceivedData = MSComm1.Input
        Reply = True
        If StrComp(Asc(Left(ReceivedData, 1)), _
            Nodes.Address(NodeNumber), vbBinaryCompare) = 0 Then
            'If the first byte equals the slave's address,
            'get the numeric value of each pair of ASCII hex bytes.
            Call SaveResults _
                (NodeNumber, _
                Val("&h" & Mid(ReceivedData, 2, 2)), _
                 Val("&h" & Mid(ReceivedData, 4, 2)), _
                 "OK")
        Else
            'If the first byte doesn't equal the node address:
             Call SaveResults(NodeNumber, 0, 0, "Data Error")
        End If
     Else
        'If the wait for a reply times out:
        Call SaveResults(NodeNumber, 0, 0, "Reply Timeout")
     End If
Loop Until Reply = True Or TimedOut = True
tmrTimeout.Enabled = False
Call EnableTransmitter(EnableDelay)
fncWaitForReply = Reply
End Function

Private Sub cboIntervalValue_Click()
'Store the selected interval for data transfers.
DataTransferFormat.IntervalValue = Val(cboIntervalValue.Text)
'With shorter intervals, check elapsed time more often.
Select Case DataTransferFormat.IntervalUnits
    Case "seconds"
        tmrTransferInterval.Interval = 100
    Case "minutes", "hours"
        tmrTransferInterval.Interval = 1000
End Select
End Sub

Private Sub cmdStart_Click()
'Initiate data transfer.
Select Case DataTransferFormat.SingleOrContinuous
    Case "single"
        'Transfer data once.
        'Disable the Start button until polling is finished.
        cmdStart.Enabled = False
        Call PollSlave
        cmdStart.Enabled = True
    Case "continuous"
        'Do one transfer immediately, then let the timer take over.
        cmdStart.Enabled = False
        cmdStop.Enabled = True
        cmdStop.SetFocus
        PreviousTime = Now
        tmrTransferInterval.Enabled = True
        Call PollSlave
    Case Else
End Select
End Sub

Private Sub cmdStop_Click()
'Stop transferring data.
tmrTransferInterval.Enabled = False
cmdStop.Enabled = False
cmdStart.Enabled = True
Call DisableTransmitter
End Sub