VBS 批量Ping的项目实现_vbs_

'判断当前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