PDA

View Full Version : Solved: VBA - Excel - XP - Ping



mrdata030
09-16-2005, 02:28 PM
How do I ping a domain name within ms excel xp and then copy the ip address into a cell of the same worksheet?

Justinlabenne
09-16-2005, 03:01 PM
Try this entry and see if it works for you: (http://vbaexpress.com/kb/getarticle.php?kb_id=537)

Killian
09-16-2005, 03:48 PM
Hi and welcome to VBAX :hi:

I'm not sure VBA has the means to do this directly, since some kind of Internet Connection Protocal would need to be established.
That's not to say it can't be done from Excel, you'll just need to get creative with some Win API functions.
Here's some code that does the job... I've added some comments to attempt to explain what's going on. The main routine just calls the main function, passing the web addy you want to ping. I've set the main function up to return a string in the format ip_address,time(in milliseconds) so you can use the Split function to write this to cells.Dim c As Range

'Range("A1:A10") contains the domain names to ping
For Each c In ActiveSheet.Range("A1:A10")
ActiveSheet.Range(c.Offset(0, 1), c.Offset(0, 2)) = _
Split(PingAddress(c.Text), ",")
Next cIt's probably worth pointing out if you have a firewall, there may be some complaints, depending on how it's configured. It's also quite simple so some nested DNS lookups (for sites set up as portals) might return failures. Worth a try, though :yes
Option Explicit

'required WIN API functions
Private Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal strDomainName As String) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired&, lpWSAdata As WSAdata) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal HANDLE As Long) As Boolean
Private Declare Function IcmpSendEcho Lib "ICMP" (ByVal IcmpHandle As Long, ByVal DestAddress As Long, ByVal RequestData As String, ByVal RequestSize As Integer, RequestOptns As IP_OPTION_INFORMATION, ReplyBuffer As IP_ECHO_REPLY, ByVal ReplySize As Long, ByVal TimeOut As Long) As Boolean

'declare data structures
Private Type WSAdata 'for wsock32.dll data
wVersion As Integer
wHighVersion As Integer
szDescription(0 To 255) As Byte
szSystemStatus(0 To 128) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Private Type Hostent 'for memory copy
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type
Private Type IP_OPTION_INFORMATION ' optional ICMP info
TTL As Byte
Tos As Byte
Flags As Byte
OptionsSize As Long
OptionsData As String * 128
End Type
Private Type IP_ECHO_REPLY 'ICMP return data
Address(0 To 3) As Byte
Status As Long
RoundTripTime As Long
DataSize As Integer
Reserved As Integer
data As Long
Options As IP_OPTION_INFORMATION
End Type

Function PingAddress(strDomainName) As String

'declare return types
Dim hFile As Long
Dim lpWSAdata As WSAdata
Dim hHostent As Hostent
Dim AddrList As Long
Dim Address As Long
Dim rIP As String
Dim OptInfo As IP_OPTION_INFORMATION
Dim EchoReply As IP_ECHO_REPLY

'startup wsock32.dll
Call WSAStartup(&H101, lpWSAdata)

If GetHostByName(strDomainName) <> 0 Then
CopyMemory hHostent.h_name, ByVal GetHostByName(strDomainName), Len(hHostent)
CopyMemory AddrList, ByVal hHostent.h_addr_list, 4
CopyMemory Address, ByVal AddrList, 4
Else
PingAddress = "Error, Unable to get host name"
Exit Function
End If

'return handle to new file to hold Internet Control Message Protocol data
hFile = IcmpCreateFile()
If hFile = 0 Then
PingAddress = "Error, Unable to Create File Handle"
Exit Function
End If

'TTL is the Time To Live, i.e. number of hops the request will make before failure
OptInfo.TTL = 255

'send the request - return data to structures declared above
If IcmpSendEcho(hFile, Address, String(32, "A"), 32, OptInfo, EchoReply, Len(EchoReply) & 8, 2000) Then
rIP = CStr(EchoReply.Address(0)) & "." & CStr(EchoReply.Address(1)) & "." & CStr(EchoReply.Address(2)) & "." & CStr(EchoReply.Address(3))
Else
PingAddress = "Error, Timeout"
End If
If EchoReply.Status = 0 Then
PingAddress = rIP & "," & Trim$(CStr(EchoReply.RoundTripTime)) & "ms"
Else
PingAddress = "Error, Failure"
End If

'close handle to datafile and close wsock32.dll
Call IcmpCloseHandle(hFile)
Call WSACleanup

End Function

Sub VBPing()
'example of use
MsgBox PingAddress("www.google.com")

End Sub

sheeeng
09-16-2005, 05:10 PM
Wow, new ideas here...

Btw, can we use VBA to entablish TCP/IP connections? eg. ECHO client server type?

