fcomm1.frm

这是一个实际的工程中所用的源程序

VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.Form fComm1 
   Caption         =   "Form1"
   ClientHeight    =   3540
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   8085
   LinkTopic       =   "Form1"
   ScaleHeight     =   3540
   ScaleWidth      =   8085
   StartUpPosition =   3  '窗口缺省
   Begin VB.Timer tmrComm 
      Enabled         =   0   'False
      Interval        =   2000
      Left            =   2100
      Top             =   630
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Command2"
      Height          =   255
      Left            =   120
      TabIndex        =   10
      Top             =   2040
      Width           =   1035
   End
   Begin VB.TextBox txtSend 
      Height          =   375
      Index           =   7
      Left            =   5940
      TabIndex        =   9
      Text            =   "1111 1111 1111 1111"
      Top             =   1590
      Width           =   1875
   End
   Begin VB.TextBox txtSend 
      Height          =   375
      Index           =   6
      Left            =   3990
      TabIndex        =   8
      Text            =   "1111 1111 1111 1111"
      Top             =   1590
      Width           =   1875
   End
   Begin VB.TextBox txtSend 
      Height          =   375
      Index           =   5
      Left            =   1980
      TabIndex        =   7
      Text            =   "1111 1111 1111 1111"
      Top             =   1590
      Width           =   1875
   End
   Begin VB.TextBox txtSend 
      Height          =   375
      Index           =   4
      Left            =   30
      TabIndex        =   6
      Text            =   "1111 1111 1111 1111"
      Top             =   1590
      Width           =   1875
   End
   Begin VB.TextBox txtSend 
      Height          =   375
      Index           =   3
      Left            =   5910
      TabIndex        =   5
      Text            =   "1111 1111 1111 1111"
      Top             =   1080
      Width           =   1875
   End
   Begin VB.TextBox txtSend 
      Height          =   375
      Index           =   2
      Left            =   3960
      TabIndex        =   4
      Text            =   "1111 1111 1111 1111"
      Top             =   1080
      Width           =   1875
   End
   Begin VB.TextBox txtSend 
      Height          =   375
      Index           =   1
      Left            =   1950
      TabIndex        =   3
      Text            =   "1111 1111 1111 1111"
      Top             =   1080
      Width           =   1875
   End
   Begin VB.TextBox txtSend 
      Height          =   375
      Index           =   0
      Left            =   0
      TabIndex        =   2
      Text            =   "1111 1111 1111 1111"
      Top             =   1080
      Width           =   1875
   End
   Begin VB.TextBox Text1 
      Height          =   375
      Left            =   240
      TabIndex        =   1
      Top             =   180
      Width           =   7425
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   240
      TabIndex        =   0
      Top             =   600
      Width           =   945
   End
   Begin MSCommLib.MSComm MSComm1 
      Left            =   6420
      Top             =   630
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      DTREnable       =   -1  'True
      RThreshold      =   1
      ParitySetting   =   3
      InputMode       =   1
   End
   Begin MSCommLib.MSComm MSComm2 
      Left            =   6990
      Top             =   600
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      DTREnable       =   -1  'True
      InputMode       =   1
   End
End
Attribute VB_Name = "fComm1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'这个模块从串口1取数据。
'调度室：取流程和仪表数据（从中控室发来）；中控室取流程。
Const Settings_M As String = "9600,m,8,1"
Const Settings_S As String = "9600,s,8,1"
Const Settings_N As String = "9600,n,8,1"
'
Dim iDock As Integer
Dim DockData(0 To 19) As Integer

Private Sub tmrComm_Timer()
'iDock = (iDock + 1) Mod 2
iDock = 0
Call Send8x02(iDock + &H86)
End Sub

Private Sub Command1_Click()
   Call Send8x02(&H86 + 1) ' + 1
End Sub

Private Sub Form_Load()
On Error GoTo err1
Dim i As Integer
For i = 0 To 19
   DockData(i) = -1
Next i

Dim EnableComm As Integer

EnableComm = SetReg.GetSettingInt(Sc_Comm, "流程状态", 0)
Call SetReg.SaveSettingInt(Sc_Comm, "流程状态", EnableComm)
If EnableComm = 0 Then
#If dds = 0 Then
      Call openComm(COMM_PORT4)
      tmrComm.Enabled = True
#ElseIf dds = 1 Then
      Call openComm(1)
#End If
End If
Exit Sub
err1:
   MsgBox "与控制仪表的通信没有打开！", vbExclamation
End Sub
Private Sub openComm(ByVal com As Long)
    With MSComm1
        #If dds = 1 Then
         .Settings = Settings_N
        #End If
'         .Settings = Settings_N
        .CommPort = com
        .InBufferCount = 0
        .OutBufferCount = 0
        #If dds = 0 Then
        .RThreshold = 1
        #ElseIf dds = 1 Then
        .RThreshold = 2
        #End If
        .InputMode = comInputModeBinary
        If .PortOpen = False Then .PortOpen = True
    End With
