Команда ping в excel

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

Function PingResponseTimeEx(ByVal ComputerName$, Optional ByVal BufferSize As Long = 1024) As Long
     
    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
   
    If txt Then WriteFile txt
   
End Function
 
Function WriteFile(txt)
  Dim oFSO, oFile
  Set oFSO = CreateObject("Scripting.FileSystemObject")
  Set oFile = oFSO.CreateTextFile(oFSO.BuildPath("C:", "test.txt"))
  oFile.Write txt
  oFile.Close: Set oFile = Nothing
  Set oFSO = Nothing
  Set oFile = Nothing
End Function
 
Sub TestPingFunction()
    PingResponseTimeEx ("google.ru")
    MsgBox "Тестирование канала связи закончено! Спасибо!"
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

    Dim oOutlook As Outlook.Application         'Приложение Outlook
    Dim oItem As Outlook.MailItem               'Письмо
    
    'Проверяем, запущен ли Outlook,  если нет - запускаем
    If GetObject("winmgmts:\.rootcimv2").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

1

        .To = "<Адрес отправителя>"

1

        .To = "<Адрес получателя>"

1
2

Sub SendMail(Region As String)
    Dim oOutlook As Outlook.Application

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42

Sub ImportTextFiles()
   Dim fsSearch As FileSearch
   Dim strFileName As String
   Dim strPath As String
   Dim i As Integer
 
   ' Задание пути и возможного имени файла
   strFileName = ThisWorkbook.Path & "C:"
   strPath = "test??.txt"
 
   ' Создание объекта FileSearch
   Set fsSearch = Application.FileSearch
   ' Настройка объекта для поиска
   With fsSearch
      ' Маска для поиска
      .LookIn = strFileName
      ' Путь для поиска
      .FileName = strPath
      ' Поиск всех файло удовлетворяющих условиям поиска
      .Execute
      ' если файл не существует, то выход
      If .FoundFiles.Count = 0 Then
         MsgBox "Файлы не обнаружены"
         Exit Sub
      End If
   End With
   ' Обрабатываем найденые файлы
   For i = 1 To fsSearch.FoundFiles.Count
      Call ImportTextFile(fsSearch.FoundFiles(i))
   Next i
End Sub
 
Sub ImportTextFile(FileName As String)
   ' Импорт файла
   Workbooks.OpenText FileName:=FileName, _
    Origin:=xlWindows, _
    StartRow:=1, _
    DataType:=xlFixedWidth, _
    FieldInfo:= _
    Array(Array(0, 1), Array(3, 1), Array(12, 1))
 
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86

Option Explicit
 
Const sPath As String = "C:"                       'Путь к файлу
Const sFileName As String = "test.txt"              'Имя файла
Const sPingAddress As String = "sudir.ca.sbrf.ru"   'Пингуемый адрес
Const sMailTo As String = "starostin-dt@mail.ca.sbrf.ru" 'Адрес эл.почты получателя
 
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 & (i & "; " & "Time: " & oPingResult.ResponseTime & "; ") & vbCrLf
                Else
                   txt = txt & (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 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
 
 
Sub TestPingFunction()
    Dim sRegion As String           'Область и город
    Dim sResponse As String         'Ответ Ping
    
    sRegion = Cells(3, 3) & ";" & Cells(5, 3)
    sResponse = PingResponseTimeEx(sPingAddress)
    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:\.rootcimv2").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

1
2

Dim oFSO as Object
Set oFSO = CreateObject("Scripting.FileSystemObject")

1
2

Dim oFSO as Scripting.FileSystemObject 
Set oFSO as New Scripting.FileSystemObject