簡單介紹VBS 批次Ping的專案實現

導讀	本文主要介紹了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        = "
 
    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的專案實現的文章就介紹到這了。

原文來自：