form1.frm

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

      Top             =   1560
      Width           =   2415
   End
   Begin VB.Label Label4 
      Caption         =   "转发延时（ms 0～65535）："
      Height          =   255
      Left            =   120
      TabIndex        =   9
      Top             =   840
      Width           =   2415
   End
   Begin VB.Label Label2 
      Caption         =   "远程端口（1～65535）："
      Height          =   255
      Left            =   4080
      TabIndex        =   2
      Top             =   120
      Width           =   2175
   End
   Begin VB.Label Label1 
      Caption         =   "远程主机IP："
      Height          =   255
      Left            =   120
      TabIndex        =   1
      Top             =   120
      Width           =   1215
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim cmd_data(0 To 19) As Byte
Dim io_data(0 To 19) As Byte

' --------
'  Public
' --------
'
' Property for file to read

Public File As String
'
' API to read/write ini's
#If Win32 Then
   Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
   Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal Appname As String, ByVal KeyName As Any, ByVal NewString As Any, ByVal Filename As String) As Integer
#Else
   Private Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
  Private Declare Function WritePrivateProfileString Lib "Kernel" (ByVal Appname As String, ByVal KeyName As Any, ByVal NewString As Any, ByVal Filename As String) As Integer
#End If

Public Function DeleteSectionFile(ByVal Section As String)

   Dim retval As Integer
   retval = WritePrivateProfileString(Section, 0&, "", File)

End Function
Public Function SaveSettingFile(ByVal Section$, ByVal Key$, ByVal Value$)

Dim retval As Integer
   SaveSettingFile = WritePrivateProfileString(Section$, Key$, Value$, File)
End Function

Public Function GetSettingFile(ByVal Section As String, ByVal KeyName As String) As String

Dim retval As Integer
Dim t As String * 255

   ' Get the value
   retval = GetPrivateProfileString(Section, KeyName, "unknown value", t, Len(t), File)

   ' If there is one, return it
   If retval > 0 Then
      GetSettingFile = Left$(t, retval)
   Else
      GetSettingFile = "Unknown section or key"
   End If

End Function

Public Function GetSectionFile(ByVal Section As String, KeyArray() As String) As Integer

Dim retval As Integer
' Allocate space for return value
Dim t As String * 2500
Dim lastpointer As Integer
Dim nullpointer As Integer
Dim ArrayCount As Integer
Dim keystring As String
   
   ReDim KeyArray(0)
   
   ' Get the value
   retval = GetPrivateProfileString(Section, 0&, "", t, Len(t), File)
   
   ' If there is one, return it
   If retval > 0 Then
      '
      ' Separate the keys and store them in the array
      nullpointer = InStr(t, Chr$(0))
      lastpointer = 1
      Do While (nullpointer <> 0 And nullpointer > lastpointer + 1)
         '
         ' Extract key string
         keystring = Mid$(t, lastpointer, nullpointer - lastpointer)
         '
         ' Now add to array
         ArrayCount = ArrayCount + 1
         ReDim Preserve KeyArray(ArrayCount)
         KeyArray(ArrayCount) = keystring
         '
         ' Find next null
         lastpointer = nullpointer + 1
         nullpointer = InStr(nullpointer + 1, t, Chr$(0))
      Loop
   End If
   '
   ' Return the number of array elements
   GetSectionFile = ArrayCount
   
End Function


Private Sub Check_CTS_Click()
    VSPort_com1.SetCTS Check_CTS.Value
End Sub

Private Sub Check_DCD_Click()
    VSPort_com1.SetDCD Check_DCD.Value
End Sub

Private Sub Check_DSR_Click()
    VSPort_com1.SetDSR Check_DSR.Value
End Sub

Private Sub Check_DTR_Click()
    Command_set_io_Click
End Sub

Private Sub Check_RING_Click()
    VSPort_com1.SetRING Check_RING.Value
End Sub

Private Sub Check_RTS_Click()
   Command_set_io_Click
End Sub

Private Sub Command_close_Click()
   Winsock_cmd.Close
   Winsock_data.Close
   VSPort_com1.Delete
   
   Check_setio.Value = 0
   Check_setcom.Value = 0
   
   Check_CTS.Value = 0
   Check_DSR.Value = 0
   Check_DCD.Value = 0
   
   Check_RTS.Value = 1
   Check_DTR.Value = 1
   
   Combo_mode.Enabled = True
   Timer_check.Enabled = False
   
   Command_link.Enabled = True
   Command_close.Enabled = False
   
End Sub

Private Sub Command_exit_Click()
   Winsock_cmd.Close
   Winsock_data.Close
   VSPort_com1.Delete
   Unload Me
End Sub

Private Sub Command_hide_Click()

'If Me.WindowState = 1 Then '如程序为最小化则——
cSysTray1.InTray = True '隐藏到任务栏
Me.Visible = False '让程序界面不可见
'End If

End Sub

Private Sub Command_link_Click()

    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
    
    If Combo_mode.ListIndex = 2 Then
    Winsock_data.Protocol = sckUDPProtocol
    Winsock_data.Bind 'Val(Trim(Text_local_port.Text))
    End If
    
    Combo_mode.Enabled = False
    Timer_check.Enabled = True
    
    Call Command_vcom_Click
    Call Command_open_Click
    Call Command_save_ini_Click
    
    Command_link.Enabled = False
    Command_close.Enabled = True

End Sub