End Sub
Private Sub Send8x02(ByVal v2 As Integer)  'v2：2#泊位/3#泊位
Dim sd02(0) As Byte
sd02(0) = &H2
Dim sd(0) As Byte
sd(0) = v2
'sd(1) = &H2
'MSComm1.PortOpen = False
    With MSComm1
        .Settings = Settings_M 'M
        .InputLen = 0
        .OutBufferCount = 0
        .InBufferCount = 0
        .RThreshold = 2
        If .PortOpen = False Then .PortOpen = True
        .Output = sd '(0)
        Do
        Loop Until .OutBufferCount = 0
'            DoEvents

'        .Settings = Settings_S
'        If .PortOpen = False Then .PortOpen = True
'        .Output = sd02
    End With
    Call mePauseX
'    DoEvents
'    DoEvents
'    DoEvents
    DoEvents
    With MSComm1
        .Settings = Settings_S
        .InputLen = 0
        .OutBufferCount = 0
        .InBufferCount = 0
        .RThreshold = 17
        If .PortOpen = False Then .PortOpen = True
        .Output = sd02
        Do
        Loop Until .OutBufferCount = 0
    End With
''    Call mePauseX(0.5)
End Sub

'   SUCCESS  Length: 1: 86
'   SUCCESS  Length: 1: 12
'   SUCCESS  Length: 17: 20 80 00 0F 06 00 2A 24 03 00 00 D0 07 00 00 00 22
'   SUCCESS  Length: 1: 87
'   SUCCESS  Length: 1: 12
'   SUCCESS  Length: 17: 10 01 00 D0 0A 00 00 00 0E 00 00 00 00 FF 00 00 07
'   SUCCESS  Length: 1: 81
'   SUCCESS  Length: 1: 42
'   SUCCESS  Length: 12: 00 00 00 00 00 00 00 00 00 10 93 5C
'Lenth:8  3F 12 10 1 0 D0 A 0x
'Lenth:8  3F 12 20 80 0 F 6 0x
'
'Lenth:8  3F 12 10 1 0 F0 1B E8x
'Lenth:8  3F 12 20 80 0 F 6 0x

'测试输出：Lenth:19  3F 12 08 80 00 33 00 00 2F 00 00 00 00 80 00 00 00 00 95x
'实际输出：    Length: 17: 08 80 00 33 00 00 2F 00 00 00 00 80 00 00 00 00 95

Private Sub MSComm1_OnComm()
Dim i As Long
Dim j As Long

Dim Dock As Integer

    Dim iAddr  As Integer '站号
    '
    Dim DisplayStr As String
    Dim dblTotal As Double
    Dim dblRate  As Double
    Dim dblSpeed As Double
    Dim isAlarm  As Boolean
    
    Dim bcNumber   As Integer, bcNumber1 As Integer
    Dim bcResetTotal As Double
    Dim bcTotal    As Double
    Dim bcSetPoint As Double
    Dim bcPreSet   As Double
    Dim bcPreAct   As Double
    
Dim sR As String
Dim Receive
    
    On Error Resume Next

    Select Case MSComm1.CommEvent
       'Errors
       Case comEventBreak
       Case comEventCDTO
       Case comEventCTSTO
       Case comEventDSRTO
       Case comEventFrame
       Case comEventOverrun
       Case comEventRxOver
       Case comEventRxParity
       Case comEventTxFull
       Case comEventDCB
       'Event
       Case comEvCD
       Case comEvCTS
       Case comEvDSR
       Case comEvRing
       Case comEvReceive

    'Debug.Assert False
    Receive = MSComm1.Input
    sR = ""
    For i = 0 To UBound(Receive)
        sR = sR & " " & CStr(Hex(Receive(i)))
    Next i
    
    Debug.Print "com1:Lenth:" & UBound(Receive) + 1 & " " & sR & "x"
    Text1.Text = ""
    Text1.Text = sR
'    If (Receive(0) = &H86 And Receive(1) = &H0) Or (Receive(0) = &H87 And Receive(1) = &H12) Or (Receive(0) = &H3F And Receive(1) = &H12) Or (Receive(0) = 2 And Receive(1) = 16) Then

    If (Receive(0) = &H86 And Receive(1) = &H12) Or (Receive(0) = &H87 And Receive(1) = &H12) Or (Receive(0) = &H3F And Receive(1) = &H12) Or (Receive(0) = 2 And Receive(1) = 16) Then
      For i = 0 To 19 '泊位信号的起始时清零
         DockData(i) = -1
      Next i
    End If
    
      j = -1
      Do
         j = j + 1
      Loop Until DockData(j) < 0
    For i = 0 To UBound(Receive)
      DockData(j) = Receive(i)
      j = j + 1
      'If j = 19 Then Debug.Assert False
      If j > 19 Then Exit For
    Next i
      
    If j >= 19 Then
   If DockData(0) = 2 And DockData(1) = 16 Then
             iAddr = CInt(DockData(2))
             
             
                
                dblRate = DealFloat(CByte(DockData(3)), CByte(DockData(4)), CByte(DockData(5)), CByte(DockData(6)))
           bcResetTotal = DealFloat(CByte(DockData(7)), CByte(DockData(8)), CByte(DockData(9)), CByte(DockData(10)))
                bcTotal = DealFloat(CByte(DockData(11)), CByte(DockData(12)), CByte(DockData(13)), CByte(DockData(14)))
             bcSetPoint = DealFloat(CByte(DockData(15)), CByte(DockData(16)), CByte(DockData(17)), CByte(DockData(18)))
            
