VBS 批量Ping的项目实现
本文用vb编写的 ping程序实现，具体如下：
"判断当前VBS脚本是否由CScript执行
If InStr(LCase(WScript.FullName), "cscript.exe") = 0 Then
"若不是由CScript执行，则使用CScript重新执行当前脚本
Set objShell = CreateObject("Shell.Application")
objShell.ShellExecute "cscript.exe", """" & WScript.ScriptFullName & """", , , 1
WScript.Quit "退出当前程序
End If
"----------------------------------------------------------------------------------------------
Set objFSO = CreateObject("Scripting.FileSystemObject")
"创建日志文件
Set fileLog = objFSO.CreateTextFile("Ping运行结果(" &_
Year(Now()) & "-" & Month(Now()) & "-" & Day(Now()) & " " &_
Hour(Now()) & "-" & Minute(Now()) & "-" & Second(Now()) & ").txt", True)
"----------------------------------------------------------------------------------------------
"Ping 方案类
Class PingScheme
Public Address "目标地址
Public DisconnectionCount "断线计数
End Class
Dim dicPingScheme "配置方案集合
Set dicPingScheme = CreateObject("Scripting.Dictionary")
Dim strPingQuery "Ping查询条件语句
strPingQuery = Null
"添加Ping方案到方案集合
Public Sub AddPingScheme ( addr )
Set newPingScheme = New PingScheme
newPingScheme.Address = addr
newPingScheme.DisconnectionCount = 0
dicPingScheme.Add addr, newPingScheme
"合成Ping查询条件语句
If IsNull( strPingQuery ) Then
strPingQuery = "Address="" & addr & """
Else
strPingQuery = strPingQuery & "OR Address="" & addr & """
End If
End Sub
"----------------------------------------------------------------------------------------------
AddPingScheme ( "8.8.8.8" )
AddPingScheme ( "8.8.4.4" )
AddPingScheme ( "192.168.1.8" )
"----------------------------------------------------------------------------------------------
Dim bEmailFlag "发送邮件标志
bEmailFlag = False
Const LoopInterval = 5000 "循环间隔
Dim strDisplay "显示缓存字符串
Dim strLog "日志文件缓存字符串
"连接WMI服务
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Do
strDisplay = "----" & Now & "----" & vbCrlf
strLog = ""
"通过WMI调用Ping命令，返回Ping执行结果集合
Set colPings = objWMIService.ExecQuery("SELECT * FROM Win32_PingStatus WHERE " & strPingQuery)
"遍历结果集合
For Each objPing in colPings
strLog = strLog & FormatDateTime(Now()) & vbTab &_
objPing.Address & vbTab & objPing.StatusCode & vbTab
strDisplay = strDisplay & "[" & objPing.Address & "] - "
Select Case objPing.StatusCode
Case 0
strDisplay = strDisplay & objPing.ProtocolAddress &_
", Size: " & objPing.ReplySize &_
", Time: " & objPing.ResponseTime &_
", TTL: " & objPing.ResponseTimeToLive & vbCrlf
strLog = strLog & objPing.ProtocolAddress & vbTab & objPing.ReplySize & vbTab &_
objPing.ResponseTime & vbTab & objPing.ResponseTimeToLive
Case 11002
strDisplay = strDisplay & "目标网络不可达" & vbCrlf
strLog = strLog & "目标网络不可达"
Case 11003
strDisplay = strDisplay & "目标主机不可达 " & vbCrlf
strLog = strLog & "目标主机不可达"
Case 11010
strDisplay = strDisplay & "等待超时" & vbCrlf
strLog = strLog & "等待超时"
Case Else
If IsNull(objPing.StatusCode) Then
strDisplay = strDisplay & "找不到主机 " & objPing.Address & vbCrlf
strLog = strLog & "找不到主机 " & objPing.Address
Else
strDisplay = strDisplay & "错误：" & objPing.StatusCode & vbCrlf
strLog = strLog & "错误：" & objPing.StatusCode
End If
End Select
strLog = strLog & vbCrlf
"判断 Ping返回结果是否执行成功
If objPing.StatusCode <> 0 Then
"若不成功 将相应的 DisconnectionCount 加 1
dicPingScheme(objPing.Address).DisconnectionCount = dicPingScheme(objPing.Address).DisconnectionCount + 1
"DisconnectionCount = 10 时 置位 发送邮件标志
If dicPingScheme(objPing.Address).DisconnectionCount = 10 Then
bEmailFlag = True
End If
Else
"若成功 将相应的 DisconnectionCount 清零
dicPingScheme(objPing.Address).DisconnectionCount = 0
End If
Next
"输出显示
PrintLine strDisplay
"保存日志
fileLog.WriteLine strLog
"如果 发送邮件标志 被置位 清除标志 并 发送邮件
If bEmailFlag = True Then
bEmailFlag = False "清除 标志
SendEmail "设备断线 " & Now, strDisplay
End If
"挂起指定时间，暂停
WScript.Sleep(LoopInterval)
Loop
"---------------------------------------------------------------------------------------
"标准输出
Public Sub Print ( tmp )
WScript.StdOut.Write tmp
End Sub
"标准输出以换行符结尾
Public Sub PrintLine ( tmp )
WScript.StdOut.Write tmp & vbCrlf
End Sub
"---------------------------------------------------------------------------------------
"发送邮件
Public Sub SendEmail(title, textbody)
Set objCDO = CreateObject("CDO.Message")
objCDO.Subject = title
objCDO.From = "XXX@qq.com"
objCDO.To = "XXX@qq.com"
objCDO.TextBody = textbody
cdoConfigPrefix = "http://schemas.microsoft.com/cdo/configuration/"
Set objCDOConfig = objCDO.Configuration
With objCDOConfig
.Fields(cdoConfigPrefix & "smtpserver") = "smtp.qq.com"
.Fields(cdoConfigPrefix & "smtpserverport") = 465
.Fields(cdoConfigPrefix & "sendusing") = 2
.Fields(cdoConfigPrefix & "smtpauthenticate") = 1
.Fields(cdoConfigPrefix & "smtpusessl") = true
.Fields(cdoConfigPrefix & "sendusername") = "XXX"
.Fields(cdoConfigPrefix & "sendpassword") = "XXX"
.Fields.Update
End With
objCDO.Send
Set objCDOConfig = Nothing
Set objCDO = Nothing
End Sub到此这篇关于VBS 批量Ping的项目实现的文章就介绍到这了,更多相关VBS 批量Ping内容请搜索脚本之家以前的文章或继续浏览下面的相关文章希望大家以后多多支持脚本之家！
X 关闭
X 关闭