Create a new class module and paste this source code into it. Change the name of the class module to cICMP. If you have any questions, email us at help@codeoftheweek.com
Option Explicit
'----------------------------------------------------------------------
'
' Module Name: cICMP
' Written By: C&D Programming Corp.
' Create Date: 1/2000
' Copyright: Copyright 1999 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
Option Explicit
' Basic Winsock definitions
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128
Private Const AF_INET = 2
Private Type WSADATA
wversion As Integer
whighversion As Integer
szDescription(0 To WSADescription_Len) As Byte
szSystemStatus(0 To WSASYS_Status_Len) As Byte
imaxsockets As Integer
imaxudp As Integer
lpszvenderinfo As Long
End Type
Private Declare Function gethostbyname Lib "wsock32.dll" _
(ByVal hostname As String) As Long
Private Declare Function gethostbyaddr Lib "wsock32.dll" _
(haddr As Long, ByVal hnlen As Long, ByVal addrtype As Long) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" _
(ByVal VersionReq As Long, WSADataReturn As WSADATA) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
' and a way to copy memory directly...
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (xDest As Any, xSource As Any, ByVal nbytes As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (lpString As Any) As Long
Public Sub Initialize()
Dim uWSAData As WSADATA
If WSAStartup(257, uWSAData) <> 0 Then
MsgBox "Unable to initialize Winsock", vbOKOnly, "Winsock Error"
Exit Sub
End If
End Sub
Private Function TextToIP(ByVal sIPAddress As String) As Long
Dim x As Integer
Dim iOctet As Integer ' octet value
Dim bIP(1 To 4) As Byte ' IP storage for each octet
Dim lIP As Long ' IP value
Dim iDots As Integer ' count of dots found
lIP = 0
iOctet = 0
iDots = 0
For x = 1 To Len(sIPAddress)
If Mid$(sIPAddress, x, 1) = "." Then
iDots = iDots + 1
If iDots > 3 Then Exit For ' bad format!
bIP(iDots) = iOctet
iOctet = 0
Else
' add digit but restrict to 8 bits
iOctet = (iOctet * 10 + Val("0" & Mid$(sIPAddress, x, 1))) And 255
End If
Next
bIP(4) = iOctet ' save last one
CopyMemory lIP, bIP(1), 4 ' copy to LONG value
TextToIP = lIP ' copy to return value
End Function
Private Function IPToText(ByVal sIPAddress As String) As String
IPToText = CStr(Asc(Mid$(sIPAddress, 1, 1))) & "." & _
CStr(Asc(Mid$(sIPAddress, 2, 1))) & "." & _
CStr(Asc(Mid$(sIPAddress, 3, 1))) & "." & _
CStr(Asc(Mid$(sIPAddress, 4, 1)))
End Function
' Converts hostname (such as microsoft.com) to an IP address
' Gets first IP address that belongs to the name
Public Function GetIPAddress(ByVal sLookupName As String) As String
Dim x As Long ' scratch
Dim nbytes As Long
Dim sTarget As String ' null-delimited hostname
Dim lhostent As Long ' address of hostent structure
Dim lhostentName As Long ' address of name pointer
Dim lhostentAddress As Long ' address of address pointer
Dim lIPPointer As Long ' address of IP address
Dim sAddress As String
'default values
GetIPAddress = ""
' if an IP was specified, use gethostbyaddr instead
If IsNumeric(Left$(sLookupName, 1)) Then
lhostent = gethostbyaddr(TextToIP(sLookupName), 4, AF_INET)
Else
sTarget = sLookupName & vbNullChar
lhostent = gethostbyname(sTarget) ' do actual winsock call
End If
If lhostent = 0 Then
GetIPAddress = 0
Exit Function ' failed!
End If
lhostentName = lhostent ' set pointer addresses
lhostentAddress = lhostent + 12
' convert addresses of pointers to the pointers...
CopyMemory lhostentName, ByVal lhostentName, 4
CopyMemory lhostentAddress, ByVal lhostentAddress, 4
' Get resolved hostname
nbytes = lstrlen(ByVal lhostentName)
If nbytes > 0 Then
sLookupName = Space$(nbytes)
CopyMemory ByVal sLookupName, ByVal lhostentName, nbytes
End If
' get all IP addresses
CopyMemory lIPPointer, ByVal lhostentAddress, 4
If lIPPointer = 0 Then
GetIPAddress = "