简单介绍VBS 批量Ping的项目实现

共计 4395 个字符，预计需要花费 11 分钟才能阅读完成。

本文用 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 的项目实现的文章就介绍到这了。

阿里云 2 核 2G 服务器 3M 带宽 61 元 1 年，有高配

腾讯云新客低至 82 元 / 年，老客户 99 元 / 年

代金券：在阿里云专用满减优惠券