Create a new class module and paste this source code into it. Change the name of the class module to cICMP. This class replaces the one in issue number 114. If you have any questions, email us at help@codeoftheweek.com
'----------------------------------------------------------------------
'
' 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
'
' Credits: Some portions of this code was derived from
' Jim Huff of Edinborg Productions.
'
' Some Microsoft Comments:
' The ICMPSendEcho() function sends an ICMP echo request to the
' specified destination IP address and returns any replies received
' within the timeout specified. The API is synchronous, requiring
' the process to spawn a thread before calling the API to avoid
' blocking. An open IcmpHandle is required for the request to
' complete. IcmpCreateFile() and IcmpCloseHandle() functions are
' used to create and destroy the context handle.
'
'----------------------------------------------------------------------
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
Private Declare Function IcmpSendEcho Lib "ICMP.DLL" _
(ByVal lngHandle As Long, ByVal lIP As Long, _
strData As String, ByVal intDataLen As Integer, _
usrOpt As ICMPReqOpt, bytBuff As ICMPEchoReply, _
ByVal lngRepLen As Long, ByVal lTimeOut As Long) As Long
Private Declare Function IcmpCreateFile Lib "ICMP.DLL" () As Long
Private Declare Function IcmpCloseHandle Lib "ICMP.DLL" _
(ByVal lngHandle As Long) As Integer
' 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
'
'
' information for Ping routines
'
'
Private Type ICMPReqOpt
TTL As Byte ' time-to-live
Tos As Byte ' type-of-service
Flags As Byte ' see below
optsize As Long ' length of options string
Options As String * 128 ' use empty string (haven't figured this yet)
End Type
Private Type ICMPEchoReply
Address(1 To 4) As Byte ' address of system responding
lStatus As Long ' error code
lRoundTripTime As Long ' time in milliseconds
iDataSize As Integer ' buffer size
Reserved As Integer ' not used
lReplyData As Long ' buffer returned
IPOptions As ICMPReqOpt ' options structure
End Type
Private mlPacketSize As Long ' size of the packets to ping
Private mlPacketCount As Long ' number of packets to send
Private mlTimeToLive As Long ' number milliseconds to wait for a response.
Private mlIPHandle As Long ' handle to IP channel
Private tIPOptionInfo As ICMPReqOpt ' option info for icmp call
Private tIPEchoReply As ICMPEchoReply ' reply info for icmp call
Public Event PingStatus(lStatus As Long, sResultString As String, sRespondingHost As String, iBytesSent As Integer, lRoundTripTime As Long, lTimeToLive As Byte)
Private Const IP_STATUS_BASE = 11000
Private Const IP_SUCCESS = 0
Private Const IP_BUF_TOO_SMALL = (IP_STATUS_BASE + 1)
Private Const IP_DEST_NET_UNREACHABLE = (IP_STATUS_BASE + 2)
Private Const IP_DEST_HOST_UNREACHABLE = (IP_STATUS_BASE + 3)
Private Const IP_DEST_PROT_UNREACHABLE = (IP_STATUS_BASE + 4)
Private Const IP_DEST_PORT_UNREACHABLE = (IP_STATUS_BASE + 5)
Private Const IP_NO_RESOURCES = (IP_STATUS_BASE + 6)
Private Const IP_BAD_OPTION = (IP_STATUS_BASE + 7)
Private Const IP_HW_ERROR = (IP_STATUS_BASE + 8)
Private Const IP_PACKET_TOO_BIG = (IP_STATUS_BASE + 9)
Private Const IP_REQ_TIMED_OUT = (IP_STATUS_BASE + 10)
Private Const IP_BAD_REQ = (IP_STATUS_BASE + 11)
Private Const IP_BAD_ROUTE = (IP_STATUS_BASE + 12)
Private Const IP_TTL_EXPIRED_TRANSIT = (IP_STATUS_BASE + 13)
Private Const IP_TTL_EXPIRED_REASSEM = (IP_STATUS_BASE + 14)
Private Const IP_PARAM_PROBLEM = (IP_STATUS_BASE + 15)
Private Const IP_SOURCE_QUENCH = (IP_STATUS_BASE + 16)
Private Const IP_OPTION_TOO_BIG = (IP_STATUS_BASE + 17)
Private Const IP_BAD_DESTINATION = (IP_STATUS_BASE + 18)
Private Const IP_ADDR_DELETED = (IP_STATUS_BASE + 19)
Private Const IP_SPEC_MTU_CHANGE = (IP_STATUS_BASE + 20)
Private Const IP_MTU_CHANGE = (IP_STATUS_BASE + 21)
Private Const IP_UNLOAD = (IP_STATUS_BASE + 22)
Private Const IP_GENERAL_FAILURE = (IP_STATUS_BASE + 50)
Private Const MAX_IP_STATUS = IP_GENERAL_FAILURE
Private Const IP_PENDING = (IP_STATUS_BASE + 255)
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
TimeToLive = 255
PacketSize = 32
PacketCount = 5
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 = "