|
The code:
Private Declare Sub Sleep Lib "kernel32" (ByVal _
dwMilliSeconds As Long)
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 Long, ByVal lpFileName As String) As Long
Dim strRecData As String
Dim autostart As Boolean
Dim LedStatus As Boolean
Dim File As String
Dim Anzeigetext1 As String
Dim Anzeigetext2 As String
Dim Anzeigetext3 As String
Dim Anzeigetext4 As String
Dim Anzeigetext5 As String
Dim Anzeigetext6 As String
Dim Anzeigetext7 As String
Dim dataprocessed As Boolean
Dim dummy As String
Private Sub cbConnect_Click()
If (tbRemotePort.Text <> "") And (tbRemoteIP.Text <> "") Then
Winsock1.RemotePort = tbRemotePort.Text
Winsock1.RemoteHost = tbRemoteIP.Text
Winsock1.Connect
End If
End Sub
Private Sub cbDisconnect_Click()
live.Enabled = False
Winsock1.Close
Winsock1.LocalPort = 0
cbConnect.Enabled = True
cbConnect.SetFocus
Command1.Enabled = False
Shape1.FillColor = &HFF&
End Sub
Private Sub cbSendData_Click()
Winsock1.SendData (tbSendData.Text)
tbSendData.Text = ""
End Sub
Private Sub Command1_Click()
If autostart = False Then
autostart = True
Shape1.FillColor = &HFF00&
Timer2.Enabled = True
tbSendData.Enabled = False
Label6.Caption = "running"
Timer3.Enabled = True
live.Enabled = False ' Livetimer um die verbindung zu halten.
Else
Shape1.FillColor = &HFF&
autostart = False
Timer2.Enabled = False
tbSendData.Enabled = True
cbSendData.Enabled = False
Label6.Caption = "stopped"
Timer3.Enabled = False
live.Enabled = True
End If
End Sub
Private Sub Command2_Click()
Winsock1.SendData ("S2")
End Sub
Private Sub Command3_Click()
Winsock1.SendData ("S3")
End Sub
Private Sub Command4_Click()
Winsock1.SendData ("S4")
End Sub
Private Sub Command5_Click()
Winsock1.SendData ("S5")
End Sub
Private Sub Command6_Click()
Winsock1.SendData ("S6")
End Sub
Private Sub Command7_Click()
Winsock1.SendData ("S7")
End Sub
Private Sub Command8_Click()
Winsock1.SendData ("S1")
End Sub
Private Sub Command9_Click()
Dim strtime As String
Dim strt As String
strt = Mid$(MaskEdBox1.Text, 1, 2)
strt = strt & Mid$(MaskEdBox1.Text, 4, 2)
strt = strt & Mid$(MaskEdBox1.Text, 7, 2)
strtime = "ST" & strt
Text1.Text = strt
Winsock1.SendData (strtime)
End Sub
Private Sub Form_Load()
Dim i As Integer
For i = 0 To 6
Label11(i).Caption = ""
Next i
'Pfad der neuen ini-Datei
File = App.Path & "\NetTemp.ini"
Anzeigetext1 = INIGetValue(File, "IOTexte", "Bit1")
Anzeigetext2 = INIGetValue(File, "IOTexte", "Bit2")
Anzeigetext3 = INIGetValue(File, "IOTexte", "Bit3")
Anzeigetext4 = INIGetValue(File, "IOTexte", "Bit4")
Anzeigetext5 = INIGetValue(File, "IOTexte", "Bit5")
Anzeigetext6 = INIGetValue(File, "IOTexte", "Bit6")
Anzeigetext7 = INIGetValue(File, "IOTexte", "Bit7")
autostart = False
Label6.Caption = "stopped"
tbSendData.Enabled = False
LedStatus = False
MaskEdBox1.Text = "00:00:00"
Timer3.Enabled = False
Label7.Caption = ""
Label8.Caption = ""
live.Enabled = True ' live timer einschalten.
End Sub
Private Function INIGetValue(ByVal Path$, ByVal Sect$, ByVal Key$) _
As String
Dim Result&, Buffer$
'Wert lesen
Buffer = Space$(32)
Result = GetPrivateProfileString(Sect, Key, vbNullString, _
Buffer, Len(Buffer), Path)
INIGetValue = Left$(Buffer, Result)
End Function
Private Sub live_Timer()
Winsock1.SendData ("9") ' dummy befehl um die Verindung zu halten.
End Sub
Private Sub Timer1_Timer()
Select Case Winsock1.State
Case ckClosed
lbStatus.Caption = "no Connection"
Case sckResolvingHost
lbStatus.Caption = "waiting for DNS"
Case sckHostResolved
lbStatus.Caption = "get IP from DNS"
Case sckConnecting
lbStatus.Caption = "connecting"
Case sckConnected
lbStatus.Caption = "Connection to " + Winsock1.RemoteHost
Command1.Enabled = True
Case sckClosing
lbStatus.Caption = "closing Connection"
Case sckError
lbStatus.Caption = "Connection Error"
Winsock1.Close
End Select
If Winsock1.State <> sckConnected Then
cbSendData.Enabled = False
cbDisconnect.Enabled = False
cbConnect.Enabled = True
Else
cbSendData.Enabled = True
cbDisconnect.Enabled = True
cbConnect.Enabled = False
End If
End Sub
Private Sub Timer2_Timer()
dataprocessed = False
tbSendData.Text = "1" ' Temperatur 1
Call cbSendData_Click
While dataprocessed = False
DoEvents
Sleep (50)
Wend
Sleep (500)
dataprocessed = False
tbSendData.Text = "2" ' Temperatur 2
Call cbSendData_Click
While dataprocessed = False
DoEvents
Sleep (50)
Wend
Sleep (500)
dataprocessed = False
tbSendData.Text = "3" ' Uhrzeit
Call cbSendData_Click
While dataprocessed = False
DoEvents
Sleep (50)
Wend
Sleep (500)
End Sub
Private Sub Timer3_Timer()
If LedStatus = False Then
Shape1.FillColor = &HC0C0C0
LedStatus = True
Else
LedStatus = False
Shape1.FillColor = &HFF00&
End If
End Sub
Private Sub Winsock1_Close()
Winsock1.Close
Winsock1.LocalPort = 0
cbConnect.Enabled = True
cbDisconnect.Enabled = False
cbSendData.Enabled = False
lbStatus.Caption = "no Connection"
cbConnect.SetFocus
End Sub
Private Sub Winsock1_Connect()
cbDisconnect.Enabled = True
cbConnect.Enabled = False
lbStatus.Caption = "connected to " + Winsock1.RemoteHost
Winsock1.SendData ("S0")
Call Timer2_Timer
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim ReceiveData As String
Dim intStart, intEnd, Result As Integer
Dim strTemp, strTemp1, strTemp2 As String
Dim intStatus As Integer
Dim intTime As Integer
Winsock1.GetData ReceiveData
Label10.Caption = Str(bytesTotal) & " " & ReceiveData
strRecData = strRecData + ReceiveData
Label5.Caption = strRecData
intStatus = 0
intStart = 0
intTime = 0
intStart = InStr(1, strRecData, "<", vbTextCompare)
intEnd = InStr(1, strRecData, ">", vbTextCompare)
If (intStart = 0) And (intEnd = 0) Then ' Start- und Endekennung da ?
Label9.Caption = "Kein Start- oder Endezeichen empfangen"
'Winsock1.SendData ("S0")
dataprocessed = True
Exit Sub
End If
If intEnd < intStart Then ' Mist empfangen
Label9.Caption = "Endezeichen vor Startzeichen empfangen"
' Winsock1.SendData ("S0")
dataprocessed = True
Exit Sub
End If
strTemp = Mid$(strRecData, intStart + 1, intEnd - 2)
strTemp1 = Mid$(strRecData, intStart + 1, intEnd - 1)
Label9.Caption = strRecData
intStart = InStr(1, strTemp, "t", vbTextCompare)
intStatus = InStr(1, strTemp, "ST", vbTextCompare)
' result = MsgBox("Status: " & Str(intStatus), vbOKOnly, "Status")
Label9.Caption = strTemp
If intStatus > 0 Then ' Status empfangen
If Mid$(strTemp, 3, 1) = "1" Then
Shape2(6).FillColor = &HFF00&
Label11(0).Caption = Anzeigetext1 & "an"
Else
Shape2(6).FillColor = &HFF&
Label11(0).Caption = Anzeigetext1 & "aus"
End If
If Mid$(strTemp, 4, 1) = "1" Then
Shape2(5).FillColor = &HFF00&
Label11(1).Caption = Anzeigetext2 & "an"
Else
Shape2(5).FillColor = &HFF&
Label11(1).Caption = Anzeigetext2 & "aus"
End If
If Mid$(strTemp, 5, 1) = "1" Then
Shape2(4).FillColor = &HFF00&
Label11(2).Caption = Anzeigetext3 & "an"
Else
Shape2(4).FillColor = &HFF&
Label11(2).Caption = Anzeigetext3 & "aus"
End If
If Mid$(strTemp, 6, 1) = "1" Then
Shape2(3).FillColor = &HFF00&
Label11(3).Caption = Anzeigetext4 & "an"
Else
Shape2(3).FillColor = &HFF&
Label11(3).Caption = Anzeigetext4 & "aus"
End If
If Mid$(strTemp, 7, 1) = "1" Then
Shape2(2).FillColor = &HFF00&
Label11(4).Caption = Anzeigetext5 & "an"
Else
Shape2(2).FillColor = &HFF&
Label11(4).Caption = Anzeigetext5 & "aus"
End If
If Mid$(strTemp, 8, 1) = "1" Then
Shape2(1).FillColor = &HFF00&
Label11(5).Caption = Anzeigetext6 & "an"
Else
Shape2(1).FillColor = &HFF&
Label11(5).Caption = Anzeigetext6 & "aus"
End If
If Mid$(strTemp, 9, 1) = "1" Then
Shape2(0).FillColor = &HFF00&
Label11(6).Caption = Anzeigetext7 & "an"
Else
Shape2(0).FillColor = &HFF&
Label11(6).Caption = Anzeigetext7 & "aus"
End If
End If
If InStr(1, strTemp, "t1", vbTextCompare) > 0 Then
Label7.Caption = strTemp & " °C"
End If
If InStr(1, strTemp, "t2", vbTextCompare) > 0 Then
Label8.Caption = strTemp & " °C"
End If
If InStr(1, strTemp, "t3", vbTextCompare) > 0 Then
Label15.Caption = Mid$(strTemp1, intStart + 3, intEnd - 5)
End If
intStatus = 0
intTime = 0
intStart = 0
strRecData = ""
Label5.Caption = ""
dataprocessed = True
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)
Winsock1.Close
Winsock1.LocalPort = 0
dummy = MsgBox("Connection Error", vbOKOnly, "TCP Client")
Call cbConnect_Click
End Sub
|
