host/vb_net_test/nettest.frm

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{33155A3D-0CE0-11D1-A6B4-444553540000}#1.0#0"; "SysTray.ocx"
Begin VB.Form Form1 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "i-scream Winhost"
   ClientHeight    =   5655
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4710
   Icon            =   "nettest.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5655
   ScaleWidth      =   4710
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Hide 
      Caption         =   "Hide Window"
      Height          =   375
      Left            =   3120
      TabIndex        =   7
      Top             =   840
      Width           =   1455
   End
   Begin SysTray.SystemTray SystemTray 
      Left            =   2160
      Top             =   1800
      _ExtentX        =   847
      _ExtentY        =   847
      SysTrayText     =   "i-scream Winhost"
      IconFile        =   0
   End
   Begin VB.Timer Timer1 
      Left            =   2760
      Top             =   1800
   End
   Begin VB.TextBox Text4 
      Height          =   1575
      Left            =   240
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Text            =   "nettest.frx":0742
      Top             =   3000
      Width           =   3975
   End
   Begin VB.CommandButton Reconfigure 
      Caption         =   "Reconfigure with FilterManager"
      Height          =   375
      Left            =   120
      TabIndex        =   0
      Top             =   840
      Width           =   2895
   End
   Begin MSWinsockLib.Winsock TCPSock 
      Left            =   3720
      Top             =   1800
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin MSWinsockLib.Winsock UDPSock 
      Left            =   3240
      Top             =   1800
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
      Protocol        =   1
   End
   Begin VB.Label Label5 
      Caption         =   "b e t a"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   24
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   240
      TabIndex        =   8
      Top             =   120
      Width           =   1815
   End
   Begin VB.Label Label2 
      Alignment       =   1  'Right Justify
      Caption         =   "Next heartbeat:"
      Height          =   255
      Left            =   2400
      TabIndex        =   6
      Top             =   480
      Width           =   1455
   End
   Begin VB.Label Label1 
      Alignment       =   1  'Right Justify
      Caption         =   "Next UDP packet:"
      Height          =   255
      Left            =   2400
      TabIndex        =   5
      Top             =   120
      Width           =   1455
   End
   Begin VB.Label Label4 
      BorderStyle     =   1  'Fixed Single
      Caption         =   "0"
      Height          =   255
      Left            =   3960
      TabIndex        =   4
      Top             =   480
      Width           =   615
   End
   Begin VB.Label Label3 
      BorderStyle     =   1  'Fixed Single
      Caption         =   "0"
      Height          =   255
      Left            =   3960
      TabIndex        =   3
      Top             =   120
      Width           =   615
   End
   Begin VB.Label Status 
      Alignment       =   2  'Center
      Caption         =   "Status:"
      Height          =   255
      Left            =   0
      TabIndex        =   2
      Top             =   1320
      Width           =   4695
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' For the system tray bits
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long

Dim filterManagerHostname As String
Dim filterManagerTCPPort As Long

Dim seqNo As Long
Dim machineName As String

Dim filterHostname As String
Dim filterTCPPort As Integer
Dim filterUDPPort As Integer
Dim fileList As String
Dim lastModified As String

Dim UDPUpdateTime As Integer
Dim TCPUpdateTime As Integer

Dim protocolVersion As String
Dim connected As Boolean

Dim CUpTime As New CUpTime

Dim responseNumber As Integer

Private Sub Form_Load()
    
    If App.PrevInstance Then
        x = MsgBox("There is already an i-scream Winhost running on this machine.", 48, "i-scream host already running")
    End If
    
    protocolVersion = "1.1"
    
    Status.Caption = "Loading"
    Form1.Caption = "i-scream Winhost " & protocolVersion
    
    Form1.Show
    
    CUpTime.Init
    
    If CUpTime.isWin9x Then
        x = MsgBox("Sorry, the i-scream host can only be used to monitor servers (i.e. not Win9x)", 48, "Not a server.")
        End
    End If
    
    ''''TEMP
    'filterManagerHostname = "killigrew.ukc.ac.uk"
    'filterManagerTCPPort = 4567
    ''''' END TEMP
    
    'GoTo skip
    On Error GoTo iniError
    Dim buf As String * 256
    Dim length As Long
    length = GetPrivateProfileString("i-scream Winhost", "FilterManager", "<no value>", buf, Len(buf), App.Path & "/winhost.ini")
    filterManagerHostname = Left$(buf, length)
    length = GetPrivateProfileInt("i-scream Winhost", "FilterManagerPort", 0, App.Path & "/winhost.ini")
    filterManagerTCPPort = length
    On Error GoTo 0
