Imports System.Net
Imports System.IO
Imports System.Data
Imports System.Data.OleDb
Imports System.ComponentModel
Imports System.Xml
Imports System.Threading
Imports Microsoft.VisualBasic
Imports System.ServiceProcess
Imports System.Management
Imports System.Net.Sockets
Imports System.Text
Public Class MyService
Inherits System.ServiceProcess.ServiceBase
Public N As Integer
Public A(9) As String
Dim BStart As Boolean = False
Public SaveNum As Integer
Dim MustThred As Thread
Public FDir As String = "F:\winForm\WinAutoDetect\bin\Log"
Public myListerner As TcpListener
Public port As Integer = 4554
Public strAd As String = "123456"
Dim th As Thread
#Region " 组件设计器生成的代码 "
Public Sub New()
MyBase.New()
" 该调用是组件设计器所必需的。
InitializeComponent()
" 在 InitializeComponent() 调用之后添加任何初始化
End Sub
"UserService 重写 dispose 以清理组件列表。
Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
If disposing Then
If Not (components Is Nothing) Then
components.Dispose()
End If
End If
MyBase.Dispose(disposing)
End Sub
" 进程的主入口点
_
Shared Sub Main()
Dim ServicesToRun() As System.ServiceProcess.ServiceBase
" 在同一进程中可以运行不止一个 NT 服务。若要将
" 另一个服务添加到此进程，请更改下行以
" 创建另一个服务对象。例如，
"
" ServicesToRun = New System.ServiceProcess.ServiceBase () {New Service1, New MySecondUserService}
"
ServicesToRun = New System.ServiceProcess.ServiceBase() {New MyService}
System.ServiceProcess.ServiceBase.Run(ServicesToRun)
End Sub
"组件设计器所必需的
Private components As System.ComponentModel.IContainer
"注意: 以下过程是组件设计器所必需的
" 可以使用组件设计器修改此过程。
" 不要使用代码编辑器修改它。
Private Sub InitializeComponent()
components = New System.ComponentModel.Container
Me.ServiceName = "Service1"
End Sub
#End Region
Protected Overrides Sub OnStart(ByVal args() As String)
N = 1000
Dim Src As String
Src = "C:\Windows\Setup.Xml"
If File.Exists(Src) Then
Dim Myt As New DataSet
Myt.ReadXml(Src)
Dim I As Integer
For I = 1 To 9
A(I) = Myt.Tables(0).Rows(0)("Setup" + I.ToString)
Next
FDir = A(1)
End If
XcModelInfo("系统开始运行", 3)
port = CInt(A(8))
strAd = A(9)
BStart = True
MustThred = New Thread(AddressOf Me.GoDetectInfo)
MustThred.Start()
"###################################################3
DateServer()
End Sub
Protected Overrides Sub OnStop()
" 在此处添加代码以执行停止服务所需的关闭操作。
Try
If BStart = True Then
MustThred.Abort()
End If
XcModelInfo("系统关闭运行", 3)
If Not myListerner Is Nothing Then
myListerner.Stop()
End If
th.Abort()
Me.Dispose()
Catch ex As Exception
End Try
End Sub
Public Sub GoDetectInfo()
Dim i As Integer
Dim Bb As Boolean
If CheckURL(A(2)) Then
XcModelInfo("〖系统开始正常检测，欢迎您的使用〗", 1)
Bb = True
Do While Bb
If CheckURL(A(2)) Then
XcModelInfo("〖主机正常〗", 1)
Else
XcModelInfo("〖主机关闭〗", 2)
SaveNum += 1
If SaveNum >= 5 Then
"停止
Bb = False
"Me.Dispose()
Else
Dim B As Boolean
B = XcSendEmailToUser(A(6), "服务器异常", "服务器异常，请仔细查看！")
If B = False Then
XcModelInfo("〖主机异常，发送Email失败！〗", 2)
Else
XcModelInfo("〖主机异常，发送Email成功！〗", 2)
End If
End If
End If
System.Threading.Thread.Sleep(CInt(A(7)))
Loop
Else
XcModelInfo("〖系统运行失败失败，远程地址错误！〗", 2)
End If
End Sub
Public Function XcModelInfo(ByVal BInfo As String, ByVal Bzt As Integer) As String
"Dim L As System.Windows.Forms.ListViewItem
Dim Tstr, BG, ZTB, NN As String
NN = N
Tstr = Now.ToString
Dim k(3), APath, FileName, Vp, TMP As String
APath = A(1)
k(1) = "\True\"
k(2) = "\Error\"
k(3) = "\SendInfo\"
FileName = Now.ToShortDateString.Replace(" ", "").Replace("-", "").Replace(":", "")
Vp = APath + k(Bzt) + FileName + ".txt"
TMP = "〖" + Tstr + "〗 " + BInfo + Chr(13) + Chr(10)
FileWriteReal(Vp, TMP)
"#################################################
End Function
Public Function XcSendEmailToUser(ByVal UEMail As String, ByVal Title As String, ByVal Info As String) As Boolean
Try
"-----------------------------------------
Dim EFrom, EName, EPwd, ESMTP As String
Dim MyT As New DataSet
Dim XcSoft As String
XcSoft = "公司服务器运行问题"
Dim EPath, Fname As String
EPath = FDir + "\MeEmail.xml"
Fname = EPath
If File.Exists(Fname) Then
MyT.ReadXml(Fname)
EFrom = A(3)
EName = A(3)
EPwd = A(4)
ESMTP = A(5)
Else
EFrom = "quzefeng@0451sky.com"
EName = "quzefeng@0451sky.com"
EPwd = "0451sky"
ESMTP = "smtp.0451sky.com"
End If
MyT.Dispose()
"-----------------------------------------
Dim JMail As New jmail.Message
Dim T As DateTime = Now()
Dim SubJect, Body, FromEmail, ToEmail As String
SubJect = Title
Body = Info + "
时间：" + Now.ToString
FromEmail = EFrom
ToEmail = UEMail
JMail.Silent = True
JMail.FromName = XcSoft
JMail.Logging = True
JMail.Charset = "GB2312"
JMail.ContentType = "text/html"
JMail.AddRecipient(ToEmail, "", "")
JMail.From = FromEmail
JMail.MailServerUserName = EName
JMail.MailServerPassWord = EPwd
JMail.Subject = SubJect
JMail.Body = Body
JMail.Priority = 1
Dim flag As Boolean
flag = JMail.Send(ESMTP)
JMail.Close()
XcSendEmailToUser = flag
Catch ex As Exception
XcSendEmailToUser = False
End Try
End Function
Public Function CheckURL(ByVal A_strUrl As String) As Boolean
"---------------------返回是否存在
Try
Dim XMLHTTP As Object
XMLHTTP = CreateObject("Microsoft.XMLHTTP")
XMLHTTP.open("HEAD", A_strUrl, False)
XMLHTTP.send()
CheckURL = (XMLHTTP.status = 200)
XMLHTTP = Nothing
Catch ex As Exception
" MsgBox(ex.ToString, MsgBoxStyle.Information, "系统提示")
End Try
End Function
Public Function FileWriteReal(ByVal RealName As String, ByVal SInfo As String) As Boolean
Dim FName As String
FName = RealName
"MsgBox(FName + SInfo)
Dim RetBoolean As Boolean
Try
Dim MyStream As StreamWriter
If File.Exists(FName) Then
MyStream = New StreamWriter(FName, True, System.Text.Encoding.Default)
Else
MyStream = New StreamWriter(FName, True, System.Text.Encoding.Default)
End If
MyStream.Write(SInfo)
MyStream.Close()
RetBoolean = True
Catch ex As Exception
RetBoolean = False
End Try
FileWriteReal = RetBoolean
End Function
Public Function ShowPara(ByVal i As Integer) As String
" "强制重启(DosCommand("shutdown", "/f /r"))
" "强制关机(DosCommand("shutdown", "/f /s"))
" "强制注销(DosCommand("shutdown", "/f /l"))
Dim S As String
S = "执行命令:" + i.ToString
If i = 1 Then
S = DosCommand("shutdown", "/f /l")
ElseIf i = 2 Then
S = DosCommand("shutdown", "/f /r")
ElseIf i = 3 Then
S = DosCommand("shutdown", "/f /s")
ElseIf i = 4 Then
S = Now.ToString
ElseIf i = 5 Then
S = mewwwGetIP()
ElseIf i = 6 Then
S = MewwwGetMac()
End If
ShowPara = S
End Function
Private Function DosCommand(ByVal Str_Command As String, ByVal Str_Arguments As String) As String
Try
Dim Obj_Command As ProcessStartInfo = New ProcessStartInfo
Dim Pro_Lob As Process = New Process
Obj_Command.FileName = Str_Command
Obj_Command.RedirectStandardInput = True
Obj_Command.RedirectStandardOutput = True
Obj_Command.RedirectStandardError = True
Obj_Command.CreateNoWindow = True
Obj_Command.UseShellExecute = False
Obj_Command.Arguments = Str_Arguments
Pro_Lob = Process.Start(Obj_Command)
DosCommand = Pro_Lob.ToString
Pro_Lob.Dispose()
Catch ex As Exception
DosCommand = ex.ToString
End Try
End Function
Private Function mewwwGetIP() As String
Dim StrHostName, IP As String
StrHostName = ""
" 首先得到本地机器的主机名称
StrHostName = Dns.GetHostName.ToString
" 然后通过主机名称得到IP地址列表
Dim ipEntry As IPHostEntry = Dns.GetHostByName(StrHostName)
Dim Addr() As IPAddress
Addr = ipEntry.AddressList
Dim I As Integer
For I = 0 To Addr.Length - 1
IP += Addr(I).ToString + "@"
Next
mewwwGetIP = IP
End Function
Private Function MewwwGetMac() As String
MewwwGetMac = "Mac:Nothing"
Dim Mac As String
Dim mc As ManagementClass
mc = New ManagementClass("Win32_NetworkAdapterConfiguration")
Dim Moc2 As ManagementObjectCollection = mc.GetInstances
Dim mo As ManagementObject
For Each mo In Moc2
If CBool(mo("IPEnabled")) = True Then
Mac += mo("MacAddress").ToString + "@"
End If
Next
mo.Dispose()
mc.Dispose()
Moc2.Dispose()
MewwwGetMac = Mac
End Function
Public Sub DateServer()
Try
Dim ip As IPAddress = Dns.Resolve(Dns.GetHostName).AddressList(0)
myListerner = New TcpListener(ip, port)
myListerner.Start()
XcModelInfo("服务器启动检测,监测端口:" + port.ToString + " 监测IP:" + ip.ToString, 3)
th = New Thread(New ThreadStart(AddressOf StartLister))
th.Start()
Catch ex As Exception
XcModelInfo("服务器启动检测失败:" + ex.ToString, 3)
End Try
End Sub
Private Sub StartLister()
While True
Dim mySocket As Socket
mySocket = myListerner.AcceptSocket
If mySocket.Connected Then
XcModelInfo("有客户连接服务器", 3)
Dim receive(1024) As Byte
Dim i As Integer
i = mySocket.Receive(receive, receive.Length, SocketFlags.None)
Dim rece As String
rece = System.Text.Encoding.Unicode.GetString(receive, 0, i)
rece = rece.Trim().Trim(Chr(13)).Trim(Chr(10)).Trim(Chr(9)).Trim(" ")
XcModelInfo("客户连接使用参数:" + rece.ToString, 3)
Dim strDateLine As String
strDateLine = StrPara(rece)
Dim byted(1024) As Byte
byted = Encoding.Unicode.GetBytes(strDateLine.ToCharArray)
mySocket.Send(byted, byted.Length, SocketFlags.None)
mySocket.Close()
End If
End While
End Sub
Public Function StrPara(ByVal str As String) As String
Dim s, ret As String
str = str.ToLower
s = strAd.ToLower
If String.Compare(str, s.ToString + "1") = 0 Then
ret = ShowPara(1)
ElseIf String.Compare(str, s.ToString + "2") = 0 Then
ret = ShowPara(2)
ElseIf String.Compare(str, s.ToString + "3") = 0 Then
ret = ShowPara(3)
ElseIf String.Compare(str, s.ToString + "4") = 0 Then
ret = ShowPara(4)
ElseIf String.Compare(str, s.ToString + "5") = 0 Then
ret = ShowPara(5)
ElseIf String.Compare(str, s.ToString + "6") = 0 Then
ret = ShowPara(6)
Else
ret = str
End If
StrPara = ret
End Function
End Class