form1.frm

可以生成最多255个虚拟串口

Private Sub cSysTray1_MouseDown(Button As Integer, Id As Long)
Me.WindowState = 0 '程序回复到Normal状态
Me.Visible = True '令程序界面可见
cSysTray1.InTray = False  '从任务栏中清除图标
End Sub

Private Sub Form_Load()

     File = App.Path & "\COM.INI"
     VSPort_com1.ResetBus
     
     Call Command_load_ini_Click
     
     Command_close.Enabled = False
     
     If Check_autorun.Value Then
     
           Command_link_Click
           Command_hide_Click
     
     End If
     
End Sub


Private Sub Label_state_DblClick()
            Label_state.Caption = ""
End Sub

Private Sub Timer_check_Timer()
            Timer_check.Enabled = False
            Timer_check.Interval = 50
            If Check_setio.Value = False Then
                 Call Command_set_io_Click
            End If
            If Check_setcom.Value = False Then
                 Call Command_setcom_Click
            End If
            
            If Winsock_data.State <> 7 And Combo_mode.ListIndex < 2 Then
                       Winsock_data.Close
                       Winsock_data.RemoteHost = Trim(Text_server_add.Text)
                       Winsock_data.RemotePort = Trim(Text_server_port.Text)
    
                       If Combo_mode.ListIndex = 0 Then
                           Winsock_data.Protocol = sckTCPProtocol
                           Winsock_data.LocalPort = Trim(Text_server_port.Text)
                           Winsock_data.Listen
                       End If
    
                       If Combo_mode.ListIndex = 1 Then
                           Winsock_data.Protocol = sckTCPProtocol
                           Winsock_data.Connect
                       End If
                       Timer_check.Interval = 3000
            End If
            
            Timer_check.Enabled = True
End Sub

Private Sub VSPort_com1_OnDTR(ByVal OnDTR As Boolean)
       If OnDTR = True Then
          'Label_state.Caption = Label_state.Caption & "OnDTR = ON" & vbCrLf
          Check_DTR.Value = 1
          Else
          'Label_state.Caption = Label_state.Caption & "OnDTR = OFF" & vbCrLf
          Check_DTR.Value = 0
       End If
       Command_set_io_Click
End Sub

Private Sub VSPort_com1_OnHandflow(ByVal ControlHandShake As Long, ByVal FlowReplace As Long, ByVal XOnLimit As Long, ByVal XOffLimit As Long)
       
       cmd_data(4) = 0

End Sub

Private Sub VSPort_com1_OnLineControl(ByVal StopBits As Long, ByVal Parity As Long, ByVal WordLength As Long)

       cmd_data(1) = 9 - (WordLength And &HFF)
       cmd_data(2) = (StopBits And &HFF) + 1
       cmd_data(3) = (Parity And &HFF) + 1
       
       Call Command_setcom_Click

End Sub

Private Sub VSPort_com1_OnRING()
        Label_state.Caption = Label_state.Caption & "OnRING" & vbCrLf
End Sub

Private Sub VSPort_com1_OnRTS(ByVal OnRTS As Boolean)
       If OnRTS = True Then
          'Label_state.Caption = Label_state.Caption & "OnRTS = ON" & vbCrLf
          Check_RTS.Value = 1
          Else
          'Label_state.Caption = Label_state.Caption & "OnRTS = OFF" & vbCrLf
          Check_RTS.Value = 0
       End If
       
       Command_set_io_Click
End Sub

Private Sub VSPort_com1_OnRxChar(ByVal Count As Long)
    Dim COMBuffer() As Byte
    Dim Received As Long
    Dim j As Integer
    Dim strtp As String
        
    Received = VSPort_com1.GetInCount
    If Received > 0 Then
              '//   调整数组长度
              ReDim COMBuffer(Received - 1)
              Received = VSPort_com1.Read(COMBuffer(0), Received)
              
              '发送数据到网络
              
              If Combo_mode.ListIndex < 2 And Winsock_data.State = 7 Then
                    Winsock_data.SendData COMBuffer
              End If
              
              If Combo_mode.ListIndex = 2 And Winsock_data.RemoteHostIP <> "" Then
                    Winsock_data.SendData COMBuffer
                    Winsock_data.RemoteHost = Trim(Text_server_add.Text)
              End If
              
      If Check_log.Value Then
    
          maxlen = UBound(COMBuffer)
    
          If UBound(COMBuffer) > 19 Then
                maxlen = 19
          End If
          'MsgBox Received & "|" & UBound(COMBuffer)
          For j = 0 To maxlen
    
              strre = Hex(COMBuffer(j))
                    
              If Len(strre) = 1 Then
                   strtp = strtp & "0" & Hex(COMBuffer(j)) & " "
              Else
                   strtp = strtp & Hex(COMBuffer(j)) & " "
              End If
    
          Next
    
          Label_state.Caption = strtp & vbCrLf & Label_state.Caption
          Label_state.Caption = "接收到串口" & Received & "个数据" & vbCrLf & Label_state.Caption
      End If
      
      If LenB(Label_state.Caption) > 1024 Then
              Label_state.Caption = Left(Label_state.Caption, 100)
      End If
              
   End If
        
End Sub

Private Sub VSPort_com1_OnBaudRate(ByVal BaudRate As Long)
       
       Label_state.Caption = Label_state.Caption & "OnBaudRate = " & BaudRate & vbCrLf
       
       Label_com_rate.Caption = "baudrate : " & CStr(BaudRate)
       
       'long zhuan byte
       cmd_data(9) = (BaudRate And &HFF000000) / &H1000000
       cmd_data(10) = (BaudRate And &HFF0000) / &H10000
       cmd_data(11) = (BaudRate And &HFF00&) / &H100&
       cmd_data(12) = BaudRate And &HFF
       
       Call Command_setcom_Click
       
