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内容请搜索我们以前的文章或继续浏览下面的相关文章希望大家以后多多支持我们!
赞 (0)