form1.frm

这是我们当时计算机接口与通信课程的时候编的两个程序之一

    
    
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 + vbCrLf     '加入新信息并设置换行
    
    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

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

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 cmdFileSend_Click()
    On Error GoTo FileError
    
    If blnFileTransFlag = True And intCommFlag = 1 Then
        
        intCommFlag = 8
            Call FileSendManager(0)
        intCommFlag = 1
    End If
    
FileError:                           '错误处理
    
    'MsgBox (Str(Err.Number) & ":" & Err.Description)
    '这一行是笔者保留下来给读者测试用
    Select Case Err.Number
        Case 53
            MsgBox ("文件没有找到!")
    End Select
    If intCommFlag > 0 Then
        intCommFlag = 1
    Else
        MsgBox ("串口没有打开!")
    End If
    
End Sub

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

Private Sub cmdOpenPort_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

'************************************************
'关闭串口
'响应菜单功能
'************************************************

Private Sub cmdClosePort_Click()
    
    Call CommPortClose
    intCommFlag = 0
    Timer1.Enabled = False
    cmdReceiveText.Caption = "自动发送"
   
End Sub


Private Sub cmdReceiveText_Click()
    If ctrMSComm.PortOpen = True Then
        Timer1.Enabled = Not Timer1.Enabled
        If Timer1.Enabled = True Then
            cmdReceiveText.Caption = "停止自动发送"
        Else
            cmdReceiveText.Caption = "自动发送"
        End If
    Else
       MsgBox ("先打开串行口!")
    End If
End Sub

Private Sub cmdSendText_Click()
    Dim bytFlag(5) As Byte                          '组织帧头
    bytFlag(0) = 1
    bytFlag(1) = 0
    bytFlag(4) = 0
    bytFlag(5) = 0
    
    Dim strTemp As String
    
    Dim intSelLen As Integer
    If frmMain.ctrMSComm.PortOpen = True Then
    
        strTemp = "发送:" + txtSend.Text
        Call ReceiveDisplay(strTemp, 1)
        
        Do
        Loop While intCommFlag > 1
        intCommFlag = 4
        
        strSend = txtSend.Text                      '用于发送的文本信息
        intlenth = Len(strSend)
        bytFlag(2) = intlenth \ 100
        bytFlag(3) = intlenth - bytFlag(2) * 100
        frmMain.ctrMSComm.Output = bytFlag
        frmMain.ctrMSComm.Output = strSend
        txtSend.Text = ""
        
        intCommFlag = 1
        
    Else
        MsgBox ("先打开串行口!")
    End If
    

End Sub

Private Sub cmdSetPort_Click()
    If ctrMSComm.PortOpen = False Then
        frmConfig.Show
    Else
        MsgBox ("先关闭串行口!")
    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 Form_Load()
txtIp.Text = ctrWinsock.LocalIP
    Call SetComm("9600,N,8,1", 2, 4096)                '串口设置
    intInBufferSize = 4096
    
    intCommFlag = 0                                     '初始系统状态
    Timer1.Interval = 1000
    Timer1.Enabled = False
    
    frmMain.ctrCommonDialog.Flags = &H200000 Or &H2     '初始化标准对话框
    frmMain.ctrCommonDialog.CancelError = True
    
    blnFileTransFlag = False
    rtfReceive.Text = ""
    intArrayCount = 0
    

End Sub

Private Sub Timer1_Timer()
   Dim bytFlag(5) As Byte                          '组织帧头
    bytFlag(0) = 1
    bytFlag(1) = 0
    bytFlag(4) = 0
    bytFlag(5) = 0
    
    Dim strTemp As String
    
    Dim intSelLen As Integer
    Dim strSend As String
    strSend = "021104123 赵翰铭"
    If frmMain.ctrMSComm.PortOpen = True Then
    
        strTemp = "发送:" + strSend
        Call ReceiveDisplay(strTemp, 1)
        
        Do
        Loop While intCommFlag > 1
        intCommFlag = 4
        
                                                  '用于发送的文本信息
        intlenth = Len(strSend)
        bytFlag(2) = intlenth \ 100
        bytFlag(3) = intlenth - bytFlag(2) * 100
        frmMain.ctrMSComm.Output = bytFlag
        frmMain.ctrMSComm.Output = strSend
        'txtSend.Text = ""
        
        intCommFlag = 1
        
    Else
        MsgBox ("先打开串行口!")
    End If
    
End Sub