MOS MASTER
09-16-2005, 05:19 PM
Nice one Killian! :clap:

Perhaps this one could be helpfull as well:
http://www.vbaexpress.com/kb/getarticle.php?kb_id=537

HTH, :whistle:

Justinlabenne
09-16-2005, 07:52 PM
Hey Joost, thats the same kb entry I posted.
The link is just formatted as text to throw you off. http://vbaexpress.com/forum/images/smilies/074.gif

Later buddy.......

MOS MASTER
09-17-2005, 06:34 PM
Hey Joost, thats the same kb entry I posted.
The link is just formatted as text to throw you off. http://vbaexpress.com/forum/images/smilies/074.gif

Later buddy.......

Hahahaa...:rotlaugh: sorry buddy!

mrdata030
09-19-2005, 09:20 AM
I have that but I am trying to have it get website address fromwithin my excel spreadsheet starting from cell a1 and going to until their is data to be gotten and then place the ip address into the cell c1

mrdata030
09-19-2005, 10:10 AM
Ok, but that code at the end as it says displays a message box with the info. Now I am trying to capture what to ping in cell a2 and place the results in b2 and ping the mail server and place those results in c2

Sub VBPing()
'example of use
MsgBox PingAddress("www.google.com")

End Sub

Killian
09-19-2005, 10:29 AM
Well there's another example of what you want to do preceding the main code - you just need to change the reference to the range that contains the domain names

mrdata030
09-19-2005, 11:24 AM
Dim c As Range

'Range("A1:A10") contains the domain names to ping
For Each c In ActiveSheet.Range("A1:A10")
ActiveSheet.Range(c.Offset(0, 1), c.Offset(0, 2)) = _
Split(PingAddress(c.Text), ",")
Next c

Sorry i did not look at that script at first. That works well, the only 2 things is that I am also trying to do a mail lookup and I only want the ip addresses pasted not the time frame. Any suggestions.

mrdata030
09-19-2005, 01:03 PM
I will as soon as it is.

Killian
09-19-2005, 01:42 PM
So, to return just the IP, change this line in the main function:
PingAddress = rIP & "," & Trim$(CStr(EchoReply.RoundTripTime)) & "ms"

to this:
PingAddress = rIP

Now you don't need to Split the returned string and you're only assigning it to a single cell so that routine becomes a little simpler
For Each c In ActiveSheet.Range("A1:A10")
ActiveSheet.Range(c.Offset(0, 1)).Value = PingAddress
Next c

Regarding the next part... what do you mean by a Mail lookup? Communicating with a mail server is a different ballgame... Pinging the domain name will tell you that the server's responding - if it's also a mail server you would have to use Simple Mail Transfer Protocol (SMTP) to interrogate port 25 to get a response on the mail capabilities. However, I don't think this is possible in the same way - The WinAPI doesn't have an SMTP library so you would need to use some 3rd party library.

mrdata030
09-19-2005, 02:47 PM
I am trying to do the same thing for the mail server. I.E. ping mail.domainname.com and copy the ip to the cell. Now I tried what you wrote and its hung up on pingaddress. What exactly should I write for the code.

Killian
09-19-2005, 04:15 PM
Well the code I posted seems to work fine for my tests... using the address format "mail.domainname.com" will only work if the mailserver is registered as a sub-domain in that way - which isn't always the case.
Can you describe what you mean by "hung-up"? the IcmpSendEcho call passes the timeout as it's last parameter, 2000ms in the posted code, so if there's no response after 2 seconds, you should get "Error, Timeout" written out as the result.
You could try stepping through the code line by line with F8 to see what's going on.
If it's not working out, post a sample list of servers (or you can send the workbook with the code you're trying, if you like) and I'll try to figure something out.

mrdata030
09-20-2005, 07:56 AM
Qoute:


"For Each c In ActiveSheet.Range("A1:A10")
ActiveSheet.Range(c.Offset(0, 1)).Value = PingAddress
Next c "

When I use this it always has a problem with the PingAddress command.

So i decided just to learn to use nslookup against 3 name servers, any ideas

Killian
09-20-2005, 08:33 AM
My idea is, that saying something has a problem doesn't adequately describe what's happening, so it will be diffucult to resolve it.
I'm not so sure that giving up and learning to use nslookup is going to help either... nslookup is a windows executable that actually uses the GetHostByName WinAPI function we used in the PingAddress function - I don't see how you can use it to get a return value in Excel. :dunno

I've attached an example that works for me - open and run the "GetIPs" marco at let me know exactly what happens... I'm intrigued (and also I don't like to give up, it's only code, after all) :whistle:

