frmmain.frm

串口双机互相连接

'************************************************
'打开
'打开标准对话框，选择待发送的文件
'************************************************

Private Sub cmdFileOpen_Click()
   
    On Error GoTo cancel
    Call optSend_Click
    
    frmMain.ctrCommonDialog.ShowOpen
    strFileName = frmMain.ctrCommonDialog.FileTitle
    strFileDirectary = frmMain.ctrCommonDialog.FileName
    txtSendDir.Text = strFileDirectary
    
cancel:
End Sub

'************************************************
'保存
'打开标准对话框，选择保存文件的路径
'************************************************

Public Sub cmdFileSave_Click()
    On Error GoTo cancel
    Call optReceive_Click
    frmMain.ctrCommonDialog.ShowSave
    strFileDirectary = frmMain.ctrCommonDialog.FileName
    strFileName = frmMain.ctrCommonDialog.FileTitle
    
    txtReceiveDir.Text = strFileDirectary
    
cancel:
End Sub

'*************************************************
'配置串口
'响应菜单，打开参数设置窗体
'*************************************************

Private Sub ConfigPort_Click()
    frmConfig.Show
    
End Sub


'************************************************
'主窗体初始化
'加载主窗体，并对串口、标准对话框及进度条进行初始化设置
'************************************************

Private Sub Form_Load()
    
    cmdShow.Caption = "<<隐藏"                          '初始化主窗体模式
    blnShowFlag = True
    
    frmMain.Height = 6400
    
    Call SetComm("9600,N,8,1", 2, 4096)                 '串口设置
    intInBufferSize = 4096
    intOutBufferSize = 2048
    
    intCommFlag = 0                                     '初始系统状态
    
    frmMain.ctrCommonDialog.Flags = &H200000 Or &H2     '初始化标准对话框
    frmMain.ctrCommonDialog.CancelError = True
    
    blnFileTransFlag = False                            '初始发送接收标志
    
    prgFileTransfer.Max = 100                           '初始化进度条
    prgFileTransfer.Min = 0
    prgFileTransfer.Value = 0
    
    rtfReceive.Text = ""                                '信息显示初始化
    
    intArrayCount = 0

End Sub

'*************************************************
'设置串行口
'为参数设置提供公共接口
'*************************************************

Public Sub SetComm(strSet As String, intPort As Long, intOutBuffer As Long)
    strCommSettings = strSet
    intCommPort = intPort
    intOutBufferSize = intOutBuffer
    
End Sub

'*************************************************
'获取串行口设置
'返回串口设置（波特率等）
'*************************************************

Public Function GetSettings() As String
    GetSettings = strCommSettings
    
End Function

'**************************************************
'获取当前串口号
'
'**************************************************

Public Function GetCommPort() As Long
    GetCommPort = intCommPort
    
End Function


'**************************************************
'获取当前发送缓冲区大小
'
'**************************************************

Public Function GetOutBuffer() As Long
    GetOutBuffer = intOutBufferSize
    
End Function


'*************************************************
'打开串行口
'
'*************************************************

Public Sub CommPortOpen()
    
    On Error GoTo PortError
    
    ctrMSComm.CommPort = intCommPort                        '设置串行口号
    
    If ctrMSComm.PortOpen = True Then
        ctrMSComm.PortOpen = False
    End If
    ctrMSComm.Settings = strCommSettings                    '设置波特率.奇偶校验位.数据位和停止位
    ctrMSComm.InBufferSize = intInBufferSize                '设置接收缓冲区的字节长度
    
    ctrMSComm.InBufferCount = 0                             '清除接收缓冲区数据
    
    ctrMSComm.OutBufferSize = intOutBufferSize              '设置发送缓冲区字节长度
    ctrMSComm.OutBufferCount = 0                            '清除发送缓冲区数据
    ctrMSComm.RThreshold = 1                                '每次接收到字符即产生OnComm事件
    ctrMSComm.Handshaking = comRTSXOnXOff
    
    frmMain.ctrMSComm.InputLen = 100
    
    
        
    ctrMSComm.PortOpen = True

PortError:
    Select Case Err.Number
        Case 8005
            MsgBox ("该串口已经被占用,请换其它串口!")
    End Select

End Sub

'*************************************************
'关闭串行口
'
'*************************************************


Public Sub CommPortClose()
    
    Dim strTemp As String
    
    If ctrMSComm.PortOpen = True Then
        ctrMSComm.PortOpen = False
        strTemp = "设置:关闭串行口!"
        Call ReceiveDisplay(strTemp, 3)
    Else
        strTemp = "设置:串行口已关闭!"
        Call ReceiveDisplay(strTemp, 3)
        
    End If
    
    
End Sub

'**************************************************
'打开串口
'响应菜单，打开串行口并向用户显示相关信息
'**************************************************

Private Sub OpenPort_Click()

    Dim strTemp As String
    
    If frmMain.ctrMSComm.PortOpen = False Then
    
        Call CommPortOpen
        strTemp = "设置:打开串行口!"
        Call ReceiveDisplay(strTemp, 3)
        
        intCommFlag = 1
    Else
        strTemp = "设置:串行口已经打开!"
        Call ReceiveDisplay(strTemp, 3)
    End If
    
End Sub

'*************************************************
'MSComm事件处理
'响应MSComm事件作出相关处理
'*************************************************

Private Sub ctrMSComm_OnComm()

    
    Select Case frmMain.ctrMSComm.CommEvent
      
        Case comEvReceive
            
            If intCommFlag = 1 Then
                
                Call InputManager
                intCommFlag = 1
            End If
            
    End Select
    
End Sub

'*************************************************
'选择接收
'准备接收文件
'*************************************************

Private Sub optReceive_Click()
    optReceive.Value = True
    blnFileTransFlag = False
End Sub

'*************************************************
'选择发送
'准备发送文件
'*************************************************

Private Sub optSend_Click()
    optSend.Value = True
    blnFileTransFlag = True
End Sub


'************************************************
'响应按键
'实现利用回车键即可发送消息的功能
'************************************************

Private Sub txtSend_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
      Call frmMain.cmdSendText_Click
      
    End If
End Sub


'************************************************
'信息显示处理
'记录发送接收及串口设置信息，保存显示格式（颜色）
'************************************************

Public Sub ReceiveDisplay(strAdd As String, intColor As Long)
    
    intArrayCount = intArrayCount + 2               '收到新信息,信息记录计数增加
    
    ReDim Preserve intColorSet(intArrayCount)       '重定义纪录数组,保留原有数据
    
    intColorSet(intArrayCount - 1) = Len(rtfReceive.Text)   '添加新数据(格式位置)
    intColorSet(intArrayCount) = intColor                   '格式类型
    
    rtfReceive.Text = rtfReceive.Text + strAdd + Chr(13)    '加入新信息并设置换行
    
    For n = 1 To intArrayCount - 1 Step 2                   '显示
        rtfReceive.SelStart = intColorSet(n)
        If n < intArrayCount - 1 Then
            rtfReceive.SelLength = intColorSet(n + 2) - intColorSet(n)
        Else
            rtfReceive.SelLength = Len(rtfReceive.Text) - intColorSet(n)
        End If
        
        Select Case intColorSet(n + 1)
            Case 1
                rtfReceive.SelColor = RGB(0, 255, 0)
            Case 2
                rtfReceive.SelColor = RGB(255, 0, 0)
            Case 3
                rtfReceive.SelColor = RGB(0, 0, 255)
        End Select
        
   Next n
    
End Sub