End Sub

Private Sub VSPort_com1_OnOpenClose(ByVal Opened As Boolean)
         If Opened = True Then
            Label_state.Caption = "串口打开" & vbCrLf & Label_state.Caption
            Label_com_state.Caption = "Open"
            
         Call Command_setcom_Click
          
          Else
            Label_state.Caption = "串口关闭" & vbCrLf & Label_state.Caption
            Label_com_state.Caption = "Close"
            
         End If
End Sub


Private Sub Winsock_cmd_DataArrival(ByVal bytesTotal As Long)

Dim strdata() As Byte
Dim i As Integer
Dim strre As String
Dim strtp As String
    
    i = Winsock_cmd.BytesReceived
    
    If i <> 20 Then
            ReDim strdata(i) As Byte
            Winsock_cmd.GetData strdata, vbByte, i
            Exit Sub
    End If

    ReDim strdata(i - 1) As Byte
    
    Winsock_cmd.GetData strdata, vbByte, i
 
    For i = 0 To UBound(strdata)
    
         strre = Hex(strdata(i))
                    
          If Len(strre) = 1 Then
             strtp = strtp & "0" & Hex(strdata(i)) & " "
          Else
             strtp = strtp & Hex(strdata(i)) & " "
          End If
    
    Next
    
    Label_state.Caption = strtp & vbCrLf & Label_state.Caption
   
    
    If strdata(19) = &H50 Then
    
          For i = 0 To 19
    
            If strdata(i) <> cmd_data(i) Then
                Exit For
            End If
          Next
                  
          If i = 20 Then
              Label_state.Caption = "串口参数更新成功！" & vbCrLf & Label_state.Caption
              Check_setcom.Value = 1
          End If
    End If

    If strdata(19) = &H51 Then
              Label_state.Caption = "接收到串口参数查询结果！" & vbCrLf & Label_state.Caption
    End If

    If strdata(19) = &H55 Then
          If (strdata(1) And &H4 And Check_RTS.Value) Or (Not (strdata(1) And &H4) And Not Check_RTS.Value) Then
               If (strdata(1) And &H20 And Check_DSR.Value) Or (Not (strdata(1) And &H20) And Not Check_DSR.Value) Then
                    Label_state.Caption = "串口 RTS 和  DTR设置成功！" & vbCrLf & Label_state.Caption
                    Check_setio.Value = 1
               End If
        End If
    End If

    If strdata(19) = &H56 Then
    
              Winsock_cmd.SendData strdata
              
              Label_state.Caption = "接收到网络 CTS 、DSR、DCD、RING 状态数据！" & vbCrLf & Label_state.Caption
                                          
              If strdata(1) And &H8 Then
                     VSPort_com1.SetCTS 0
                     Check_CTS.Value = 0
              Else
                     VSPort_com1.SetCTS 1
                     Check_CTS.Value = 1
              End If
              
              If strdata(1) And &H10 Then
                     VSPort_com1.SetDSR 0
                     Check_DSR.Value = 0
              Else
                     VSPort_com1.SetDSR 1
                     Check_DSR.Value = 1
              End If
              
              If strdata(1) And &H40 Then
                     VSPort_com1.SetDCD 0
                     Check_DCD.Value = 0
              Else
                     VSPort_com1.SetDCD 1
                     Check_DCD.Value = 1
              End If
              
              If strdata(1) And &H80 Then
                     VSPort_com1.SetRING 0
                     Check_RING.Value = 0
              Else
                     VSPort_com1.SetRING 1
                     Check_RING.Value = 1
              End If
              
    End If
    
    If LenB(Label_state.Caption) > 1024 Then
           Label_state.Caption = Left(Label_state.Caption, 100)
    End If

End Sub

Private Sub Winsock_data_Close()
            Text_remote_ip.Caption = ""
End Sub

Private Sub Winsock_data_Connect()
            Text_remote_ip.Caption = Winsock_data.RemoteHostIP
End Sub

Private Sub Winsock_data_ConnectionRequest(ByVal requestID As Long)

 If Combo_mode.ListIndex = 0 Then
    Winsock_data.Close
    Winsock_data.Accept requestID
 End If

End Sub

Private Sub Winsock_data_DataArrival(ByVal bytesTotal As Long)

Dim strdata() As Byte
Dim i, j, maxlen As Integer
Dim strtp As String

    Text_remote_ip.Caption = Winsock_data.RemoteHostIP
    i = Winsock_data.BytesReceived
    
    ReDim strdata(i - 1) As Byte
    
    Winsock_data.GetData strdata, vbByte, i
    
    
    If Check_log.Value Then
    
          maxlen = UBound(strdata)
    
          If UBound(strdata) > 19 Then
                maxlen = 19
          End If
          'MsgBox i & "|" & UBound(strdata)
          For j = 0 To maxlen
    
              strre = Hex(strdata(j))
                    
              If Len(strre) = 1 Then
                   strtp = strtp & "0" & Hex(strdata(j)) & " "
              Else
                   strtp = strtp & Hex(strdata(j)) & " "
              End If
    
          Next
    
          Label_state.Caption = strtp & vbCrLf & Label_state.Caption
          Label_state.Caption = "接收到网络" & i & "个数据" & vbCrLf & Label_state.Caption
    End If
    
    If VSPort_com1.IsOpened Then
        VSPort_com1.Write strdata(0), i
    End If
    
    If LenB(Label_state.Caption) > 1024 Then
              Label_state.Caption = Left(Label_state.Caption, 100)
    End If
End Sub