Команда ping в excel

Public Function Ping(ByVal ComputerName As String) As Boolean
    ' возвращает TRUE, если пинг прошел
    Dim oPingResult As Variant
    For Each oPingResult In GetObject("winmgmts://./root/cimv2").ExecQuery _
        ("SELECT * FROM Win32_PingStatus WHERE Address = '" & ComputerName & "'")
        If IsObject(oPingResult) Then
            If oPingResult.StatusCode = 0 Then
                Ping = True        'Debug.Print "ResponseTime", oPingResult.ResponseTime
                Exit Function
            End If
        End If
    Next
End Function

Пример использования:

Sub TestPingFunction()
    If Ping("ComputerName") Then ПутьКПапке = "\ComputerNamefiles"
    If Ping("ya.ru") Then MsgBox "Интернет доступен!"
    If Not Ping("192.168.0.2") Then MsgBox "Компьютер с IP адресом 192.168.0.2 недоступен в сети!"
End Sub

Расширенные варианты функции:

Function PingResponseTime(ByVal ComputerName$, Optional ByVal BufferSize% = 32) As Long
    ' Выполняет ICMP запрос (ping) до адреса ComputerName пакетами размером BufferSize% байтов
    ' Возвращает время отклика (в миллисекундах), если пинг прошел удачно,
    ' или -1, если ответ на запрос не получен.

    Dim oPingResult As Variant: PingResponseTime = -1: On Error Resume Next
    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 PingResponseTime = oPingResult.ResponseTime
    Next
End Function
Function PingResponseTimeEx(ByVal ComputerName$, Optional ByVal BufferSize As Long = 32) As Long
    ' Выполняет ICMP запрос (ping) до адреса ComputerName пакетами размером BufferSize% байтов
    ' Возвращает время отклика (в миллисекундах), если пинг прошел удачно,
    ' или -1, если ответ на запрос не получен.

    Dim oPingResult As Variant: PingResponseTimeEx = -1: On Error Resume Next
    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    ' ответ пришёл - возвращаем время отклика
                PingResponseTimeEx = oPingResult.ResponseTime
            Else    ' выводим код ошибки в окно Immediate
                Debug.Print "Ошибка ICMP запроса к адресу " & ComputerName$ & " (размер пакета: " & _
                            BufferSize & "): " & "Код ошибки " & oPingResult.StatusCode
            End If
            ' описания ошибок есть здесь: http://msdn.microsoft.com/ru-ru/library/aa394350(v=VS.85).aspx
            ' например, ошибка 11010 означает "Request Timed Out" - таймаут (по умолчанию он равен 1000 мс)
        End If
    Next
End Function

Ну и, как обычно, пример использования:

Sub ПримерИспользованияPingResponseTimeEx()
    ' пингуем адрес 192.168.1.100 пакетами размером 1000 байтов
    Debug.Print PingResponseTimeEx("192.168.1.100", 1000)    ' возвращает 5 (ping успешный, отклик 5ms)

    ' пингуем Яндекс пакетами размером 99 байтов
    Debug.Print PingResponseTimeEx("ya.ru", 99)    ' возвращает 28 (ping успешный, отклик 28ms)
End Sub

А эта функция (совместно с функцией Ping) поможет проверить, доступно ли соединение с интернетом на компьютере:

Function InternetConnectionAvailable() As Boolean
    ' возвращает TRUE, если доступно соединение с Интернетом (пингуются несколько хостов)
    InternetConnectionAvailable = False
    If Ping("yandex.ru") Then InternetConnectionAvailable = True: Exit Function
    If Ping("ya.ru") Then InternetConnectionAvailable = True: Exit Function
    If Ping("mail.ru") Then InternetConnectionAvailable = True: Exit Function
    If Ping("rambler.ru") Then InternetConnectionAvailable = True: Exit Function
End Function

Сделать это можно так:

Sub ПримерИспользования()
    If Not InternetConnectionAvailable Then ' проверяем доступ к основным сайтам
        MsgBox "Сначала подключите интернет (или отключите брандмауэр), " & _
               "а потом запускайте макрос", vbCritical, "Недоступен интернет"
        Exit Sub
    End If
    ' далее идёт код, взаимодействующий с интернетом (почта, FTP, HTTP и т.д.)
End Sub

