Option Explicit
Dim viewData As Double 'переменная хранящая данные (температуру)
Dim connectionState As Boolean ' переменная, отвечающая за состояние подключения
Public Function WinToUTF8(ByRef inString As String, ByVal lMaxSize As Long) As String
Dim hMemLock1 As Long, hMemLock2 As Long
Dim iStrSize As Long
hMemLock1 = LocalAlloc(LMEM_ZEROINIT, lMaxSize)
hMemLock2 = LocalAlloc(LMEM_ZEROINIT, lMaxSize)
iStrSize = MultiByteToWideChar(0&, 0&, inString, &HFFFF, hMemLock1, lMaxSize)
iStrSize = WideCharToMultiByte(65001, 0&, hMemLock1, iStrSize, hMemLock2, lMaxSize, 0&, 0&) ' CP_UTF8
If Len(iStrSize) Then
WinToUTF8 = String$(iStrSize, 0&)
Call CopyMemory(ByVal WinToUTF8, ByVal hMemLock2, iStrSize)
End If
Call LocalFree(hMemLock1)
Call LocalFree(hMemLock2)
End Function
Public Function WinToUTF8TXT(Txt As Variant) As String
If Txt & "" = "" Then Exit Function
Dim i As Long, s As String, Tmp As String
Tmp = Txt
i = (Len(Tmp) + 1) * 2
s = WinToUTF8(Tmp, i)
s = Left(s, Len(Tmp) * 2)
WinToUTF8TXT = s
End Function
Private Sub LabelPref()
'Набор настроек элементов управления
lbData.Caption = CStr(viewData) + "°C"
lbData.ForeColor = vbGreen
lbData.Font = "Times New Roman"
lbData.FontSize = 100
lbData.Alignment = 2
frTP.Caption = "Температура процесса"
frTP.FontSize = 12
frCS.Caption = "Состояние подключения"
frCS.FontSize = 12
Shape1.BackStyle = 1
Shape2.BackStyle = 1
Shape1.BackColor = vbRed
Shape2.BackColor = vbRed
lbChat.Font = "Times New Roman"
lbChat.FontSize = 24
lbChat.Caption = " Чат"
lbChat.ForeColor = vbYellow
lbCData.Font = "Times New Roman"
lbCData.FontSize = 24
lbCData.Caption = " Данные"
lbCData.ForeColor = vbYellow
txtOutput.Text = ""
txtSendData.Text = ""
cmdSendData.Caption = "Отправить"
txtOutput.Locked = True
End Sub
Private Sub cmdSendData_Click()
Dim b As String
'Преобразовываем строку в кодировку UTF-8
b = WinToUTF8TXT(txtSendData.Text & vbCrLf)
'Отправляем сообщение
Winsock1.SendData b
'Записываем в лог чата
txtOutput.Text = txtOutput.Text & vbNewLine & "Сервер: " & txtSendData.Text
'Стираем текст
txtSendData.Text = ""
txtSendData.SetFocus
End Sub
Private Sub Form_Load()
viewData = 10
LabelPref
connectionState = False
'Устанавливаем порт для прослушивания
Winsock1.LocalPort = 6574
Winsock2.LocalPort = 6575
'Начинаем прослушивать
Winsock1.Listen
Winsock2.Listen
Timer1.Interval = 1000
End Sub
Private Sub txtSendData_KeyPress(KeyAscii As Integer)
'Если нажат Enter - отправляем данные
If KeyAscii = 13 Then cmdSendData_Click
End Sub
Private Sub Winsock1_Close()
'Закрываем соединение, если оно еще не закрыто
If Winsock1.State <> sckClosed Then Winsock1.Close
'Начинаем прослушивать еще раз
Winsock1.Listen
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
'Останавливаем прослушивание
'(Обязательно!)
Winsock1.Close
'Подключаем клиента
Winsock1.Accept requestID
'Очищаем лог разговора
txtOutput.Text = "ЕСТЬ ПОДКЛЮЮЧЕНИЕ!!!"
Shape1.BackColor = vbGreen
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim s As String
'Принимаем все данные
Winsock1.GetData s, vbString
'Записываем данные в лог разговора
txtOutput.Text = txtOutput.Text & vbNewLine & "Клиент: " & s
'Перемещаем курсор в конец лога
txtOutput.SelStart = txtOutput.SelLength
End Sub
Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox Description, vbCritical
Winsock1_Close
End Sub
Private Sub Winsock2_ConnectionRequest(ByVal requestID As Long)
'Останавливаем прослушивание
'(Обязательно!)
Winsock2.Close
'Подключаем клиента
Winsock2.Accept requestID
connectionState = True
'Очищаем лог разговора
txtOutput.Text = txtOutput.Text & vbNewLine & "ЕСТЬ ПОДКЛЮЮЧЕНИЕ ДАННЫХ!!!"
Shape2.BackColor = vbGreen
End Sub
Private Sub Winsock2_Close()
'Закрываем соединение, если оно еще не закрыто
If Winsock2.State <> sckClosed Then Winsock2.Close
'Начинаем прослушивать еще раз
Winsock2.Listen
End Sub
Private Sub Winsock2_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox Description, vbCritical
Winsock2_Close
End Sub
Private Sub cmdSendData2_Click()
viewData = viewData - 1
End Sub
Private Sub cmdSendData3_Click()
viewData = viewData + 1
End Sub
Private Sub DataResultMax()
viewData = viewData + 0.3
If viewData < 15 And viewData > 5 Then
lbData.ForeColor = vbGreen
lbData.Caption = CStr(viewData) + "°C"
End If
If viewData < 16.5 And viewData > 15 Then
lbData.ForeColor = vbYellow
lbData.Caption = CStr(viewData) + "°C"
End If
If viewData > 16.5 Then
lbData.ForeColor = vbRed
lbData.Caption = CStr(viewData) + "°C"
End If
End Sub
Private Sub Timer1_Timer()
DataResultMax
If connectionState = True Then
Winsock2.SendData CStr(viewData & vbCrLf)
End If
End Sub
Private Sub Winsock2_DataArrival(ByVal bytesTotal As Long)
'Dim s As String
Dim i As Integer
'Принимаем все данные
Winsock2.GetData i, vbInteger
'i = CInt(s)
If i = 1 Then
viewData = viewData - 1
End If
If i = 2 Then
viewData = viewData + 1
End If
'Записываем данные в лог разговора
txtOutput.Text = txtOutput.Text & vbNewLine & "Клиент: " & i
'Перемещаем курсор в конец лога
txtOutput.SelStart = txtOutput.SelLength
End Sub