Private Sub Command_load_ini_Click()

If GetSettingFile("MAINSETING", "RPORT") Like "unknown value" Then
    Combo_mode.ListIndex = 1
    Call Command_save_ini_Click
    Exit Sub
End If

Text_server_add.Text = GetSettingFile("MAINSETING", "IP")
Text_server_port.Text = GetSettingFile("MAINSETING", "RPORT")
Text_local_port.Text = GetSettingFile("MAINSETING", "LPORT")
Text_com_delay.Text = GetSettingFile("MAINSETING", "DELAY")
Text_com_len.Text = GetSettingFile("MAINSETING", "MAXLEN")
Text_server_vname.Text = GetSettingFile("MAINSETING", "COMNAME")

Combo_mode.ListIndex = Val(GetSettingFile("MAINSETING", "MODE"))
'Check_setcom.Value = Val(GetSettingFile("MAINSETING", "SETCOM"))
'Check_setio.Value = Val(GetSettingFile("MAINSETING", "SETIO"))
Check_log.Value = Val(GetSettingFile("MAINSETING", "DISPPLAYLOG"))
Check_autorun.Value = Val(GetSettingFile("MAINSETING", "AUTORUN"))

End Sub

Private Sub Command_open_Click()

    Winsock_cmd.Close
    Winsock_cmd.Protocol = sckUDPProtocol
    Winsock_cmd.RemoteHost = Trim(Text_server_add.Text)
    Winsock_cmd.RemotePort = 4095
    Winsock_cmd.Bind Val(Trim(Text_local_port.Text))
    
End Sub

Private Sub Command_save_ini_Click()

valtemp = SaveSettingFile("MAINSETING", "IP", Trim(Text_server_add.Text))
valtemp = SaveSettingFile("MAINSETING", "RPORT", Trim(Text_server_port.Text))
valtemp = SaveSettingFile("MAINSETING", "LPORT", Trim(Text_local_port.Text))

valtemp = SaveSettingFile("MAINSETING", "DELAY", Trim(Text_com_delay.Text))
valtemp = SaveSettingFile("MAINSETING", "MAXLEN", Trim(Text_com_len.Text))
valtemp = SaveSettingFile("MAINSETING", "COMNAME", Trim(Text_server_vname.Text))
valtemp = SaveSettingFile("MAINSETING", "MODE", Combo_mode.ListIndex)

'valtemp = SaveSettingFile("MAINSETING", "SETCOM", Check_setcom.Value)
'valtemp = SaveSettingFile("MAINSETING", "SETIO", Check_setio.Value)
valtemp = SaveSettingFile("MAINSETING", "DISPPLAYLOG", Check_log.Value)
valtemp = SaveSettingFile("MAINSETING", "AUTORUN", Check_autorun.Value)

End Sub

Private Sub Command_set_io_Click()
     Dim i As Integer
            For i = 0 To 19
                io_data(i) = &H0
            Next

            '串口序号
            io_data(0) = &H0
            '数据
            If Check_DTR.Value = 0 Then
            
            io_data(1) = &H20
            
            End If
            
            If Check_RTS.Value = 0 Then
            
            io_data(1) = io_data(1) + &H4
            
            End If
            
            io_data(19) = &H55
            
            Winsock_cmd.SendData io_data
            Winsock_cmd.RemoteHost = Trim(Text_server_add.Text)
            
            Check_setio.Value = 0

End Sub

Private Sub Command_setcom_Click()
     Dim i As Integer
            'For i = 0 To 19
            '    cmd_data(i) = &H0
            'Next

            '串口序号
            cmd_data(0) = &H0
            '数据位
            'cmd_data(1) = &H1
            '停止位
            'cmd_data(2) = &H1
            '校验模式
            'cmd_data(3) = &H1
            '端口流控
            'cmd_data(4) = &H0
            
            '间隔时间H
            'cmd_data(5) = &H0
            '间隔时间L
            'cmd_data(6) = &HC8
            
            cmd_data(5) = (Val(Trim(Text_com_delay.Text)) And &HFF00&) / &H100&
            cmd_data(6) = Val(Trim(Text_com_delay.Text)) And &HFF
            
            '最大长度H
            'cmd_data(7) = &H0
            '最大长度L
            'cmd_data(8) = &HFF
            
            cmd_data(7) = (Val(Trim(Text_com_len.Text)) And &HFF00&) / &H100&
            cmd_data(8) = Val(Trim(Text_com_len.Text)) And &HFF

            '波特率0
            'cmd_data(9) = &H0
            '波特率1
            'cmd_data(10) = &H0
            '波特率2
            'cmd_data(11) = &H4B
            '波特率3
            'cmd_data(12) = &H0
            
            '命令字
            cmd_data(19) = &H50
            
            Winsock_cmd.SendData cmd_data
            'Winsock_cmd.RemoteHost = Trim(Text_server_add.Text)
            Check_setcom.Value = 0

End Sub

Private Sub Command_vcom_Click()
  If VSPort_com1.CreatePort(Trim(Text_server_vname.Text)) = True Then
     Label_state.Caption = Trim(Text_server_vname.Text) & "虚拟串口建立成功!" & vbCrLf & Label_state.Caption
     Else
     Label_state.Caption = Trim(Text_server_vname.Text) & "虚拟串口建立失败!请关闭需要打开串口的所有程序后，重试一次。" & vbCrLf & Label_state.Caption
  End If
End Sub