Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing MainForm.frm (20.92 KB)
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form MainForm
BorderStyle = 1 'Fixed Single
Caption = "Network Statistics WebServer"
ClientHeight = 2070
ClientLeft = 45
ClientTop = 435
ClientWidth = 5550
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "MainForm.frx":0000
MaxButton = 0 'False
ScaleHeight = 2070
ScaleWidth = 5550
StartUpPosition = 2 'CenterScreen
Begin VB.Timer TimeoutTimer
Enabled = 0 'False
Index = 0
Interval = 20000
Left = 5040
Top = 0
End
Begin MSWinsockLib.Winsock WSArray
Index = 0
Left = 4680
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin MSWinsockLib.Winsock WSConnHandler
Left = 4320
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.CommandButton Command3
Caption = "E&xit"
Height = 375
Left = 4080
TabIndex = 6
Top = 1560
Width = 1335
End
Begin VB.CommandButton Command2
Caption = "&Hide Window"
Height = 375
Left = 1560
TabIndex = 5
Top = 1560
Width = 1455
End
Begin VB.CommandButton Command1
Caption = "&Activate"
Default = -1 'True
Height = 375
Left = 120
TabIndex = 4
Top = 1560
Width = 1335
End
Begin VB.Frame Frame1
Caption = "NSWS Options"
Height = 1215
Left = 120
TabIndex = 7
Top = 120
Width = 5295
Begin VB.ComboBox cboInterfaces
Height = 315
Left = 1200
Style = 2 'Dropdown List
TabIndex = 1
Top = 720
Width = 3855
End
Begin VB.TextBox txtPort
Height = 315
Left = 4320
MaxLength = 5
TabIndex = 3
Text = "9445"
ToolTipText = "Default Port: 9445"
Top = 360
Width = 735
End
Begin VB.Image GradBar
Height = 15
Left = 120
Picture = "MainForm.frx":0442
Top = 960
Width = 720
End
Begin VB.Image ImgNetwork
Height = 480
Left = 240
Picture = "MainForm.frx":0790
Top = 360
Width = 480
End
Begin VB.Label Label2
Caption = "&Interface:"
Height = 255
Left = 1200
TabIndex = 0
Top = 400
Width = 855
End
Begin VB.Label Label1
Caption = "&Listen Port:"
Height = 255
Left = 3360
TabIndex = 2
Top = 405
Width = 855
End
End
Begin VB.Menu SysTrayMenu
Caption = "SysTrayMenu"
Visible = 0 'False
Begin VB.Menu OpenMenu
Caption = "&Show"
End
Begin VB.Menu ActivateMenu
Caption = "&Activate"
End
Begin VB.Menu Blank1
Caption = "-"
End
Begin VB.Menu StartupMenu
Caption = "&Run on Startup"
End
Begin VB.Menu Blank2
Caption = "-"
End
Begin VB.Menu ExitMenu
Caption = "E&xit"
End
End
End
Attribute VB_Name = "MainForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private m_objIpHelper As CIpHelper
Private Type INTERFACE_INFO
strInterfaceName As String
lngInterfaceIndex As Long
strInterfaceType As String
strInterfaceDescription As String
strAdapterAddress As String
strAdminStatus As String
strOperationalStatus As String
datLastChange As Long
lngSpeed As Long
lngOctetsReceived As Double
lngUnicastPacketsReceived As Long
lngMaximumTransmissionUnit As Long
lngNonunicastPacketsReceived As Long
lngDiscardedIncomingPackets As Long
lngIncomingErrors As Long
lngUnknownProtocolPackets As Long
lngOctetsSent As Double
lngUnicastPacketsSent As Long
lngNonunicastPacketsSent As Long
lngDiscardedOutgoingPackets As Long
lngOutgoingErrors As Long
lngOutputQueueLength As Long
lngBytesRecv As Double
lngBytesSent As Double
End Type
Dim Ver As String
Dim strFileBuffer As String
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_MBUTTONDBLCLK = &H209
Private SysTray As New SystrayIcon
Private pSysTrayIcon1 As StdPicture
Private pSysTrayIcon2 As StdPicture
Private Const RegAppRoot = "Software\NSWS\"
Private Function GetUpTime() As String
Dim lngDays As Long
Dim lngHour As Long
Dim lngMinute As Long
Dim lngSeconds As Long
Dim TickCount As Long
TickCount = GetTickCount
lngDays = 0
lngHour = Int(TickCount / 1000 / 60 / 60)
lngMinute = Int((TickCount / 1000 / 60)) - lngHour * 60
lngSeconds = Int((TickCount / 1000)) - lngMinute * 60 - lngHour * 3600
If lngHour > 24 Then
lngDays = Int(lngHour / 24)
lngHour = lngHour - (lngDays * 24)
End If
GetUpTime = IIf(lngDays > 0, CStr(lngDays) & " Days, ", "") & CStr(lngHour) & " Hours, " & CStr(lngMinute) & " Minutes, " & CStr(lngSeconds) & " Seconds"
End Function
Private Function GetInterfaceInfo(InterfaceID As Long, iInfo As INTERFACE_INFO) As Boolean
Dim objInterface As CInterface
If InterfaceID > m_objIpHelper.Interfaces.Count Then
GetInterfaceInfo = False
Exit Function
End If
Set objInterface = m_objIpHelper.Interfaces(InterfaceID)
iInfo.strInterfaceName = objInterface.InterfaceName
iInfo.strInterfaceDescription = objInterface.InterfaceDescription
iInfo.lngInterfaceIndex = objInterface.InterfaceIndex
Select Case objInterface.InterfaceType
Case MIB_IF_TYPE_ETHERNET: iInfo.strInterfaceType = "Ethernet"
Case MIB_IF_TYPE_FDDI: iInfo.strInterfaceType = "FDDI"
Case MIB_IF_TYPE_LOOPBACK: iInfo.strInterfaceType = "Loopback"
Case MIB_IF_TYPE_OTHER: iInfo.strInterfaceType = "Other"
Case MIB_IF_TYPE_PPP: iInfo.strInterfaceType = "PPP"
Case MIB_IF_TYPE_SLIP: iInfo.strInterfaceType = "SLIP"
Case MIB_IF_TYPE_TOKENRING: iInfo.strInterfaceType = "TokenRing"
End Select
iInfo.lngMaximumTransmissionUnit = objInterface.MaximumTransmissionUnit
iInfo.lngSpeed = objInterface.Speed
iInfo.strAdapterAddress = objInterface.AdapterAddress
Select Case objInterface.AdminStatus
Case MIB_IF_ADMIN_STATUS_DOWN: iInfo.strAdminStatus = "Down"
Case MIB_IF_ADMIN_STATUS_TESTING: iInfo.strAdminStatus = "Testing"
Case MIB_IF_ADMIN_STATUS_UP: iInfo.strAdminStatus = "Up"
End Select
Select Case objInterface.OperationalStatus
Case MIB_IF_OPER_STATUS_CONNECTED: iInfo.strOperationalStatus = "Connected"
Case MIB_IF_OPER_STATUS_CONNECTING: iInfo.strOperationalStatus = "Connecting"
Case MIB_IF_OPER_STATUS_DISCONNECTED: iInfo.strOperationalStatus = "Disconnected"
Case MIB_IF_OPER_STATUS_NON_OPERATIONAL: iInfo.strOperationalStatus = "Non operational"
Case MIB_IF_OPER_STATUS_OPERATIONAL: iInfo.strOperationalStatus = "Operational"
Case MIB_IF_OPER_STATUS_UNREACHABLE: iInfo.strOperationalStatus = "Unreachable"
End Select
iInfo.datLastChange = objInterface.LastChange
iInfo.lngOctetsReceived = objInterface.OctetsReceived
iInfo.lngUnicastPacketsReceived = objInterface.UnicastPacketsReceived
iInfo.lngNonunicastPacketsReceived = objInterface.NonunicastPacketsReceived
iInfo.lngDiscardedIncomingPackets = objInterface.DiscardedIncomingPackets
iInfo.lngIncomingErrors = objInterface.IncomingErrors
iInfo.lngUnknownProtocolPackets = objInterface.UnknownProtocolPackets
iInfo.lngOctetsSent = objInterface.OctetsSent
iInfo.lngUnicastPacketsSent = objInterface.UnicastPacketsSent
iInfo.lngNonunicastPacketsSent = objInterface.NonunicastPacketsSent
iInfo.lngDiscardedOutgoingPackets = objInterface.DiscardedOutgoingPackets
iInfo.lngOutgoingErrors = objInterface.OutgoingErrors
iInfo.lngOutputQueueLength = objInterface.OutputQueueLength
iInfo.lngBytesRecv = m_objIpHelper.BytesReceived
iInfo.lngBytesSent = m_objIpHelper.BytesSent
Set objInterface = Nothing
End Function
Private Sub ActivateMenu_Click()
Command1_Click
End Sub
Private Sub cboInterfaces_Click()
cboInterfaces.ToolTipText = cboInterfaces.Text
End Sub
Private Sub Command1_Click()
On Error GoTo ErrHandler
If Command1.Caption = "&Activate" Then
If cboInterfaces.ListIndex = -1 Then
MsgBox "Please choose an interface before activating the server.", vbExclamation
cboInterfaces.SetFocus
Exit Sub
End If
If Val(txtPort.Text) < 1 Or Val(txtPort.Text) > 65535 Then
MsgBox "Please enter a port between 1 and 65535.", vbExclamation
txtPort.SetFocus
txtPort.SelStart = 0
txtPort.SelLength = Len(txtPort.Text)
Exit Sub
End If
txtPort.Enabled = False
WSConnHandler.Close
WSConnHandler.LocalPort = Val(txtPort.Text)
WSConnHandler.Listen
Dim FNum As Integer
Dim AppPath As String
FNum = FreeFile
AppPath = App.Path
If Right(AppPath, 1) <> "\" Then AppPath = AppPath + "\"
Open AppPath + "nsws.html" For Input As #FNum
strFileBuffer = Input(LOF(FNum), FNum)
Close #FNum
SysTray.IconHandle = pSysTrayIcon1
SysTray.TipText = "NSWS " + Ver + " - Active"
Command1.Caption = "De&activate"
Else
WSConnHandler.Close
txtPort.Enabled = True
SysTray.IconHandle = pSysTrayIcon2
SysTray.TipText = "NSWS " + Ver + " - Inactive"
Command1.Caption = "&Activate"
If WSArray.UBound > 0 Then
Dim i As Integer
For i = WSArray.UBound To 1 Step -1
Unload WSArray(i)
Unload TimeoutTimer(i)
Next i
End If
End If
Exit Sub
ErrHandler:
MsgBox "The following error occurred while activating the server: " + Err.Description, vbCritical
WSConnHandler.Close
txtPort.Enabled = True
SysTray.IconHandle = pSysTrayIcon2
SysTray.TipText = "NSWS " + Ver + " - Inactive"
Command1.Caption = "&Activate"
End Sub
Private Sub Command2_Click()
Visible = False
End Sub
Private Sub Command3_Click()
Unload Me
End Sub
Private Sub ExitMenu_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dim objInterface As CInterface
Dim bRegErr As Boolean
Dim lRegData As Long
Set m_objIpHelper = New CIpHelper
For Each objInterface In m_objIpHelper.Interfaces
cboInterfaces.AddItem objInterface.InterfaceDescription
Next objInterface
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, RegAppRoot, "Interface Index", bRegErr)
If (lRegData < 0 Or lRegData > cboInterfaces.ListCount - 1) Or bRegErr Then lRegData = 0
If cboInterfaces.ListCount > 0 Then cboInterfaces.ListIndex = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, RegAppRoot, "Port Number", bRegErr)
If (lRegData < 1 Or lRegData > 65535) Or bRegErr Then lRegData = 9445
txtPort.Text = lRegData
If GetRegString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run\", "NSWS") <> "" Then StartupMenu.Checked = True
Ver = App.Major & "." & App.Minor & IIf(App.Revision = 0, "", "." & App.Revision)
Caption = "Network Statistics WebServer (NSWS " + Ver + ")"
SysTray.PopUpMessage = "NSWS " + Ver + " - Inactive"
Set pSysTrayIcon1 = LoadResPicture(100, 1)
Set pSysTrayIcon2 = LoadResPicture(101, 1)
SysTray.Initialize hWnd, pSysTrayIcon2, SysTray.PopUpMessage
SysTray.ShowIcon
If Command = "-startup" Then
Visible = False
Command1_Click
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim msgCallBackMessage As Long
msgCallBackMessage = X / Screen.TwipsPerPixelX
Select Case msgCallBackMessage
Case WM_LBUTTONDBLCLK
Visible = True
Case WM_RBUTTONDOWN
If Visible Then
OpenMenu.Caption = "&Hide"
Else
OpenMenu.Caption = "&Show"
End If
ActivateMenu.Caption = Command1.Caption
PopupMenu SysTrayMenu, , , , OpenMenu
End Select
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If UnloadMode = 0 Or UnloadMode = 3 Then
Visible = False
Cancel = True
Exit Sub
End If
WSConnHandler.Close
SysTray.HideIcon
Set pSysTrayIcon1 = Nothing
Set pSysTrayIcon2 = Nothing
Set m_objIpHelper = Nothing
SaveRegDWORD HKEY_LOCAL_MACHINE, RegAppRoot, "Interface Index", CLng(cboInterfaces.ListIndex)
SaveRegDWORD HKEY_LOCAL_MACHINE, RegAppRoot, "Port Number", CLng(Val(txtPort.Text))
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub OpenMenu_Click()
Visible = Not Visible
End Sub
Private Sub StartupMenu_Click()
StartupMenu.Checked = Not StartupMenu.Checked
If StartupMenu.Checked Then
SaveRegString HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run\", "NSWS", LCase(App.Path + IIf(Right(App.Path, 1) <> "\", "\", "")) + App.EXEName + ".exe -startup"
Else
DeleteValue HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run\", "NSWS"
End If
End Sub
Private Sub TimeoutTimer_Timer(Index As Integer)
WSArray(Index).Close
Unload WSArray(Index)
Unload TimeoutTimer(Index)
End Sub
Private Sub txtPort_KeyPress(KeyAscii As Integer)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then Exit Sub
KeyAscii = 0
End Sub
Private Sub txtPort_LostFocus()
txtPort.Text = Val(txtPort.Text)
End Sub
Private Sub WSArray_Close(Index As Integer)
WSArray(Index).Close
Unload WSArray(Index)
Unload TimeoutTimer(Index)
End Sub
Private Sub WSArray_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim RecvData As String
Dim iInfo As INTERFACE_INFO
Dim strBuffer As String
Dim strArray() As String
Dim memoryInfo As MEMORYSTATUS
WSArray(Index).GetData RecvData
If Left(RecvData, 4) <> "GET " Then
WSArray(Index).Close
Unload WSArray(Index)
Unload TimeoutTimer(Index)
Exit Sub
End If
strArray = Split(RecvData, " ")
If strArray(1) <> "/" Then
strBuffer = "HTTP/1.1 301 Moved Permanently" & vbCrLf & _
"Server: NSWS/" & Ver & vbCrLf & _
"Connection: Close" & vbCrLf & _
"Location: /" & vbCrLf & vbCrLf
WSArray(Index).SendData strBuffer
Exit Sub
End If
GlobalMemoryStatus memoryInfo
GetInterfaceInfo cboInterfaces.ListIndex + 1, iInfo
strBuffer = "HTTP/1.1 200 OK" & vbCrLf & _
"Server: NSWS/" & Ver & vbCrLf & _
"Connection: Close" & vbCrLf & _
"Content-Type: text/html" & vbCrLf & vbCrLf & strFileBuffer
strBuffer = Replace(strBuffer, "%LOCALHOST%", WSConnHandler.LocalHostName)
strBuffer = Replace(strBuffer, "%LOCALIP%", WSConnHandler.LocalIP)
strBuffer = Replace(strBuffer, "%INTERFACE_TYPE%", iInfo.strInterfaceType)
strBuffer = Replace(strBuffer, "%MTU%", CStr(iInfo.lngMaximumTransmissionUnit))
strBuffer = Replace(strBuffer, "%INTERFACE_SPEED%", CStr(Round(iInfo.lngSpeed / 1000000, 1)) + " Mbit")
strBuffer = Replace(strBuffer, "%ADAPTER_ADDRESS%", iInfo.strAdapterAddress)
strBuffer = Replace(strBuffer, "%ADMIN_STATUS%", iInfo.strAdminStatus)
strBuffer = Replace(strBuffer, "%OP_STATUS%", iInfo.strOperationalStatus)
strBuffer = Replace(strBuffer, "%OCTETS_RECV%", Trim(Format(iInfo.lngOctetsReceived, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%UNICAST_RECV%", Trim(Format(iInfo.lngUnicastPacketsReceived, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%NONUNICAST_RECV%", Trim(Format(iInfo.lngNonunicastPacketsReceived, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%RECV_DISCARDED%", Trim(Format(iInfo.lngDiscardedIncomingPackets, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%ERR_RECV%", Trim(Format(iInfo.lngIncomingErrors, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%UNKNOWN_RECV%", Trim(Format(iInfo.lngUnknownProtocolPackets, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%OCTETS_SENT%", Trim(Format(iInfo.lngOctetsSent, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%UNICAST_SENT%", Trim(Format(iInfo.lngUnicastPacketsSent, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%NONUNICAST_SENT%", Trim(Format(iInfo.lngNonunicastPacketsSent, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%SENT_DISCARDED%", Trim(Format(iInfo.lngDiscardedOutgoingPackets, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%ERR_SENT%", Trim(Format(iInfo.lngOutgoingErrors, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%BYTES_RECV%", Trim(Format(iInfo.lngBytesRecv, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%BYTES_SENT%", Trim(Format(iInfo.lngBytesSent, "###,###,###,###0")))
strBuffer = Replace(strBuffer, "%REMOTE_IP%", WSArray(Index).RemoteHostIP)
strBuffer = Replace(strBuffer, "%REMOTE_HOST%", WSArray(Index).RemoteHostIP)
strBuffer = Replace(strBuffer, "%REMOTE_PORT%", CStr(WSArray(Index).RemotePort))
strBuffer = Replace(strBuffer, "%UPTIME%", GetUpTime())
strBuffer = Replace(strBuffer, "%MEM_TOTAL%", Trim(Format(Round(memoryInfo.dwTotalPhys / 1043321, 0), "###,###,###,###0")) & " Mb")
strBuffer = Replace(strBuffer, "%MEM_FREE%", Trim(Format(Round(memoryInfo.dwAvailPhys / 1043321, 0), "###,###,###,###0")) & " Mb")
strBuffer = Replace(strBuffer, "%VIRTUAL_MEM_TOTAL%", Trim(Format(Round(memoryInfo.dwTotalVirtual / 1043321, 0), "###,###,###,###0")) & " Mb")
strBuffer = Replace(strBuffer, "%VIRTUAL_MEM_FREE%", Trim(Format(Round(memoryInfo.dwAvailVirtual / 1043321, 0), "###,###,###,###0")) & " Mb")
strBuffer = Replace(strBuffer, "%APPVER%", Ver)
WSArray(Index).SendData strBuffer
End Sub
Private Sub WSArray_Error(Index As Integer, 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)
If Number = sckBadState Then
WSArray(Index).Close
Unload WSArray(Index)
Unload TimeoutTimer(Index)
End If
End Sub
Private Sub WSArray_SendComplete(Index As Integer)
WSArray(Index).Close
Unload WSArray(Index)
Unload TimeoutTimer(Index)
End Sub
Private Sub WSConnHandler_ConnectionRequest(ByVal requestID As Long)
If WSArray.UBound < 100 Then
Load WSArray(WSArray.UBound + 1)
WSArray(WSArray.UBound).LocalPort = 0
WSArray(WSArray.UBound).Accept requestID
Load TimeoutTimer(WSArray.UBound)
TimeoutTimer(WSArray.UBound).Enabled = True
End If
End Sub