mrdata030
09-20-2005, 09:11 AM
My idea is, that saying something has a problem doesn't adequately describe what's happening, so it will be diffucult to resolve it.
I'm not so sure that giving up and learning to use nslookup is going to help either... nslookup is a windows executable that actually uses the GetHostByName WinAPI function we used in the PingAddress function - I don't see how you can use it to get a return value in Excel. :dunno

I've attached an example that works for me - open and run the "GetIPs" marco at let me know exactly what happens... I'm intrigued (and also I don't like to give up, it's only code, after all) :whistle:


I didn't see any attachements? The reason I have decided to use nslookup instead is because I am finding alot of the domains no longer resolving but I still need to find internally what servers they are on.

Killian
09-20-2005, 09:43 AM
forgot the attachment :doh:

mrdata030
09-20-2005, 10:00 AM
Ok, that worked but that script was different then what you posted. this is the results:

Error, Unable to get host name82.165.237.33,34ms82.165.237.33,32msError, Failure64.202.167.129,61ms216.149.215.5,48ms207.234.151.47,65ms65.163.26.13 5,52msError, Unable to get host name65.163.26.164,32msError, Failure65.163.26.164,31msError, Unable to get host nameError, Unable to get host name65.73.235.127,87ms65.163.26.164,31ms65.163.26.164,31msError, FailureError, Unable to get host name64.202.167.192,61msError, Unable to get host name65.163.26.136,32msError, Unable to get host nameError, Unable to get host name68.142.234.44,29ms65.163.26.98,52msError, Failure64.202.167.129,60ms

Now I am trying to do an internal lookup of these domains so I dont what the errors and I dont want the ms

Killian
09-20-2005, 11:26 AM
OK, time for a re-think...

I've been quick to say that you can't get a return value, but remembering back to the days of the dos prompt, that's not entirely true. With nslookup, you can pipe the result out to a text file. Then we just need to parse the text file to output the IPs

I'm working on it - I'll post back soon

Killian
09-20-2005, 12:05 PM
Right, now we're using a new method to crack this... NSLookUp as requested. :yes
There's a shell execution of the command prompt, a write out to a temp text file and some string parsing so it's not the last word in either speed or efficiency, but if it suits your purposes, maybe we can tidy things up a bit. :whistle:
Also, NSLookUp often returns multiple IPs, so I don't know what you want to do about that ?
So here's version 2 (beta) :)Sub GetIPs()

Dim c As Range

'Range("A2:A4") contains the domain names to ping
For Each c In ActiveSheet.Range("A2:A4")
c.Offset(0, 1) = PingAddress(c.Text)
Next c

End Sub

Function PingAddress(strDomain As String) As String

Dim fso As Object
Dim WshShell As Object
Dim RetVal As Long
Dim strTemp As String
Dim colOutput As New Collection
Dim OutputItem
Dim i As Long

Set WshShell = CreateObject("Wscript.Shell")
RetVal = WshShell.Run("cmd /c nslookup.exe -ls " & strDomain & " > C:\NSLOOKUPDATA.TXT", 0, True)

Set fso = CreateObject("Scripting.FileSystemObject")
Set txtstream = fso.OpenTextFile("C:\NSLOOKUPDATA.TXT", 1)
Do
strTemp = txtstream.ReadLine
colOutput.Add strTemp
Loop Until txtstream.AtEndOfStream
txtstream.Close

For i = colOutput.Count To 1 Step -1
If Left(colOutput(i), 10) = "Addresses:" Then
strTemp = Trim(colOutput(i))
PingAddress = Trim(Right(strTemp, Len(strTemp) - InStr(1, strTemp, "Addresses:") - 9))
Exit For
End If
Next
If PingAddress = "" Then
For i = colOutput.Count To 1 Step -1
If Left(colOutput(i), 8) = "Address:" Then
strTemp = Trim(colOutput(i))
PingAddress = Trim(Right(strTemp, Len(strTemp) - InStr(1, strTemp, "Addresses:") - 9))
Exit For
End If
Next
End If

If PingAddress = "" Then PingAddress = "Domain name not resolved"

Set txtstream = Nothing
Set fso = Nothing
Set WshShell = Nothing

End Function

mrdata030
09-20-2005, 12:54 PM
That works thank you. I consider this solved. You have been very helpful. Now just how do you mark it as sovled, lol?

Killian
09-20-2005, 02:06 PM
Glad it's worked out for you
Thread marked as solved :thumb

jpalazzi
07-22-2016, 09:26 AM
I love this code and it works well for me. What's the best way to handle blank rows? So if I set my range A1:A100, but only have content in A1:A50 it returns my IP for A51:A100.

Aussiebear
07-23-2016, 07:13 PM
Set a test for the trigger cell to call the code.

mdmackillop
07-24-2016, 02:14 AM
For Each c In ActiveSheet.Range("A1:A100").SpecialCells(2)