skip:

    Status.Caption = "Connecting to Filter Manager " & filterManagerHostname & ":" & filterManagerTCPPort
    Reconfigure_Click
    
    SystemTray.Icon = Val(Form1.Icon)
    SystemTray.Action = 0
    
    
    Exit Sub
    
iniError:
    x = MsgBox("The i-scream Winhost could not read the correct settings from the winhost.ini file.  Please correct these and try again.  " & Err.Description, 48, "Configuration not found")
    End
    
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    x = MsgBox("Are you sure you want to shut down the Winhost?  This will stop your computer sending information to the i-scream Central Monitoring System.", vbYesNo, "i-scream Winhost")
    If x = 7 Then
        Cancel = True
    Else
        SystemTray.Action = 2
    End If

End Sub

Private Sub Hide_Click()
    Form1.Visible = False
    SystemTray.Icon = Val(Form1.Icon)
End Sub

Private Sub Reconfigure_Click()
    ' establish a TCP connection to a filtermanager
    connected = False
    TCPSock.Close
    TCPSock.Connect filterManagerHostname, filterManagerTCPPort
End Sub


Private Sub SystemTray_MouseDblClk(ByVal Button As Integer)

    Form1.Visible = True
    Form1.SetFocus
    

End Sub

Private Sub TCPSock_Connect()
    
    responseNumber = 0
   
    ' Send something as soon as we connect to the server.
    If connected = False Then
        ' contact the FilterManager
        TCPSock.SendData "STARTCONFIG" & vbCrLf
    Else
       ' Contact the Filter
       TCPSock.SendData "HEARTBEAT" & vbCrLf
    End If
   
End Sub

Private Sub TCPSock_DataArrival(ByVal bytesTotal As Long)
    
    responseNumber = responseNumber + 1
    
    ' Get the line from the server.
    TCPSock.GetData response, vbString, bytesTotal
    
    ' Remove linefeeds and returns from the line.
    response = Replace(response, Chr(13), "")
    response = Replace(response, Chr(10), "")
    Text4.Text = Text4.Text & vbCrLf & response
    
    If connected = False Then
        ' Perform TCP configuration (1.1)
        On Error GoTo configError
        Select Case responseNumber
            Case 1:
                If Not response = "OK" Then GoTo configError
                TCPSock.SendData "LASTMODIFIED" & vbCrLf
            Case 2:
                If response = "ERROR" Then GoTo configError
                lastModified = response
                TCPSock.SendData "FILELIST" & vbCrLf
            Case 3:
                If response = "ERROR" Then GoTo configError
                fileList = response
                TCPSock.SendData "UDPUpdateTime" & vbCrLf
            Case 4:
                If response = "ERROR" Then GoTo configError
                UDPUpdateTime = response
                TCPSock.SendData "TCPUpdateTime" & vbCrLf
            Case 5:
                If response = "ERROR" Then GoTo configError
                TCPUpdateTime = response
                TCPSock.SendData "ENDCONFIG" & vbCrLf
            Case 6:
                If Not response = "OK" Then GoTo configError
                TCPSock.SendData "FILTER" & vbCrLf
            Case 7:
                'we got a filter list here.
                readTo = 0
                ' get hostname
                readTo = InStr(1, response, ";", vbBinaryCompare)
                filterHostname = Mid(response, 1, readTo - 1)
                response = Mid(response, readTo + 1, Len(response))
                ' get UDP Port number
                readTo = InStr(1, response, ";")
                filterUDPPort = Mid(response, 1, readTo - 1)
                response = Mid(response, readTo + 1, Len(response))
                ' get TCP Port number
                filterTCPPort = response
                TCPSock.SendData "END" & vbCrLf
            Case 8:
                If Not response = "OK" Then GoTo configError
                connected = True
                responseNumber = 0
                TCPSock.Close
                Text4.Text = Text4.Text & vbCrLf & "  <closed>"
                Status.Caption = "Configuration successful"
                Label3.Caption = UDPUpdateTime
                Label4.Caption = TCPUpdateTime
                Timer1.Interval = 1000
        End Select
    Else
        ' Perform a heartbeat (1.1)
        On Error GoTo heartbeatError
        Select Case responseNumber
            Case 1:
                If Not response = "OK" Then GoTo heartbeatError
                TCPSock.SendData "CONFIG" & vbCrLf
            Case 2:
                If Not response = "OK" Then GoTo heartbeatError
                TCPSock.SendData fileList & vbCrLf
            Case 3:
                If Not response = "OK" Then GoTo heartbeatError
                TCPSock.SendData lastModified & vbCrLf
            Case 4:
                If Not response = "OK" Then GoTo heartbeatError
                TCPSock.SendData "ENDHEARTBEAT" & vbCrLf
            Case 5:
                If Not response = "OK" Then GoTo heartbeatError
                TCPSock.Close
                Status.Caption = "Heartbeat sent successfully."
        End Select
    
    End If
    
    
    Exit Sub
    