Ping IP-адрес с кодом VBA и результаты возврата в Excel

‘===============================================================================

Const CONST_Cln_IP As Integer = 2

Sub GetIPStatus()

Dim Cell As Range

Dim ipRng As Range

Dim Result As String

Dim Wks As Worksheet

Set Wks = Worksheets(«SPIN»)

Select Case MsgBox(«Проверить все?», 35, «Пинг всех IP»)

Case 6 ‘ Да

Set ipRng = Wks.Range(«B3»)

Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)

Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))

For Each Cell In ipRng

Application.StatusBar = «ping: » & Cell.Offset(0, 1).Value & » (» & Cell.Value & «)»

Result = GetPingResult(Cell)

Cell.Offset(0, -1) = Result

DoEvents

Next Cell

Case 7 ‘ Нет

‘проверка по выделенному диапазону

Set ipRng = Selection

‘по словарю проверяем строки(для исключения повторного pingА)

With CreateObject(«Scripting.Dictionary»)

For Each Cell In ipRng

If Not .exists(Cell.Row) Then

.Add Cell.Row, «»

Debug.Print Cell.Row

Application.StatusBar = «ping: » & Wks.Cells(Cell.Row, CONST_Cln_IP + 1).Value & » (» & Wks.Cells(Cell.Row, CONST_Cln_IP).Value & «)»

Result = GetPingResult(Wks.Cells(Cell.Row, CONST_Cln_IP).Value)

Wks.Cells(Cell.Row, CONST_Cln_IP).Offset(0, -1) = Result

DoEvents

End If

Next Cell

End With

Case 2 ‘ Отмена

End Select

Application.StatusBar = «»

End Sub

‘===============================================================================

У меня есть некоторый визуальный базовый код (см. ниже), который проверяет ip-соединение в columb B (из excel spreedsheet) и ставит ли он, что он подключен или недоступен в columb c, мне просто интересно, можете ли вы помочь мне бы хотелось, чтобы он «подключился», если бы какой-либо другой результат был бы красным,

также может ли этот script запускаться автоматически по часовой или ежедневной основе?

Большое спасибо,Andy

Function GetPingResult(Host)

Dim objPing As Object

Dim objStatus As Object

Dim Result As String

Set objPing = GetObject(«winmgmts:{impersonationLevel=impersonate}»). _

ExecQuery(«Select * from Win32_PingStatus Where Address = ‘» & Host & «‘»)

For Each objStatus In objPing

Select Case objStatus.StatusCode

Case 0: strResult = «Connected»

Case 11001: strResult = «Buffer too small»

Case 11002: strResult = «Destination net unreachable»

Case 11003: strResult = «Destination host unreachable»

Case 11004: strResult = «Destination protocol unreachable»

Case 11005: strResult = «Destination port unreachable»

Case 11006: strResult = «No resources»

Case 11007: strResult = «Bad option»

Case 11008: strResult = «Hardware error»

Case 11009: strResult = «Packet too big»

Case 11010: strResult = «Request timed out»

Case 11011: strResult = «Bad request»

Case 11012: strResult = «Bad route»

Case 11013: strResult = «Time-To-Live (TTL) expired transit»

Case 11014: strResult = «Time-To-Live (TTL) expired reassembly»

Case 11015: strResult = «Parameter problem»

Case 11016: strResult = «Source quench»

Case 11017: strResult = «Option too big»

Case 11018: strResult = «Bad destination»

Case 11032: strResult = «Negotiating IPSEC»

Case 11050: strResult = «General failure»

Case Else: strResult = «Unknown host»

End Select

GetPingResult = strResult

Next

Set objPing = Nothing

End Function

Sub GetIPStatus()

Dim Cell As Range

Dim ipRng As Range

Dim Result As String

Dim Wks As Worksheet

Set Wks = Worksheets(«Sheet1»)

Set ipRng = Wks.Range(«B3»)

Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)

Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))

For Each Cell In ipRng

Result = GetPingResult(Cell)

Cell.Offset(0, 1) = Result

Next Cell

End Sub

Dany_crm

0 / 0 / 0

Регистрация: 04.06.2012

Сообщений: 12

1

05.06.2012, 14:26. Показов 6806. Ответов 23

Метки нет (Все метки)


Студворк — интернет-сервис помощи студентам

