📄 frm_connect.frm
字号:
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frm_connect
Caption = "Form1"
ClientHeight = 4275
ClientLeft = 60
ClientTop = 345
ClientWidth = 4635
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4275
ScaleWidth = 4635
StartUpPosition = 2 '屏幕中心
Begin VB.Timer Timer
Enabled = 0 'False
Interval = 2000
Left = 120
Top = 3960
End
Begin MSComDlg.CommonDialog dlgDialog
Left = 3840
Top = 3960
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin MSWinsockLib.Winsock winsck
Left = 4200
Top = 3960
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.CommandButton cmd_exit
Cancel = -1 'True
Caption = "E&xit"
Height = 300
Left = 2520
TabIndex = 3
Top = 3840
Width = 975
End
Begin VB.Frame Frame2
Caption = "Message"
Height = 615
Left = 20
TabIndex = 7
Top = 3120
Width = 4600
Begin VB.Label lbl_msg
Caption = "Ready..."
Height = 255
Left = 120
TabIndex = 10
Top = 240
Width = 4215
End
End
Begin VB.Frame Frame1
Caption = "TCP/IP"
Height = 1335
Left = 20
TabIndex = 6
Top = 1750
Width = 4600
Begin VB.TextBox txt_port
Enabled = 0 'False
Height = 270
Left = 1080
TabIndex = 1
Text = "3001"
Top = 600
Width = 2500
End
Begin VB.TextBox txt_ip
Enabled = 0 'False
Height = 270
Left = 1080
TabIndex = 0
Text = "192.168.0.218"
Top = 250
Width = 2500
End
Begin VB.CheckBox chk_edit
Caption = "编辑IP地址和端口号"
Height = 255
Left = 1080
TabIndex = 4
Top = 960
Width = 2055
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "端口号:"
Height = 180
Left = 240
TabIndex = 9
Top = 630
Width = 630
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "IP地址:"
Height = 180
Left = 240
TabIndex = 8
Top = 300
Width = 630
End
End
Begin VB.PictureBox Picture1
Height = 1575
Left = 20
ScaleHeight = 1515
ScaleWidth = 4545
TabIndex = 5
Top = 120
Width = 4600
End
Begin VB.CommandButton cmd_ok
Caption = "&Connect"
Default = -1 'True
Height = 300
Left = 960
TabIndex = 2
Top = 3840
Width = 975
End
End
Attribute VB_Name = "frm_connect"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public db As Database
Dim sql As String
Dim rs_ip As Recordset
Dim receive_data(257) As Byte
Dim recData(65535) As Byte
Dim total, paket As Long
Private Sub chk_edit_Click()
If chk_edit.Value = 1 Then
txt_ip.Enabled = True
txt_port.Enabled = True
Else
txt_ip.Enabled = False
txt_port.Enabled = False
End If
End Sub
Private Sub cmd_exit_Click()
Unload Me
End Sub
Private Sub cmd_ok_Click()
On Error GoTo saveerr
If txt_ip <> rs_ip!ip Then
BeginTrans
'改变ip/port
rs_ip.Edit
rs_ip.Fields(0) = txt_ip 'ip
rs_ip.Update
CommitTrans
End If
If txt_port <> rs_ip!Port Then
BeginTrans
'改变ip/port
rs_ip.Edit
rs_ip.Fields(1) = txt_port 'port
rs_ip.Update
CommitTrans
End If
On Error GoTo 0
winsck.Close
winsck.Connect txt_ip, txt_port
lbl_msg.Caption = "Version: 1.0 : " + Format(Now, "mmm dd yyyy Hh:Nn:Ss")
MousePointer = 11
cmd_ok.Enabled = False
chk_edit.Enabled = False
txt_ip.Enabled = False
txt_port.Enabled = False
Timer.Enabled = True
Exit Sub
saveerr:
Rollback
MsgBox Err.Description
End Sub
Private Sub Form_Load()
Dim mdb As String
total = 0
paket = 0
On Error GoTo errFind
Set db = OpenDatabase("tcp.mdb")
sql = "select tcp.* from tcp"
Set rs_ip = db.OpenRecordset(sql, dbOpenDynaset)
If rs_ip.RecordCount <> 0 Then
txt_ip = rs_ip!ip
txt_port = rs_ip!Port
End If
Exit Sub
' 如果数据库不能被找到，打开公用对话框控件让用户来查找它。
errFind:
If Err = 3024 Then
Set db = Nothing
mdb = "Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" & Findmdb
Set db = OpenDatabase("tcp.mdb")
Resume Next
ElseIf Err <> 0 Then ' 其他的错误
MsgBox "不期望的错误: " & Err.Description
End
End If
End Sub
Private Function Findmdb() As String
On Error GoTo ErrHandler
' 在 cam_360.mdb 不能找到的情况下，配置命令对话框。
With dlgDialog
.DialogTitle = "打开 tcp.mdb 数据库文件"
.Filter = "(*.MDB)|*.mdb"
End With
'如果用户点击“取消”按钮将导致错误。
dlgDialog.CancelError = True
dlgDialog.ShowOpen
Do While UCase(right(Trim(dlgDialog.FileName), 10)) <> "TCP.MDB"
MsgBox "文件名称与 tcp.mdb 不符。"
dlgDialog.ShowOpen
Loop
Findmdb = dlgDialog.FileName
Exit Function
ErrHandler:
If Err = 32755 Then
End
End If
End Function
Private Sub Timer_Timer1()
If winsck.State = 6 Then
If Left(lbl_msg.Caption, 3) = "Ver" Then
lbl_msg = "Conecting..."
ElseIf Left(lbl_msg.Caption, 4) = "Cone" Then
lbl_msg = "Begining Negotiation..."
ElseIf Left(lbl_msg.Caption, 3) = "Beg" Then
lbl_msg = "Connecting..."
End If
Else
MousePointer = 0
cmd_ok.Enabled = True
chk_edit.Enabled = True
chk_edit.Value = 1
txt_ip.Enabled = True
txt_port.Enabled = True
lbl_msg = "Authenticating"
MsgBox "与串口服务器连接失败.", vbOKOnly + vbCritical, "Disconnected"
MousePointer = 0
lbl_msg = "Successfull disconnected"
If Left(lbl_msg.Caption, 3) = "Suc" Then
lbl_msg = "Ready..."
Timer.Enabled = False
End If
End If
End Sub
Private Sub txt_ip_GotFocus()
txt_ip.SelStart = 0
txt_ip.SelLength = Len(txt_ip)
End Sub
Private Sub txt_port_GotFocus()
txt_port.SelStart = 0
txt_port.SelLength = Len(txt_port)
End Sub
Private Sub winsck_Close()
winsck.Close
End Sub
Private Sub winsck_Connect()
Timer.Enabled = False
frm_connect.Hide
frm_rs.Show , Me
End Sub
Private Sub winsck_DataArrival(ByVal bytesTotal As Long)
Static i, j As Integer
Dim t As Integer, str As String
Dim right As Boolean
frm_rs.timer_poll.Enabled = False
i = winsck.BytesReceived
total = total + i
paket = paket + 1
'frm_rs.Label3.Caption = total
frm_rs.lbl_rev = total
frm_rs.lbl_wuma = paket
winsck.GetData receive_data(0), vbByte, 1
'recData() = receive_data(0)
For t = 1 To i - 1
winsck.GetData receive_data(t), vbByte, 1 'jie shou shuju -> receive_data 数组
If receive_data(t) <> 0 Then
If receive_data(t) - receive_data(t - 1) = 1 Then 'Or (Int(receive_data(t)) = 0 And Int(receive_data(t - 1)) <> 255) Then
Else
frm_rs.Label2.Caption = CStr(CInt(frm_rs.Label2.Caption) + 1)
End If
If receive_data(t) = 255 Then frm_rs.txt_rec = ""
Else
If receive_data(t - 1) <> 255 Then
frm_rs.Label2.Caption = CStr(CInt(frm_rs.Label2.Caption) + 1)
Else
frm_rs.txt_rec = ""
End If
End If
Next
For j = 0 To i - 1
frm_rs.txt_rec = frm_rs.txt_rec + Hex(receive_data(j)) + " "
Next
frm_rs.timer_poll.Enabled = True
End Sub
Private Sub winsck1_DataArrival1(ByVal bytesTotal As Long)
Static i As Integer
Dim t As Integer, str As String
Dim right As Boolean
frm_rs.timer_poll.Enabled = False
If i < 257 Then
If winsck.BytesReceived < 256 Then '收到的数据小于13个，表明发出的数据有误，清空接收缓冲。
winsck.GetData receive_data(0), vbByte
i = 0
frm_rs.lbl_wuma.Caption = CStr(CInt(frm_rs.lbl_wuma.Caption) + 1)
Else '收到的数据大于/等于256个
i = 0
For t = 0 To winsck.BytesReceived
winsck.GetData receive_data(t), vbByte, 1 'jie shou shuju -> receive_data 数组
i = i + 1
If i >= 258 Then '剩余数据清除掉
winsck.GetData str, vbByte
Exit For
End If
Next
If i >= 256 Then
'接收数据完毕，回显数据
'''''''''''''''''回显
frm_rs.txt_rec = ""
right = True
For i = 0 To 255
frm_rs.txt_rec = frm_rs.txt_rec + Hex(receive_data(i)) + " "
right = right And (i = receive_data(i))
Next
frm_rs.txt_rec = frm_rs.txt_rec + vbCrLf
If right Then
frm_rs.lbl_rev.Caption = CStr(CInt(frm_rs.lbl_rev.Caption) + 1)
Else
frm_rs.lbl_wuma.Caption = CStr(CInt(frm_rs.lbl_wuma.Caption) + 1)
End If
''''''''''''''''
'数据分析
If frm_rs.timer_poll.Tag = "S" Then '是在发出数据后受到数据的才为正确
'timer3.tag=R 表示收到了数据
frm_rs.timer_poll.Tag = "R"
End If
End If
End If
Else
winsck.GetData receive_data(0), vbByte
i = 0
frm_rs.lbl_wuma.Caption = CStr(CInt(frm_rs.lbl_wuma.Caption) + 1)
End If
frm_rs.timer_poll.Enabled = True
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -