Запуск ping с параметрами n и l и последующей отправкой инфо на email

    Dim oOutlook As Outlook.Application         'Приложение Outlook
    Dim oItem As Outlook.MailItem               'Письмо
    
    'Проверяем, запущен ли Outlook,  если нет - запускаем
    If GetObject("winmgmts:\\.\root\cimv2").ExecQuery(_
        "SELECT * FROM Win32_Process WHERE Name='Outlook.exe'").Count = 0 Then Shell ("outlook")
    
    'Присваиваем переменную и создаем новое письмо
    Set oOutlook = New Outlook.Application
    Set oItem = oOutlook.CreateItem(olMailItem)
    
    'Вводим параметры письма
    With oItem
        .To = "<Адрес отправителя>"
        .Subject = "<Тема письма>"
        .Body = "<Содержание письма>"
        .Attachments.Add ("<Путь к файлу>")
        'Отправляем (можно сделать ".Display" вместо ".Send", 
        'чтобы проверить параметры и отправить письмо руками.
        .Send
    End With

Option Explicit
 
Const sPath As String = "C:\"                       'Путь к файлу
Const sFileName As String = "test.txt"              'Имя файла
Const sPingAddress As String = "google.ru"          'Пингуемый адрес
Const sMailTo As String = "Person@mail.com"         'Адрес эл.почты получателя
 
Function PingResponseTimeEx(ByVal ComputerName$, Optional ByVal BufferSize As Long = 1024) As String
    Dim i As Integer
    Dim txt As String
    
    Dim oPingResult As Variant: PingResponseTimeEx = -1: On Error Resume Next
       
    For i = 1 To 10
        For Each oPingResult In GetObject("winmgmts://./root/cimv2").ExecQuery _
            ("SELECT * FROM Win32_PingStatus WHERE Address = '" & ComputerName & "' and BufferSize = " & BufferSize)
            If IsObject(oPingResult) Then
                If oPingResult.StatusCode = 0 Then
                   txt = txt & (ComputerName$ & ": " & BufferSize & "; Step: " & i & "; " & "Time: " & oPingResult.ResponseTime & "; ") & vbCrLf
                Else
                   txt = txt & (ComputerName$ & ": " & BufferSize & "; Step: " & i & "; " & "Error: " & oPingResult.StatusCode & "; ") & vbCrLf
                End If
              End If
        Next
    Next i
    
    PingResponseTimeEx = txt
End Function
 
 
Sub WriteFile(txt As String, Region As String)
    Dim oFSO, oFile
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFile = oFSO.CreateTextFile(oFSO.BuildPath(sPath, sFileName))
    oFile.writeline Region
    oFile.write txt
    oFile.Close
    Set oFile = Nothing
    Set oFSO = Nothing
End Sub
 
Sub TestPingFunction()
    Dim sRegion As String           'Область и город
    Dim sResponse As String         'Ответ Ping
    
    sRegion = Me.Cells(2, 1) & ";" & Me.Cells(2, 2)
    sResponse = PingResponseTimeEx(PingAddress)
    WriteFile sResponse, sRegion
    SendMail sRegion
    MsgBox "Тестирование канала связи закончено! Спасибо!"
End Sub
 
Sub SendMail(Region As String)
    Dim oOutlook As Outlook.Application         'Приложение Outlook
    Dim oItem As Outlook.MailItem               'Письмо
    
    'Проверяем, запущен ли Outlook,  если нет - запускаем
    If GetObject("winmgmts:\\.\root\cimv2").ExecQuery("SELECT * FROM Win32_Process WHERE Name='Outlook.exe'").Count = 0 Then Shell ("outlook")
    
    'Присваиваем переменную и создаем новое письмо
    Set oOutlook = New Outlook.Application
    Set oItem = oOutlook.CreateItem(olMailItem)
    
    'Вводим параметры письма
    With oItem
        .To = sMailTo
        .Subject = Region
        .Attachments.Add (sPath & sFileName)
        'Отправляем (можно сделать ".Display" вместо ".Send",
        'чтобы проверить параметры и отправить письмо руками)
        'Письмо отправляется пустым (не задано свойство .Body)
        .Send
    End With
