|
По имени сервера (например, mail.ru) получить его IP-адрес Как-то раз, для одной из задач мне потребовалось узнать IP-адрес хоста.
Поиск решения привел меня на сайт DEVHUNT.NET статья VBA – Get Host IP Address
(Далее идёт вольный перевод статьи.)
Основной секрет здесь в том, чтобы знать, что существует древняя команда DOS (в своё время прошел её от версии 2,11 до 6,22 - Joss), которая позволяет легко получить такую информацию, команда nslookup.
Итак, стоит вопрос - Как я могу запустить nslookup в VBA?
Отсюда остается лишь вопрос создания оболочки для выполнения команды и анализа возвращенного ответа. Еще одним важным элементом здесь является то, что некоторые хосты могут возвращать несколько адресов, поэтому вам нужно иметь возможность перебирать возвращаемую информацию, поскольку она не всегда одинакова.
С учетом всего сказанного, не потребовалось много времени, чтобы придумать следующую небольшую функцию:
'---------------------------------------------------------------------------------------
' Procedure : GetHostNameIP
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Retrieve the IP Address of a given host name
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sHostName : Host name to lookup the IP address of
'
' Usage:
' ~~~~~~
' GetHostNameIP("utteraccess.com")
' Returns -> 52.40.49.196
' GetHostNameIP("google.com")
' Returns -> 2607:f8b0:4006:813::200e,172.217.10.238
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2020-07-20 Initial Release, Forum Help
' 2 2020-07-20 Update to handle the case of multiple addresses
' 3 2020-07-21 Handle blank/empty sHostName calls
'---------------------------------------------------------------------------------------
Function GetHostNameIP(ByVal sHostName As String) As String
Dim sResult As String
Dim aResult As Variant
Dim i As Long
On Error GoTo Error_Handler
If Len(Trim(sHostName)) = 0 Then GoTo Error_Handler_Exit
sResult = CreateObject("Wscript.Shell").Exec("nslookup " & sHostName).StdOut.ReadAll
aResult = Split(sResult, vbCrLf)
If UBound(aResult) > 2 Then
For i = 4 To UBound(aResult)
If Len(Trim(aResult(i) & vbNullString)) > 0 Then
GetHostNameIP = GetHostNameIP & Trim(Replace(Replace(Replace(aResult(i), "Address:", ""), _
"Addresses:", ""), vbTab, "")) & ","
End If
Next i
If Right(GetHostNameIP, 1) = "," Then GetHostNameIP = Left(GetHostNameIP, Len(GetHostNameIP) - 1)
End If
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GetHostNameIP" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Теперь все вышеперечисленное работало абсолютно нормально, но это действие вызвало кратковременную мигание экрана, Это мерцание меня раздражало, поэтому я продолжал работать над этим. Проблема в том, что .Exec всегда вызывает мигание (открытие/закрытие окна cmd), и нет способа обойти это (кто-нибудь, пожалуйста, поправьте меня, если я ошибаюсь, и есть простое решение, о котором я не знаю), и поэтому единственный способ обойти мигание экрана - вместо этого использовать .Run. Однако .Run не возвращает значение, как .Exec, поэтому мы должны сначала поместить результаты команды .Run в текстовый файл и прочитать текстовый файл в память для работы. И вот ниже представлена версия, при которой экран не мигает.
'---------------------------------------------------------------------------------------
' Procedure : GetHostNameIP
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Retrieve the IP Address of a given host name
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sHostName : Host name to lookup the IP address of
'
' Usage:
' ~~~~~~
' GetHostNameIP("utteraccess.com")
' Returns -> 52.40.49.196
' GetHostNameIP("google.com")
' Returns -> 2607:f8b0:4006:813::200e,172.217.10.238
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2020-07-20 Initial Release
' Different approach to avoid screen flashing
' 2 2020-07-21 Handle blank/empty sHostName calls
'---------------------------------------------------------------------------------------
Function GetHostNameIP(ByVal sHostName As String) As String
Dim sFile As String
Dim sResult As String
Dim aResult As Variant
Dim i As Long
On Error GoTo Error_Handler
If Len(Trim(sHostName)) = 0 Then GoTo Error_Handler_Exit
sFile = Environ("temp") & "\GetHostNameIP.txt"
'Run the nslookup command and save its results to a text file
CreateObject("Wscript.Shell").Run "cmd /c nslookup " & sHostName & " > " & sFile, 0, True
With CreateObject("Scripting.FileSystemObject")
'Read the contents of the text file into memory
sResult = .OpenTextFile(sFile).ReadAll()
'Delete the text file
.DeleteFile sFile
End With
aResult = Split(sResult, vbCrLf)
If UBound(aResult) > 2 Then
For i = 4 To UBound(aResult)
If Len(Trim(aResult(i) & vbNullString)) & 0 Then
GetHostNameIP = GetHostNameIP & Trim(Replace(Replace(Replace(aResult(i), "Address:", ""), _
"Addresses:", ""), vbTab, "")) & ","
End If
Next i
If Right(GetHostNameIP, 1) = "," Then GetHostNameIP = Left(GetHostNameIP, Len(GetHostNameIP) - 1)
End If
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GetHostNameIP" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function Обе функции работают одинаково хорошо, первая немного быстрее (на основе очень маленькой тестовой выборки она работала примерно на 1% быстрее), но мерцает, а вторая немного медленнее, но не мерцает. Вы выбираете, какой из них лучше всего подходит для ваших нужд.
Просмотров: 1665
 Ваш коментарий будет первым | |
|