Доброе время суток!
Помогите пожалуйста написать макрос.
1) Пользователь открывает excel файл. В Ячейке A2 из выпадающего списка выбирает «Область», а в ячейке B2 выбирает «Город»
2) В excel файле нажимает кнопку «ТЕСТ СЕТИ»
3) После нажатия «ТЕСТ СЕТИ», должно запускаться выполнение команды ping «адрес сервера» -n 80 -l 2000
4) После выполнения команды, лог должен быть сохранен в txt файле, первая строка которого должна содержать «Область»;»Город»

Я в этом деле новичок, подскажите как лучше сделать!!!!

Добавлено через 16 часов 30 минут
Пинг проходит. файл создается.

Visual Basic
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

Подскажите плиз, как сформировать email с файлом test.txt в котором первая строчка будет содержать «Область»;»Город»



0



Gibboustooth

735 / 203 / 11

Регистрация: 23.06.2011

Сообщений: 440

05.06.2012, 15:01

2

Отправка письма через Outlook 2007

Visual Basic
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



0 / 0 / 0

Регистрация: 04.06.2012

Сообщений: 12

06.06.2012, 12:16

 [ТС]

3

Спасибо большое!
Подскажите пожалуйста, как в тему письма вставить значение из excel файла?



0



Gibboustooth

735 / 203 / 11

Регистрация: 23.06.2011

Сообщений: 440

06.06.2012, 12:44

4

Лучший ответ Сообщение было отмечено как решение

Решение

Вместо

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

читать

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

Добавлено через 39 секунд

Цитата
Сообщение от Dany_crm
Посмотреть сообщение

Подскажите пожалуйста, как в тему письма вставить значение из excel файла?

Какое именно значение?

Добавлено через 26 минут
Переписал немного ваш код, добавив все, что нужно:

Ping и отправка результатов на почту

Visual Basic
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
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:\.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

Досаточно поставить в константы в начале кода нужные вам значения и все должно заработать.
NB вам понадобятся библиотеки (Tools -> References) «Microsoft Scripting Runtime» (scrrun.dll) и «Microsoft Outlook 12.0 Object Library»



3



Dany_crm

0 / 0 / 0

Регистрация: 04.06.2012

Сообщений: 12

06.06.2012, 16:08

 [ТС]

5

Странно. Раньше не ругался, теперь говорит что «User-defined type not defined» на строчку

Visual Basic
1
2
Sub SendMail(Region As String)
    Dim oOutlook As Outlook.Application

И у меня почему-то кнопка References на панели Tools не активна.



0



735 / 203 / 11

Регистрация: 23.06.2011

Сообщений: 440

06.06.2012, 16:36

6

Цитата
Сообщение от Dany_crm
Посмотреть сообщение

И у меня почему-то кнопка References на панели Tools не активна.

Нельзя менять библиотеки, пока не остановлен макрос.
Ругается потому, что нет библиотеки «Microsoft Outlook 12.0 Object Library»



1



0 / 0 / 0

Регистрация: 04.06.2012

Сообщений: 12

06.06.2012, 16:41

 [ТС]

7

Затупил… =)
Gibboustooth — доброй души человек! Все получилось, Спасибо огромное.



0



735 / 203 / 11

Регистрация: 23.06.2011

Сообщений: 440

06.06.2012, 16:48

8

Цитата
Сообщение от Dany_crm
Посмотреть сообщение

Gibboustooth — доброй души человек! Все получилось, Спасибо огромное.

На здоровье



1



Dany_crm

0 / 0 / 0

Регистрация: 04.06.2012

Сообщений: 12

07.06.2012, 08:46

 [ТС]

9

Теперь задумался об обработке txt файлов. Их будет очень много!
Файлы будут сохранятся на моем пк в определенной папке. Возникает проблема, так как имя txt файла жестко определено, при сохранении txt будет перезаписываться на новый. Как добавить к имени файла время Now() чтобы избежать затирание?

Потом надо информацию из каждого txt файла импортировать в excel (файл во вложении).Итог_быстродействие.xlsx

test.txt

Нашел пример кода для поиска и импорта файлов.

Visual Basic
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

Помогите плиз довести дело до конца!



0



Gibboustooth

735 / 203 / 11

Регистрация: 23.06.2011