'            Debug.Print "dblRate="; dblRate; " "; "ResetTotal="; bcResetTotal; " "; "bcTotal="; bcTotal; " "; "bcSetPoint="; bcSetPoint; " "; "bcPreSet="; bcPreSet; " "; "bcPreAct="; bcPreAct
        
        frmComm3.ComTechs = DockData
            
            
             With frmTechs.Shop2(modAddr.LogicAddr(iAddr))
               .d计量 = bcResetTotal
               .d流量 = dblRate
               .d设定 = bcSetPoint
               .d累计 = bcTotal
             End With
             With frmTechs1
               .txtLJ(modAddr.LogicAddr(iAddr)).Text = Format(bcTotal, "#0.00")
               .txtSD(modAddr.LogicAddr(iAddr)).Text = Format(bcSetPoint, "#0.00")
               .txtJL(modAddr.LogicAddr(iAddr)).Text = Format(bcResetTotal, "#0.00")
            End With
'      ElseIf (DockData(0) = &H3F And DockData(1) = &H0) Then

  ElseIf (DockData(0) = &H3F And DockData(1) = &H12) Then
       #If dds = 0 Then
       DockData(18) = iDock '用最后的校验位鉴别2/3泊位，传送到调度室
       DockData(19) = &HFF
       #End If
       Dock = DockData(18)
       frmComm3.ComStatus = DockData '传送到调度室/其他电脑(winsock)
       If Dock = 0 Then
       
         For i = 2 To UBound(DockData) - 2
           For j = 0 To 7
              NewStatus2((i - 2) * 8 + j) = Bit(DockData(i), j)
           Next j
         Next i
         
       ElseIf Dock = 1 Then
       
         For i = 2 To UBound(DockData) - 2
           For j = 0 To 7
              NewStatus3((i - 2) * 8 + j) = Bit(DockData(i), j)
           Next j
         Next i
       End If
   ElseIf (DockData(0) = &H86 And DockData(1) = &H12) Or (DockData(0) = &H87 And DockData(1) = &H12) Then
       #If dds = 0 Then
       DockData(18) = DockData(0) - &H86 'Dock '用最后的校验位鉴别2/3泊位，传送到调度室
       If DockData(18) < 0 Then Debug.Assert False
       DockData(19) = &HFF
       #End If
       Dock = DockData(18)
       frmComm3.ComStatus = DockData '传送到调度室
       If Dock = 0 Then
       
         For i = 2 To UBound(DockData) - 2
           For j = 0 To 7
              NewStatus2((i - 2) * 8 + j) = Bit(DockData(i), j)
           Next j
         Next i
         
       ElseIf Dock = 1 Then
       
         For i = 2 To UBound(DockData) - 2
           For j = 0 To 7
              NewStatus3((i - 2) * 8 + j) = Bit(DockData(i), j)
           Next j
         Next i
       End If
  End If
  End If 'j>=19
End Select
End Sub
Private Function cByteX(ByVal vStr As String) As String '1100 转化为"C"
    Dim s As Long
    s = Mid(vStr, 1, 1) * 8 + Mid(vStr, 2, 1) * 4 + Mid(vStr, 3, 1) * 2 + Mid(vStr, 4, 1)
    cByteX = Hex(s)
    
End Function


Private Sub Command2_Click() '构造通信结果
   Call Send8x02(&H87)
Exit Sub
    Dim i As Long
    Dim sd17(0 To 16) As Byte
    Dim send(1 To 32) As String
    Dim s
    Dim CrC As Long
    Dim j As Long
    For j = 0 To 7
        s = Split(txtSend(j).Text)
        For i = 0 To 3
            send(i + 1 + j * 4) = cByteX(s(i))
        Next i
    Next j
    For i = 1 To 32 Step 2
        sd17((i - 1) \ 2) = CByte("&H" & send(i) & send(i + 1))
    Next i
    CrC = 0
    For i = 0 To 15
        CrC = CrC + sd17(i)
    Next i
    sd17(16) = 255 - CrC Mod 256
    s = ""
    For i = 0 To 16
        s = s & " " & CStr(Hex(sd17(i)))
    Next i
    Text1.Text = s
    
End Sub