VBS 批量Ping
技术员puc 人气:0本文用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加载全部内容