End Sub

Sub WriteFile(txt As String, Region As String)
    Dim oFSO, oFile
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFile = oFSO.CreateTextFile(oFSO.BuildPath(sPath, sFileName & Format(Now, "YYYY.MM.DD-hh.mm.ss") & ".txt)
    oFile.writeline Region
    oFile.write txt
    oFile.Close
    Set oFile = Nothing
    Set oFSO = Nothing
End Sub

Option Explicit
 
Const sName_wsParce As String = "Parce"
Const sPath_Parce As String = "Q:\temp\"
Const sFile_Name As String = "test"
 
Sub ParceFiles()
    Dim oFSO As Scripting.FileSystemObject
    Dim wsParce As Worksheet
    Dim sFilePath As String
    Dim oTxtFile As Scripting.TextStream
    Dim sContent As String
    Dim vRow
    Dim asRows() As String
    Dim asColumns() As String
    Dim sRegion As String
    Dim sTown As String
    Dim bHead As Boolean
    Dim i As Long
    
    Set oFSO = New FileSystemObject
    Set wsParce = ActiveWorkbook.Sheets(sName_wsParce)
    'Çàâîäèì êðèòåðèè ïîèñêà è áåðåì ïóòü ïåðâîãî ôàéëà, óäîâëåòâîðÿþùåãî êðèòåðèÿì
    sFilePath = Dir(sPath_Parce & sFile_Name & "*.txt")
     
    With wsParce
        '×èñòèì
        .Cells.ClearContents
        'Ïèøåì çàãîëîâêè
        .Cells(1, 1) = "Ðåãèîí"
        .Cells(1, 2) = "Ãîðîä"
        .Cells(1, 3) = "Ñåðâåð"
        .Cells(1, 4) = "Êîìïüþòåð"
        .Cells(1, 5) = "¹ ïîïûòêè"
        .Cells(1, 6) = "Çàäåðæêà"
        
        i = 2
        'Îáõîäèì âñå ôàéëû, óäîâëåòâîðÿþùèå êðèòåðèÿì
        Do Until Len(sFilePath) = 0
            'Îòêðûâàåì ôàéë
            Set oTxtFile = oFSO.OpenTextFile(sPath_Parce & sFilePath)
            'Çàïèñûâàåì âñþ èíôîðìàöèþ èç ôàéëà â òåêñòîâóþ ïåðåìåííóþ
            sContent = oTxtFile.ReadAll
            'Ðàçäåëÿåì ñòðîêè ïî çíàêàì ïåðåíîñà êàðåòêè
            asRows = Split(sContent, vbCrLf)
            
            bHead = True
            For Each vRow In asRows
                'Ðàçäåëÿåì ñòîëáöû ïî çíàêó ";"
                If Not CStr(vRow) = "" Then
                    asColumns = Split(vRow, ";")
                    If bHead Then
                        '×èòàåì ïåðâóþ ñòðîêó ôàéëà êàê åãî çàãîëîâîê, çàïèñûâàåì äàííûå â ïåðåìåííûå
                        sRegion = asColumns(1)
                        sTown = asColumns(0)
                    Else
                        '×èòàåì ïîñëåäóþùèå ñòðîêè êàê çàïèñè ñ äàííûìè, ïèøåì èõ íà ëèñò
                        .Cells(i, 1) = sRegion
                        .Cells(i, 2) = sTown
                        .Cells(i, 3) = Split(asColumns(0), ":")(0)
                        .Cells(i, 4) = Split(asColumns(0), ":")(1)
                        .Cells(i, 5) = Split(asColumns(1), ":")(1)
                        .Cells(i, 6) = Split(asColumns(2), ":")(1)
                        i = i + 1
                    End If
                    
                    bHead = False
                End If
            Next vRow
            
            'Áåðåì ïóòü ñëåäóþùåãî ôàéëà, óäîâëåòâîðÿþåãî ââåäåííûì âûøå êðèòåðèÿì
            sFilePath = Dir
        Loop
    End With
End Sub

Option Explicit
 
Dim oFSO As Object
 
Const sFileName As String = "test"                  'Èìÿ ôàéëà
Const sPath As String = "C:\"                  'Ïóòü ê ôàéëó
Const sPingAddress As String = "google.ru"          'Ïèíãóåìûé àäðåñ
Const sMailTo As String = "Person@mail.com"         'Àäðåñ ýë.ïî÷òû ïîëó÷àòåëÿ
 
Function PingResponseTimeEx(ByVal ComputerName$, Optional ByVal BufferSize As Long = 1024) As String
    Dim i As Integer
    Dim txt As String
    
    Dim oPingResult As Variant: PingResponseTimeEx = -1: On Error Resume Next
       
    For i = 1 To 10
        For Each oPingResult In GetObject("winmgmts://./root/cimv2").ExecQuery _
            ("SELECT * FROM Win32_PingStatus WHERE Address = '" & ComputerName & "' and BufferSize = " & BufferSize)
            If IsObject(oPingResult) Then
                If oPingResult.StatusCode = 0 Then
                   txt = txt & (ComputerName$ & ": " & BufferSize & "; Step: " & i & "; " & "Time: " & oPingResult.ResponseTime & "; ") & vbCrLf
                Else
                   txt = txt & (ComputerName$ & ": " & BufferSize & "; Step: " & i & "; " & "Error: " & oPingResult.StatusCode & "; ") & vbCrLf
                End If
              End If
        Next
    Next i
    
    PingResponseTimeEx = txt
End Function
 
 
Sub WriteFile(txt As String, Region As String, Path As String)
    Dim oFile As Object
    
    Set oFile = oFSO.CreateTextFile(Path)
    oFile.writeline Region
    oFile.write txt
    oFile.Close
    Set oFile = Nothing
    Set oFSO = Nothing
End Sub
 
 
Sub TestPingFunction()
    Dim sRegion As String           'Îáëàñòü è ãîðîä
    Dim sResponse As String         'Îòâåò Ping
    Dim sFullPath As String         'Ïîëíûé ïóòü ê ôàéëó
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    
    'Ôîðìèðóåì èìÿ ôàéëà
    sFullPath = oFSO.BuildPath(sPath, sFileName & " " & Format(Now, "YYYY.MM.DD-hh.mm.ss") & ".txt")
    
    sRegion = Me.Cells(2, 1) & ";" & Me.Cells(2, 2)
    sResponse = PingResponseTimeEx(sPingAddress)
    WriteFile sResponse, sRegion, sFullPath
    SendMail sRegion, sFullPath
    MsgBox "Òåñòèðîâàíèå êàíàëà ñâÿçè çàêîí÷åíî! Ñïàñèáî!"
End Sub
 
Sub SendMail(Region As String, Path As String)
    Dim oOutlook As Outlook.Application         'Ïðèëîæåíèå Outlook
    Dim oItem As Outlook.MailItem               'Ïèñüìî
    
    'Ïðîâåðÿåì, çàïóùåí ëè Outlook,  åñëè íåò - çàïóñêàåì
    If GetObject("winmgmts:\\.\root\cimv2").ExecQuery("SELECT * FROM Win32_Process WHERE Name='Outlook.exe'").Count = 0 Then Shell ("outlook")
    
    'Ïðèñâàèâàåì ïåðåìåííóþ è ñîçäàåì íîâîå ïèñüìî
    Set oOutlook = New Outlook.Application
    Set oItem = oOutlook.CreateItem(olMailItem)
    
    'Ââîäèì ïàðàìåòðû ïèñüìà
    With oItem
        .To = sMailTo
        .Subject = Region
        .Attachments.Add (Path)
        'Îòïðàâëÿåì (ìîæíî ñäåëàòü ".Display" âìåñòî ".Send",
        '÷òîáû ïðîâåðèòü ïàðàìåòðû è îòïðàâèòü ïèñüìî ðóêàìè)
        'Ïèñüìî îòïðàâëÿåòñÿ ïóñòûì (íå çàäàíî ñâîéñòâî .Body)
        .Send
    End With
End Sub