Сообщений: 440

07.06.2012, 10:07

10

Application.FileSearch is so 20th century

Добавление Now в имя файла

Visual Basic
1
2
3
4
5
6
7
8
9
10
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

Константу sFileName, соответственно, нужно написать вместо «test.txt» просто «test».



0



0 / 0 / 0

Регистрация: 04.06.2012

Сообщений: 12

07.06.2012, 10:42

 [ТС]

11

Ок!

Application.FileSearch is so 20th century

как лучше сделать?



0



Gibboustooth

735 / 203 / 11

Регистрация: 23.06.2011

Сообщений: 440

07.06.2012, 12:30

12

Чтение всех текстовых файлов в папке и запись данных на лист

Visual Basic
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



0 / 0 / 0

Регистрация: 04.06.2012

Сообщений: 12

07.06.2012, 13:36

 [ТС]

13

Ругается на строчку:
Set oFile = oFSO.CreateTextFile(oFSO.BuildPath(sPath, sFileName & Format(Now, «YYYY.MM.DD-hh.mm.ss») & «.txt)
Где-то синтаксическая ошибка =(



0



735 / 203 / 11

Регистрация: 23.06.2011

Сообщений: 440

07.06.2012, 13:39

14

Ругается либо на формат даты, либо на знаки в пути к файлу. Попрбуйте написать
«YYYYMMDDhhmmss»
вместо
«YYYY.MM.DD-hh.mm.ss»

Если сожрет, значит второе. Eсли нет — значит первое

У вас какая версия Excel? (хотя врядли это может влиять. Я скорее грешу на региональные настройки Windows)



1



Dany_crm

0 / 0 / 0

Регистрация: 04.06.2012

Сообщений: 12

07.06.2012, 13:55

 [ТС]

15

Все равно ругается.
У меня 2010.

Visual Basic
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



0



Gibboustooth

735 / 203 / 11

Регистрация: 23.06.2011

Сообщений: 440

07.06.2012, 14:18

16

Сейчас скину целиком код. Там еще есть проблемы.

Добавлено через 13 минут

Исправленный код отправки файла на почту.

Visual Basic
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
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:\.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 (Path)
        'Îòïðàâëÿåì (ìîæíî ñäåëàòü ".Display" âìåñòî ".Send",
        '÷òîáû ïðîâåðèòü ïàðàìåòðû è îòïðàâèòü ïèñüìî ðóêàìè)
        'Ïèñüìî îòïðàâëÿåòñÿ ïóñòûì (íå çàäàíî ñâîéñòâî .Body)
        .Send
    End With
End Sub



1



0 / 0 / 0

Регистрация: 04.06.2012

Сообщений: 12

07.06.2012, 14:51

 [ТС]

17

Отлично! Заработало =)

Теперь ошибка в импорте файлов User-Defined type not defined
строка:

Sub ParceFiles()
Dim oFSO As Scripting.FileSystemObject



0



Gibboustooth

735 / 203 / 11

Регистрация: 23.06.2011

Сообщений: 440

07.06.2012, 14:55

18

Ах, ну да. Вам нужна библиотека Microsoft Scripting Runtime (файл scrrun.dll).
Либо можно написать

Visual Basic
1
2
Dim oFSO as Object
Set oFSO = CreateObject("Scripting.FileSystemObject")

вместо

Visual Basic
1
2
Dim oFSO as Scripting.FileSystemObject 
Set oFSO as New Scripting.FileSystemObject

Вроде бы особой разницы нет, но я предпочитаю все-таки подгружать библиотеки тех объектов, с которыми работаю.



1



0 / 0 / 0

Регистрация: 04.06.2012

Сообщений: 12

07.06.2012, 15:02

 [ТС]

19

ОГРОМНОЕ ЧЕЛОВЕЧЕСКОЕ СПАСИБО!
С МЕНЯ ВИСКАРЬ! Куда отправить?



0



735 / 203 / 11

Регистрация: 23.06.2011

Сообщений: 440

07.06.2012, 15:06

20

На здоровье.
Не пью вискарь, спасибо



1



IT_Exp

Эксперт

87844 / 49110 / 22898

Регистрация: 17.06.2006

Сообщений: 92,604

07.06.2012, 15:06

20

  • Remove From My Forums
  • Question

  • Hi,

    Is it possible to initiate a ping command from VBA to a list in the excel sheet and record the results in a different sheet.

    I tried to call vbs and bat files from the VBA code, it worked but it would be better to have a single file to do everything.

    WMI is not an option because the ping is to different network equipment not normal PC’s.

    PowerShell is not an option because we are still using windows XP.

    Currently I use a batch file and save the results to a text file.

    Any hints appreciated.

    Thanks.

    • Changed type

      Thursday, March 4, 2010 7:54 PM
      Is in fact a question not a general discussion.

    • Moved by
      Bill_Stewart
      Friday, September 13, 2013 2:23 PM
      Move to more appropriate forum

Answers

  • use wmi ping (for Windows hosts)

    1. Function sPing(sHost) As String

    2. Dim oPing As Object, oRetStatus As Object

    3. Set oPing = GetObject(«winmgmts:{impersonationLevel=impersonate}»).ExecQuery _

    4. («select * from Win32_PingStatus where address = ‘» & sHost & «‘»)

    5. For Each oRetStatus In oPing

    6. If IsNull(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then

    7.             sPing = «Status code is « & oRetStatus.StatusCode

    8. Else

    9.             sPing = «Pinging « & sHost & » with « & oRetStatus.BufferSize & » bytes of data:» & Chr(10) & Chr(10)

    10.             sPing = sPing & «Time (ms) = « & vbTab & oRetStatus.ResponseTime & Chr(10)

    11.             sPing = sPing & «TTL (s) = « & vbTab & vbTab & oRetStatus.ResponseTimeToLive

    12. End If

    13. Next

    14. End Function

    15. Sub TestPing()

    16. End Sub

    • Marked as answer by
      IamMred
      Thursday, March 4, 2010 7:55 PM

  • Alfoulad, you «can» use ping via a shell command. It’s a bit messy as you have to go outside of excel. The other way is to use ICMP Echo. Best to add it as a module and then you can re use it in other files easily.

    I don’t have the exact code on me but here is a decent Microsoft article (for VB6) http://support.microsoft.com/kb/300197 .I do have a full working ping module in Excel at home. So if you can’t work it out from that article post up here in the next 6-7 hours and I will grab my code from home.

    • Marked as answer by
      IamMred
      Thursday, March 4, 2010 7:55 PM

 

Здравствуйте!  

  Подскажите, пожалуйста, как можно решить задачу контроля в файле Excel состояния сетевого подключения компьютера (компьютер включен в локальную сеть)? Т.е. если сеть включена, то в определенную ячейку вводиться «1», если сеть отключена то «0».

 

А как проверить, что «компьютер включен в локальную сеть»?  

  Достаточно, чтобы к сетевой карте компа было что-то подключено?  
Или надо распознать наличие соединения с определёнными компами?  

  Я бы выбрал второй вариант — в таких случаях проверяю наличие пинга до нужного компьютера.  

  Если надо, выложу файл, в котором в ячейках работают формулы типа =PING(«192.168.1.4»)  
(формула возвращает 0 или 1 в зависимости от доступности узла)  

  Можно проверить и состояние сетевой карты, но это будет посложнее.

 

{quote}{login=EducatedFool}{date=28.09.2009 04:54}{thema=}{post}А как проверить, что «компьютер включен в локальную сеть»?  

  Достаточно, чтобы к сетевой карте компа было что-то подключено?  
Или надо распознать наличие соединения с определёнными компами?  

  Я бы выбрал второй вариант — в таких случаях проверяю наличие пинга до нужного компьютера.  

  Если надо, выложу файл, в котором в ячейках работают формулы типа =PING(«192.168.1.4»)  
(формула возвращает 0 или 1 в зависимости от доступности узла)  

  Можно проверить и состояние сетевой карты, но это будет посложнее.{/post}{/quote}  

  Будьте добры, выложите пожалуйста пример (второй вариант).    
И вопрос по второму варианту, как долго идет PING?

 

Вот пример файла, который при открытии проверяет доступность указанных IP-адресов:    

http://excelvba.ru/XL_Files/Sample__28-09-2009__7-05-42.zip  

(файл будет работать далеко не у всех)  

      А вот и обещанный файл:

http://excelvba.ru/XL_Files/Sample__28-09-2009__7-12-50.zip  

  В нём доступны формулы типа этих:  
=pingb(A1)  
‘ возвращает TRUE, если пинг прошёл удачно  

  =PingEx(A2)  
‘ возвращает время прохождения пакета в миллисекундах  

  =InternetConnectionAvailable()  
‘ возвращает TRUE, если доступно соединение с Интернетом (пингуются несколько хостов)

 

{quote}{login=EducatedFool}{date=28.09.2009 05:09}{thema=}{post}Вот пример файла, который при открытии проверяет доступность указанных IP-адресов:    

http://excelvba.ru/XL_Files/Sample__28-09-2009__7-05-42.zip  

(файл будет работать далеко не у всех)  

      А вот и обещанный файл:

http://excelvba.ru/XL_Files/Sample__28-09-2009__7-12-50.zip  

  В нём доступны формулы типа этих:  
=pingb(A1)  
‘ возвращает TRUE, если пинг прошёл удачно  

  =PingEx(A2)  
‘ возвращает время прохождения пакета в миллисекундах  

  =InternetConnectionAvailable()  
‘ возвращает TRUE, если доступно соединение с Интернетом (пингуются несколько хостов){/post}{/quote}  

  Пребольшущие спасибо!  

  Еще один вопросик. Можно ли средствами VBA распознать к примеру открыт ли проводник Windows или закрыт?

 

> И вопрос по второму варианту, как долго идет PING?  

  Если пинг прошёл, то после первого успешного пакета выводится результат.  
Если пинг не проходит, производится несколько попыток (в данном примере — 3)  

  Пинг работает раз в 10 быстрее, чем при помощи встроенной в Винду программы ping.exe (в ней есть таймауты. в моём варианте таймаутов нет)

 

> Можно ли средствами VBA распознать к примеру открыт ли проводник Windows или закрыт?  

  Да, можно. (используя WinAPI, можно сделать всё, что угодно)  
В цикле перебираем все открытые окна, и проверяем их заголовки.

 

{quote}{login=EducatedFool}{date=28.09.2009 05:14}{thema=}{post}> Можно ли средствами VBA распознать к примеру открыт ли проводник Windows или закрыт?  

  Да, можно. (используя WinAPI, можно сделать всё, что угодно)  
В цикле перебираем все открытые окна, и проверяем их заголовки.{/post}{/quote}  

  Спасибо, попробую разобраться с этой функцией, главное наметка есть.

 

Вообще, проверить наличие запущенного приложения можно гораздо проще:  

  Sub test2()  
   On Error Resume Next:    x = GetObject(, «word.application»)  
   If Err Then MsgBox «Word не запущен!» Else MsgBox «Word запущен!»  
End Sub  

  Как-то аналогично, скорее всего, можно проверить наличие запущенного Explorer-a:  
(такой код не работает, поскольку я не знаю, какой тип указывать)  

  Sub test()  
   On Error Resume Next  
   x = GetObject(, «ExploreWClass»)  
   If Err Then MsgBox «Проводник не запущен!» Else MsgBox «Проводник запущен!»  
End Sub

 

Alex28

Гость

#10

28.09.2009 05:42:32

{quote}{login=EducatedFool}{date=28.09.2009 05:32}{thema=}{post}Вообще, проверить наличие запущенного приложения можно гораздо проще:  

  Sub test2()  
   On Error Resume Next:    x = GetObject(, «word.application»)  
   If Err Then MsgBox «Word не запущен!» Else MsgBox «Word запущен!»  
End Sub  

  Как-то аналогично, скорее всего, можно проверить наличие запущенного Explorer-a:  
(такой код не работает, поскольку я не знаю, какой тип указывать)  

  Sub test()  
   On Error Resume Next  
   x = GetObject(, «ExploreWClass»)  
   If Err Then MsgBox «Проводник не запущен!» Else MsgBox «Проводник запущен!»  
End Sub{/post}{/quote}  

  Спасибо, проверил с Word-ом OK все получается, а вот с проводником нет. Проводник открыт а пишет что «не запущен».

Понравилась статья? Поделить с друзьями:
  • Команда excel промежуточные итоги в excel
  • Команда excel преобразовать в число
  • Команда excel на весь экран
  • Команда excel добавить строку
  • Команда excel для деления