configError:
    Status.Caption = "FAILED to get configuration"
    Exit Sub
heartbeatError:
    Status.Caption = "Heatbeat FAILED"
    Exit Sub
End Sub

Private Sub Timer1_Timer()

    Label3.Caption = Label3.Caption - 1
    Label4.Caption = Label4.Caption - 1
    
    Status.Caption = ""
    
    If Label3.Caption < 1 Then
        
        ' prepare the contents of the XML packet.
        seqNo = seqNo + 1
        machineName = TCPSock.LocalHostName
        LocalIP = TCPSock.LocalIP
        packetDate = Date2Num()
        
        
        Dim verinfo As OSVERSIONINFO
        verinfo.dwOSVersionInfoSize = Len(verinfo)
        ret% = GetVersionEx(verinfo)
        If ret% = 0 Then
            MsgBox "Error getting Windows version Information"
            End
        End If
          
        osName = GetVersion()
        osVersionMajor = verinfo.dwMajorVersion
        osVersionMinor = verinfo.dwMinorVersion
        osBuild = verinfo.dwBuildNumber
        
        Dim sysinfo As SYSTEM_INFO
        GetSystemInfo sysinfo
        Select Case sysinfo.dwProcessorType
            Case PROCESSOR_INTEL_386
                processorType = "Intel 386"
            Case PROCESSOR_INTEL_486
                processorType = "Intel 486"
            Case PROCESSOR_INTEL_PENTIUM
                processorType = "Intel Pentium variant"
            Case PROCESSOR_MIPS_R4000
                processorType = "MIPS R4000"
            Case PROCESSOR_ALPHA_21064
                processorType = "DEC Alpha 21064"
            Case Else
                processorType = "(unknown)"
        End Select
        
        Dim memsts As MEMORYSTATUS
        Dim memory&
        GlobalMemoryStatus memsts
        memory& = memsts.dwTotalPhys
        memTotal = memory& \ 1024
        memory& = memsts.dwAvailPhys
        memFree = memory& \ 1024
        memory& = memsts.dwTotalVirtual
        swapTotal = memory& \ 1024
        memory& = memsts.dwAvailVirtual
        swapFree = memory& \ 1024
        
        uptime = GetTickCount \ 1000
        
        CUpTime.Capture
        cpu_time = CUpTime.CPUTime
        percent_idle = CUpTime.PercentIdle
        
        ' build the contents of the XML packet
        xml = "<packet seq_no=""" & seqNo & """ machine_name=""" & machineName & """ date=""" & packetDate & """ type=""data"" ip=""" & LocalIP & """>" & _
              "<os>" & _
                "<name>" & osName & "</name>" & _
                "<version>" & osVersionMajor & "</version>" & _
                "<release>" & osBuild & "</release>" & _
                "<platform>" & osName & "</platform>" & _
                "<minor_version>" & osVersionMinor & "</minor_version>" & _
                "<processor>" & processorType & "</processor>" & _
                "<uptime>" & uptime & "</uptime>" & _
              "</os>" & _
              "<cpu><idle>" & percent_idle & "</idle><user>" & cpu_time & "</user></cpu>" & _
              "<memory><total>" & memTotal & "</total><free>" & memFree & "</free></memory>" & _
              "<swap><total>" & swapTotal & "</total><free>" & swapFree & "</free></swap>" & _
              "</packet>"
        Text4.Text = Text4.Text + xml

        ' Use the first winsock control to send a UDP packet.
        UDPSock.RemoteHost = filterHostname
        UDPSock.RemotePort = filterUDPPort
        UDPSock.SendData xml
        Status.Caption = "UDP packet sent"
        Label3.Caption = UDPUpdateTime
    End If
    
    If Label4.Caption < 1 Then
        ' establish a TCP connection to a filter
        TCPSock.Close
        TCPSock.Connect filterHostname, filterTCPPort
        Label4.Caption = TCPUpdateTime
    End If

End Sub

Function Date2Num() As Long
    Dim x As Long
    x = DateDiff("s", "1-1-1970", Now)
    Date2Num = x
End Function
Revision:	1.23
Committed:	Mon Feb 26 09:54:25 2001 UTC (23 years, 2 months ago) by pjm2
Branch:	MAIN
Changes since 1.22:	+5 -0 lines
Log Message:	Added cpu percent idle and cpu time to the XML packet.
#	User	Rev	Content
1	pjm2	1.1	VERSION 5.00
2			Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
3	pjm2	1.11	Object = "{33155A3D-0CE0-11D1-A6B4-444553540000}#1.0#0"; "SysTray.ocx"
4	pjm2	1.1	Begin VB.Form Form1
5	pjm2	1.17	BorderStyle = 3 'Fixed Dialog
6	pjm2	1.10	Caption = "i-scream Winhost"
7	pjm2	1.1	ClientHeight = 5655
8			ClientLeft = 45
9	pjm2	1.17	ClientTop = 330
10	pjm2	1.12	ClientWidth = 4710
11	pjm2	1.20	Icon = "nettest.frx":0000
12	pjm2	1.1	LinkTopic = "Form1"
13			MaxButton = 0 'False
14	pjm2	1.17	MinButton = 0 'False
15	pjm2	1.1	ScaleHeight = 5655
16	pjm2	1.12	ScaleWidth = 4710
17	pjm2	1.1	ShowInTaskbar = 0 'False
18			StartUpPosition = 3 'Windows Default
19	pjm2	1.11	Begin VB.CommandButton Hide
20	pjm2	1.12	Caption = "Hide Window"
21			Height = 375
22			Left = 3120
23	pjm2	1.11	TabIndex = 7
24	pjm2	1.12	Top = 840
25			Width = 1455
26	pjm2	1.11	End
27			Begin SysTray.SystemTray SystemTray
28	pjm2	1.12	Left = 2160
29			Top = 1800
30	pjm2	1.11	_ExtentX = 847
31			_ExtentY = 847
32			SysTrayText = "i-scream Winhost"
33			IconFile = 0
34			End
35	pjm2	1.8	Begin VB.Timer Timer1
36	pjm2	1.12	Left = 2760
37			Top = 1800
38	pjm2	1.1	End
39			Begin VB.TextBox Text4
40	pjm2	1.6	Height = 1575
41	pjm2	1.1	Left = 240
42			MultiLine = -1 'True
43			ScrollBars = 2 'Vertical
44	pjm2	1.10	TabIndex = 1
45	pjm2	1.20	Text = "nettest.frx":0742
46	pjm2	1.1	Top = 3000
47	pjm2	1.12	Width = 3975
48	pjm2	1.1	End
49	pjm2	1.10	Begin VB.CommandButton Reconfigure
50			Caption = "Reconfigure with FilterManager"
51	pjm2	1.12	Height = 375
52	pjm2	1.10	Left = 120
53			TabIndex = 0
54	pjm2	1.12	Top = 840
55	pjm2	1.10	Width = 2895
56	pjm2	1.1	End
57	pjm2	1.5	Begin MSWinsockLib.Winsock TCPSock
58	pjm2	1.12	Left = 3720
59			Top = 1800
60	pjm2	1.1	_ExtentX = 741
61			_ExtentY = 741
62			_Version = 393216
63			End
64	pjm2	1.5	Begin MSWinsockLib.Winsock UDPSock
65	pjm2	1.12	Left = 3240
66			Top = 1800
67	pjm2	1.1	_ExtentX = 741
68			_ExtentY = 741
69			_Version = 393216
70			Protocol = 1
71			End
72	pjm2	1.17	Begin VB.Label Label5
73			Caption = "b e t a"
74			BeginProperty Font
75			Name = "MS Sans Serif"
76			Size = 24
77			Charset = 0
78			Weight = 700
79			Underline = 0 'False
80			Italic = 0 'False
81			Strikethrough = 0 'False
82			EndProperty
83			Height = 615
84			Left = 240
85			TabIndex = 8
86			Top = 120
87			Width = 1815
88			End
89	pjm2	1.9	Begin VB.Label Label2
90			Alignment = 1 'Right Justify
91			Caption = "Next heartbeat:"
92	pjm2	1.8	Height = 255
93	pjm2	1.12	Left = 2400
94	pjm2	1.10	TabIndex = 6
95	pjm2	1.9	Top = 480
96			Width = 1455
97	pjm2	1.8	End
98	pjm2	1.9	Begin VB.Label Label1
99			Alignment = 1 'Right Justify
100			Caption = "Next UDP packet:"
101	pjm2	1.8	Height = 255
102	pjm2	1.12	Left = 2400
103	pjm2	1.10	TabIndex = 5
104	pjm2	1.9	Top = 120
105			Width = 1455
106	pjm2	1.8	End
107	pjm2	1.9	Begin VB.Label Label4
108	pjm2	1.10	BorderStyle = 1 'Fixed Single
109	pjm2	1.9	Caption = "0"
110	pjm2	1.7	Height = 255
111	pjm2	1.12	Left = 3960
112	pjm2	1.10	TabIndex = 4
113	pjm2	1.9	Top = 480
114			Width = 615
115	pjm2	1.7	End
116	pjm2	1.9	Begin VB.Label Label3
117	pjm2	1.10	BorderStyle = 1 'Fixed Single
118	pjm2	1.9	Caption = "0"
119	pjm2	1.7	Height = 255
120	pjm2	1.12	Left = 3960
121	pjm2	1.10	TabIndex = 3
122	pjm2	1.9	Top = 120
123			Width = 615
124	pjm2	1.7	End
125	pjm2	1.6	Begin VB.Label Status
126	pjm2	1.12	Alignment = 2 'Center
127	pjm2	1.6	Caption = "Status:"
128	pjm2	1.1	Height = 255
129	pjm2	1.18	Left = 0
130	pjm2	1.10	TabIndex = 2
131	pjm2	1.12	Top = 1320
132	pjm2	1.18	Width = 4695
133	pjm2	1.1	End
134			End
135			Attribute VB_Name = "Form1"
136			Attribute VB_GlobalNameSpace = False
137			Attribute VB_Creatable = False
138			Attribute VB_PredeclaredId = True
139			Attribute VB_Exposed = False
140	pjm2	1.15	' For the system tray bits
141	pjm2	1.4	Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
142			Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
143
144			Dim filterManagerHostname As String
145	pjm2	1.18	Dim filterManagerTCPPort As Long
146	pjm2	1.4
147	pjm2	1.13	Dim seqNo As Long
148			Dim machineName As String
149
150	pjm2	1.2	Dim filterHostname As String
151	pjm2	1.3	Dim filterTCPPort As Integer
152			Dim filterUDPPort As Integer
153			Dim fileList As String
154			Dim lastModified As String
155	pjm2	1.2
156	pjm2	1.7	Dim UDPUpdateTime As Integer
157			Dim TCPUpdateTime As Integer
158
159	pjm2	1.2	Dim protocolVersion As String
160			Dim connected As Boolean
161	pjm2	1.16
162	pjm2	1.21	Dim CUpTime As New CUpTime
163	pjm2	1.16
164	pjm2	1.1	Dim responseNumber As Integer
165
166	pjm2	1.2	Private Sub Form_Load()
167	pjm2	1.13
168	pjm2	1.22	If App.PrevInstance Then
169			x = MsgBox("There is already an i-scream Winhost running on this machine.", 48, "i-scream host already running")
170			End If
171
172	pjm2	1.2	protocolVersion = "1.1"
173	pjm2	1.13
174	pjm2	1.10	Status.Caption = "Loading"
175	pjm2	1.21	Form1.Caption = "i-scream Winhost " & protocolVersion
176
177			Form1.Show
178
179			CUpTime.Init
180
181			If CUpTime.isWin9x Then
182			x = MsgBox("Sorry, the i-scream host can only be used to monitor servers (i.e. not Win9x)", 48, "Not a server.")
183			End
184			End If
185	pjm2	1.6
186	pjm2	1.4	''''TEMP
187	pjm2	1.18	'filterManagerHostname = "killigrew.ukc.ac.uk"
188			'filterManagerTCPPort = 4567
189	pjm2	1.13	''''' END TEMP
190	pjm2	1.4
191	pjm2	1.18	'GoTo skip
192	pjm2	1.4	On Error GoTo iniError
193			Dim buf As String * 256
194			Dim length As Long
195	pjm2	1.18	length = GetPrivateProfileString("i-scream Winhost", "FilterManager", "<no value>", buf, Len(buf), App.Path & "/winhost.ini")
196	pjm2	1.4	filterManagerHostname = Left$(buf, length)
197	pjm2	1.18	length = GetPrivateProfileInt("i-scream Winhost", "FilterManagerPort", 0, App.Path & "/winhost.ini")
198			filterManagerTCPPort = length
199	pjm2	1.20	On Error GoTo 0
200	pjm2	1.13	skip:
201
202	pjm2	1.18	Status.Caption = "Connecting to Filter Manager " & filterManagerHostname & ":" & filterManagerTCPPort
203	pjm2	1.13	Reconfigure_Click
204	pjm2	1.6
205	pjm2	1.20	SystemTray.Icon = Val(Form1.Icon)
206	pjm2	1.15	SystemTray.Action = 0
207
208
209	pjm2	1.4	Exit Sub
210
211			iniError:
212	pjm2	1.18	x = MsgBox("The i-scream Winhost could not read the correct settings from the winhost.ini file. Please correct these and try again. " & Err.Description, 48, "Configuration not found")
213	pjm2	1.4	End
214
215			End Sub
216
217	pjm2	1.10	Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
218	pjm2	1.11	x = MsgBox("Are you sure you want to shut down the Winhost? This will stop your computer sending information to the i-scream Central Monitoring System.", vbYesNo, "i-scream Winhost")
219	pjm2	1.10	If x = 7 Then
220			Cancel = True
221	pjm2	1.15	Else
222			SystemTray.Action = 2
223	pjm2	1.10	End If
224
225			End Sub
226
227	pjm2	1.11	Private Sub Hide_Click()
228			Form1.Visible = False
229			SystemTray.Icon = Val(Form1.Icon)
230			End Sub
231
232	pjm2	1.10	Private Sub Reconfigure_Click()
233			' establish a TCP connection to a filtermanager
234			connected = False
235			TCPSock.Close
236			TCPSock.Connect filterManagerHostname, filterManagerTCPPort
237	pjm2	1.11	End Sub
238
239
240
241			Private Sub SystemTray_MouseDblClk(ByVal Button As Integer)
242
243			Form1.Visible = True
244			Form1.SetFocus
245	pjm2	1.12
246	pjm2	1.11
247	pjm2	1.10	End Sub
248
249	pjm2	1.5	Private Sub TCPSock_Connect()
250	pjm2	1.6
251			responseNumber = 0
252	pjm2	1.1
253	pjm2	1.3	' Send something as soon as we connect to the server.
254			If connected = False Then
255			' contact the FilterManager
256	pjm2	1.5	TCPSock.SendData "STARTCONFIG" & vbCrLf
257	pjm2	1.3	Else
258			' Contact the Filter
259	pjm2	1.5	TCPSock.SendData "HEARTBEAT" & vbCrLf
260	pjm2	1.3	End If
261	pjm2	1.1
262			End Sub
263
264	pjm2	1.5	Private Sub TCPSock_DataArrival(ByVal bytesTotal As Long)
265	pjm2	1.1
266			responseNumber = responseNumber + 1
267
268			' Get the line from the server.
269	pjm2	1.5	TCPSock.GetData response, vbString, bytesTotal
270	pjm2	1.1
271			' Remove linefeeds and returns from the line.
272			response = Replace(response, Chr(13), "")
273			response = Replace(response, Chr(10), "")
274			Text4.Text = Text4.Text & vbCrLf & response
275
276	pjm2	1.2	If connected = False Then
277			' Perform TCP configuration (1.1)
278			On Error GoTo configError
279			Select Case responseNumber
280			Case 1:
281			If Not response = "OK" Then GoTo configError
282	pjm2	1.5	TCPSock.SendData "LASTMODIFIED" & vbCrLf
283	pjm2	1.2	Case 2:
284			If response = "ERROR" Then GoTo configError
285	pjm2	1.3	lastModified = response
286	pjm2	1.5	TCPSock.SendData "FILELIST" & vbCrLf
287	pjm2	1.2	Case 3:
288			If response = "ERROR" Then GoTo configError
289	pjm2	1.3	fileList = response
290	pjm2	1.5	TCPSock.SendData "UDPUpdateTime" & vbCrLf
291	pjm2	1.2	Case 4:
292			If response = "ERROR" Then GoTo configError
293	pjm2	1.7	UDPUpdateTime = response
294	pjm2	1.5	TCPSock.SendData "TCPUpdateTime" & vbCrLf
295	pjm2	1.2	Case 5:
296			If response = "ERROR" Then GoTo configError
297	pjm2	1.7	TCPUpdateTime = response
298	pjm2	1.5	TCPSock.SendData "ENDCONFIG" & vbCrLf
299	pjm2	1.2	Case 6:
300			If Not response = "OK" Then GoTo configError
301	pjm2	1.5	TCPSock.SendData "FILTER" & vbCrLf
302	pjm2	1.2	Case 7:
303			'we got a filter list here.
304			readTo = 0
305			' get hostname
306			readTo = InStr(1, response, ";", vbBinaryCompare)
307			filterHostname = Mid(response, 1, readTo - 1)
308			response = Mid(response, readTo + 1, Len(response))
309			' get UDP Port number
310			readTo = InStr(1, response, ";")
311			filterUDPPort = Mid(response, 1, readTo - 1)
312			response = Mid(response, readTo + 1, Len(response))
313			' get TCP Port number
314			filterTCPPort = response
315	pjm2	1.5	TCPSock.SendData "END" & vbCrLf
316	pjm2	1.2	Case 8:
317			If Not response = "OK" Then GoTo configError
318			connected = True
319			responseNumber = 0
320	pjm2	1.5	TCPSock.Close
321	pjm2	1.2	Text4.Text = Text4.Text & vbCrLf & " <closed>"
322	pjm2	1.10	Status.Caption = "Configuration successful"
323	pjm2	1.8	Label3.Caption = UDPUpdateTime
324			Label4.Caption = TCPUpdateTime
325			Timer1.Interval = 1000
326	pjm2	1.2	End Select
327			Else
328			' Perform a heartbeat (1.1)
329			On Error GoTo heartbeatError
330			Select Case responseNumber
331			Case 1:
332	pjm2	1.3	If Not response = "OK" Then GoTo heartbeatError
333	pjm2	1.5	TCPSock.SendData "CONFIG" & vbCrLf
334	pjm2	1.2	Case 2:
335	pjm2	1.3	If Not response = "OK" Then GoTo heartbeatError
336	pjm2	1.5	TCPSock.SendData fileList & vbCrLf
337	pjm2	1.2	Case 3:
338	pjm2	1.3	If Not response = "OK" Then GoTo heartbeatError
339	pjm2	1.5	TCPSock.SendData lastModified & vbCrLf
340	pjm2	1.2	Case 4:
341	pjm2	1.3	If Not response = "OK" Then GoTo heartbeatError
342	pjm2	1.5	TCPSock.SendData "ENDHEARTBEAT" & vbCrLf
343	pjm2	1.2	Case 5:
344	pjm2	1.3	If Not response = "OK" Then GoTo heartbeatError
345	pjm2	1.5	TCPSock.Close
346	pjm2	1.10	Status.Caption = "Heartbeat sent successfully."
347	pjm2	1.2	End Select
348
349			End If
350
351
352			Exit Sub
353
354			configError:
355	pjm2	1.10	Status.Caption = "FAILED to get configuration"
356	pjm2	1.8	Exit Sub
357	pjm2	1.2	heartbeatError:
358	pjm2	1.10	Status.Caption = "Heatbeat FAILED"
359	pjm2	1.8	Exit Sub
360	pjm2	1.1	End Sub
361	pjm2	1.5
362	pjm2	1.8	Private Sub Timer1_Timer()
363
364			Label3.Caption = Label3.Caption - 1
365			Label4.Caption = Label4.Caption - 1
366
367	pjm2	1.10	Status.Caption = ""
368	pjm2	1.8
369			If Label3.Caption < 1 Then
370	pjm2	1.15
371			' prepare the contents of the XML packet.
372			seqNo = seqNo + 1
373			machineName = TCPSock.LocalHostName
374	pjm2	1.16	LocalIP = TCPSock.LocalIP
375	pjm2	1.14	packetDate = Date2Num()
376	pjm2	1.15
377
378			Dim verinfo As OSVERSIONINFO
379			verinfo.dwOSVersionInfoSize = Len(verinfo)
380			ret% = GetVersionEx(verinfo)
381			If ret% = 0 Then
382			MsgBox "Error getting Windows version Information"
383			End
384			End If
385
386	pjm2	1.21	osName = GetVersion()
387	pjm2	1.15	osVersionMajor = verinfo.dwMajorVersion
388			osVersionMinor = verinfo.dwMinorVersion
389			osBuild = verinfo.dwBuildNumber
390
391			Dim sysinfo As SYSTEM_INFO
392			GetSystemInfo sysinfo
393			Select Case sysinfo.dwProcessorType
394			Case PROCESSOR_INTEL_386
395			processorType = "Intel 386"
396			Case PROCESSOR_INTEL_486
397			processorType = "Intel 486"
398			Case PROCESSOR_INTEL_PENTIUM
399			processorType = "Intel Pentium variant"
400			Case PROCESSOR_MIPS_R4000
401			processorType = "MIPS R4000"
402			Case PROCESSOR_ALPHA_21064
403			processorType = "DEC Alpha 21064"
404			Case Else
405			processorType = "(unknown)"
406			End Select
407
408			Dim memsts As MEMORYSTATUS
409			Dim memory&
410			GlobalMemoryStatus memsts
411			memory& = memsts.dwTotalPhys
412			memTotal = memory& \ 1024
413			memory& = memsts.dwAvailPhys
414			memFree = memory& \ 1024
415			memory& = memsts.dwTotalVirtual
416			swapTotal = memory& \ 1024
417			memory& = memsts.dwAvailVirtual
418			swapFree = memory& \ 1024
419
420	pjm2	1.19	uptime = GetTickCount \ 1000
421
422	pjm2	1.23	CUpTime.Capture
423			cpu_time = CUpTime.CPUTime
424			percent_idle = CUpTime.PercentIdle
425
426	pjm2	1.15	' build the contents of the XML packet
427	pjm2	1.16	xml = "<packet seq_no=""" & seqNo & """ machine_name=""" & machineName & """ date=""" & packetDate & """ type=""data"" ip=""" & LocalIP & """>" & _
428	pjm2	1.15	"<os>" & _
429			"<name>" & osName & "</name>" & _
430			"<version>" & osVersionMajor & "</version>" & _
431			"<release>" & osBuild & "</release>" & _
432			"<platform>" & osName & "</platform>" & _
433			"<minor_version>" & osVersionMinor & "</minor_version>" & _
434			"<processor>" & processorType & "</processor>" & _
435	pjm2	1.19	"<uptime>" & uptime & "</uptime>" & _
436	pjm2	1.15	"</os>" & _
437	pjm2	1.23	"<cpu><idle>" & percent_idle & "</idle><user>" & cpu_time & "</user></cpu>" & _
438	pjm2	1.15	"<memory><total>" & memTotal & "</total><free>" & memFree & "</free></memory>" & _
439			"<swap><total>" & swapTotal & "</total><free>" & swapFree & "</free></swap>" & _
440	pjm2	1.17	"</packet>"
441	pjm2	1.13	Text4.Text = Text4.Text + xml
442	pjm2	1.8
443			' Use the first winsock control to send a UDP packet.
444			UDPSock.RemoteHost = filterHostname
445			UDPSock.RemotePort = filterUDPPort
446			UDPSock.SendData xml
447	pjm2	1.10	Status.Caption = "UDP packet sent"
448	pjm2	1.8	Label3.Caption = UDPUpdateTime
449			End If
450
451			If Label4.Caption < 1 Then
452			' establish a TCP connection to a filter
453			TCPSock.Close
454			TCPSock.Connect filterHostname, filterTCPPort
455			Label4.Caption = TCPUpdateTime
456			End If
457
458			End Sub
459	pjm2	1.13
460			Function Date2Num() As Long
461	pjm2	1.14	Dim x As Long
462			x = DateDiff("s", "1-1-1970", Now)
463			Date2Num = x
464	pjm2	1.13	End Function