简单介绍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的项目实现的全部内容。
THE END
分享
二维码
< <上一篇
下一篇>>