'Agent Initalize section:
Sub Initialize
Dim strData As String
Dim strAddress As String
Dim myPing As New MyPing
Dim strMessage As String
strAddress = Inputbox("Enter IP address for PING", "HALPing Tester", "127.0.0.1")
If strAddress = "" Then Exit Sub
strData = Inputbox("Enter message text", "HAL PING Tester", "This is my message")
If strData = "" Then Exit Sub
If Not myPing.PrepareSocket() Then
Msgbox "Windows Sockets for 32 bit Windows is not responding properly."
End If
myPing.Ping strAddress, strData
strMessage = "Requested Address: " & strAddress & Chr(10) &_
"Sent Data: " & strData & Chr(10) &_
Chr(10) &_
"Returned Values:" & Chr(10) & Chr(10) &_
"Status: " & myPing.Status & Chr(10) &_
"Pinged Address:" & myPing.Address & Chr(10) &_
"Trip Time: " & myPing.TripTime & " ms" & Chr(10) &_
"Data size: " & myPing.DataSize & " bytes" & Chr(10) &_
"Data returned: " & myPing.Data
Msgbox strMessage, 0, "HALPing Tester"
End Sub
'HALPing:
Option Public
Option Explicit
%REM
Copyright ?2000-2002 HAL Informatika d.o.o. Zagreb, Croatia
Author: Andrej Tihomirovic
%ENDREM
'Constants from IPExport.h
'IP_STATUS codes returned from IP APIs
Private Const IP_SUCCESS = 0
Private Const IP_BUF_TOO_SMALL = 11001
Private Const IP_DEST_NET_UNREACHABLE = 11002
Private Const IP_DEST_HOST_UNREACHABLE = 11003
Private Const IP_DEST_PROT_UNREACHABLE = 11004
Private Const IP_DEST_PORT_UNREACHABLE = 11005
Private Const IP_NO_RESOURCES = 11006
Private Const IP_BAD_OPTION = 11007
Private Const IP_HW_ERROR = 11008
Private Const IP_PACKET_TOO_BIG = 11009
Private Const IP_REQ_TIMED_OUT = 11010
Private Const IP_BAD_REQ = 11011
Private Const IP_BAD_ROUTE = 11012
Private Const IP_TTL_EXPIRED_TRANSIT = 11013
Private Const IP_TTL_EXPIRED_REASSEM = 11014
Private Const IP_PARAM_PROBLEM = 11015
Private Const IP_SOURCE_QUENCH = 11016
Private Const IP_OPTION_TOO_BIG = 11017
Private Const IP_BAD_DESTINATION = 11018
'The next group are status codes passed up on status indications to transport layer protocols.
Private Const IP_ADDR_DELETED = 11019
Private Const IP_SPEC_MTU_CHANGE = 11020
Private Const IP_MTU_CHANGE = 11021
Private Const IP_UNLOAD = 11022
Private Const IP_ADDR_ADDED = 11023
Private Const IP_MEDIA_CONNECT = 11024
Private Const IP_MEDIA_DISCONNECT = 11025
Private Const IP_BIND_ADAPTER = 11026
Private Const IP_UNBIND_ADAPTER = 11027
Private Const IP_DEVICE_DOES_NOT_EXIST = 11028
Private Const IP_DUPLICATE_ADDRESS = 11029
Private Const IP_INTERFACE_METRIC_CHANGE = 11030
Private Const IP_RECONFIG_SECFLTR = 11031
Private Const IP_NEGOTIATING_IPSEC = 11032
Private Const IP_INTERFACE_WOL_CAPABILITY_CHANGE = 11033
Private Const IP_DUPLICATE_IPADD = 11034
Private Const IP_GENERAL_FAILURE = 11050
Private Const MAX_IP_STATUS = 11050
Private Const IP_PENDING = 11255
'Constant from winsock2.h
Private Const INADDR_NONE = &HFFFFFFFF
Private Const WSADESCRIPTION_LEN = 128 '(String * 1 = 2 byte)
Private Const WSASYS_STATUS_LEN = 64 '(String * 1 = 2 byte)
Private Type ICMP_OPTIONS
'Ttl As byte
'Tos As byte
'Flags As byte
'OptionsSize As byte
Replacement As Long 'long is 4 bytes (String * 1 = 2 byte)
OptionsData As Long
End Type
Public Type ICMP_ECHO_REPLY
Address As Long
status As Long
RoundTripTime As Long
DataSize As Long
DataPointer As Long
Options As ICMP_OPTIONS
Data As String * 250
End Type
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription As String * WSADESCRIPTION_LEN
szSystemStatus As String * WSASYS_STATUS_LEN
wMaxSockets As Long
wMaxUDPDG As Long
dwVendorInfo As Long
End Type
Declare Private Function IcmpCreateFile Lib "icmp.dll" () As Long
Declare Private Function IcmpCloseHandle Lib "icmp.dll" (Byval IcmpHandle As Long) As Long
Declare Private Function IcmpSendEcho Lib "icmp.dll" (Byval IcmpHandle As Long, _
Byval DestinationAddress As Long, Byval RequestData As String, Byval RequestSize As Long, _
Byval RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, Byval ReplySize As Long, _
Byval Timeout As Long) As Long
Declare Private Function WSAStartup Lib "wsock32" (Byval wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Declare Private Function WSACleanup Lib "wsock32" () As Long
Declare Private Function inet_addr Lib "wsock32" (Byval s As String) As Long
%REM How to select W_VERSION_REQUESTED:
This negotiation allows both a WS2_32.DLL and a Windows Sockets application to support a range of Windows Sockets versions.
An application can use WS2_32.DLL if there is any overlap in the version ranges. The following chart gives examples of how
WSAStartup works in conjunction with different application and WS2_32.DLL versions:
App versions DLL Versions wVersionRequested wVersion wHighVersion End Result
1.1 1.1 1.1 1.1 1.1 use 1.1
1.0 1.1 1.0 1.1 1.0 1.0 use 1.0
1.0 1.0 1.1 1.0 1.0 1.1 use 1.0
1.1 1.0 1.1 1.1 1.1 1.1 use 1.1
1.1 1.0 1.1 1.0 1.0 Application fails
1.0 1.1 1.0 --- --- WSAVERNOT SUPPORTED
1.0 1.1 1.0 1.1 1.1 1.1 1.1 use 1.1
1.1 2.0 1.1 2.0 1.1 1.1 use 1.1
2.0 2.0 2.0 2.0 2.0 use 2.0
1.1 = &H0101
1.0 = &H0100
2.0 = &H0200
%END REM
Private Const W_VERSION_REQUESTED = &H1101
'The time in milliseconds to wait for replies. Change if you have problems
Private Const PING_TIMEOUT = 500
'My constants
Private Const WSA_SUCCESS = 0
Public Class MyPing
Private lStatus As Long
Private ECHO As ICMP_ECHO_REPLY
Public Property Get Status As String
Status = ConvertStatusToString(lStatus)
End Property
Public Property Get Address As String
Dim lAdr As Long
Dim lTmp4 As Long
Dim lTmp3 As Long
Dim lTmp2 As Long
Dim lTmp1 As Long
lAdr = ECHO.Address
lTmp4 = lAdr Mod 256
lTmp3 = lAdr 256
lTmp3 = lTmp3 Mod 256
lTmp2 = lAdr 256
lTmp2 = lTmp2 256
lTmp2 = ltmp2 Mod 256
lTmp1 = lAdr256
lTmp1 = lTmp1256
lTmp1 = lTmp1256
Address = lTmp4 & "." & lTmp3 & "." & lTmp2 & "." & lTmp1
End Property
Public Property Get TripTime As Long 'in ms
TripTime = ECHO.RoundTripTime
End Property
Public Property Get DataSize As String ' in byte
DataSize = ECHO.DataSize
End Property
Public Property Get Data As String
Dim nPos As Integer
Data =""
If Left$(ECHO.Data, 1) <> Chr$(0) Then
nPos = Instr(ECHO.Data, Chr$(0))
Data = Left$(ECHO.Data, nPos - 1)
End If
End Property
Private Function ConvertStatusToString(lStatus As Long) As String
Dim strStatus As String
Select Case lStatus
Case IP_SUCCESS:
strStatus = "IP Success"
Case INADDR_NONE:
strStatus = "Function: inet_addr: Bad IP"
Case IP_BUF_TOO_SMALL:
strStatus = "IP Buffer Too Small"
Case IP_DEST_NET_UNREACHABLE:
strStatus = "IP Network Destination Unreachable"
Case IP_DEST_HOST_UNREACHABLE:
strStatus = "IP Host Destination Unreachable"
Case IP_DEST_PROT_UNREACHABLE:
strStatus = "IP Protocol Destination Unreachable"
Case IP_DEST_PORT_UNREACHABLE:
strStatus = "IP Port Destination Unreachable"
Case IP_NO_RESOURCES:
strStatus = "IP No Resources"
Case IP_BAD_OPTION:
strStatus = "IP Bad Option"
Case IP_HW_ERROR:
strStatus = "IP HW Error"
Case IP_PACKET_TOO_BIG:
strStatus = "IP Packet Too Big"
Case IP_REQ_TIMED_OUT:
strStatus = "IP Requested Time Out"
Case IP_BAD_REQ:
strStatus = "IP Bad Request"
Case IP_BAD_ROUTE:
strStatus = "IP Bad Route"
Case IP_TTL_EXPIRED_TRANSIT:
strStatus = "IP TTL Expired Transit"
Case IP_TTL_EXPIRED_REASSEM:
strStatus = "IP TTL Expired Reassem"
Case IP_PARAM_PROBLEM:
strStatus = "IP Parameter Problem"
Case IP_SOURCE_QUENCH:
strStatus = "IP Source Quench"
Case IP_OPTION_TOO_BIG:
strStatus = "IP Option Too Big"
Case IP_BAD_DESTINATION:
strStatus = "IP Bad Destination"
Case IP_ADDR_DELETED:
strStatus = "IP Address Deleted"
Case IP_SPEC_MTU_CHANGE:
strStatus = "IP SPEC MTU Change"
Case IP_MTU_CHANGE:
strStatus = "IP MTU Change"
Case IP_UNLOAD:
strStatus = "IP Unload"
Case IP_ADDR_ADDED:
strStatus = "IP Address Added"
Case IP_GENERAL_FAILURE:
strStatus = "IP General Failure"
Case IP_MEDIA_CONNECT:
strStatus = "IP Media Connected"
Case IP_MEDIA_DISCONNECT:
strStatus = "IP Media Disconnected"
Case IP_BIND_ADAPTER:
strStatus = "IP Bind Adapter"
Case IP_UNBIND_ADAPTER:
strStatus = "IP Unbind Adapter"
Case IP_DEVICE_DOES_NOT_EXIST:
strStatus = "IP Device doesn't Exist"
Case IP_DUPLICATE_ADDRESS :
strStatus = "IP Duplicate Address"
Case IP_INTERFACE_METRIC_CHANGE:
strStatus = "IP Interface Metric Change"
Case IP_RECONFIG_SECFLTR:
strStatus = "IP Reconfig Secfltr"
Case IP_NEGOTIATING_IPSEC:
strStatus = "IP Nogotiating IPSec"
Case IP_INTERFACE_WOL_CAPABILITY_CHANGE:
strStatus = "IP Interface WOL Compatibility Change"
Case IP_DUPLICATE_IPADD:
strStatus = "IP Duplicate IP Address"
Case IP_PENDING:
strStatus = "IP Pending"
Case PING_TIMEOUT:
strStatus = "Ping TIMEOUT"
Case Else:
strStatus = "Unknown"
End Select
ConvertStatusToString = strStatus
End Function
Public Sub delete
If WSACleanup() <> IP_SUCCESS Then
Msgbox "Error occurred in cleanup.", 16, "HALPing class"
End If
End Sub
Public Sub Ping(strAddress As String, strData As String)
Dim hPort As Long
Dim dwAddress As Long
dwAddress = inet_addr(strAddress)
If dwAddress <> INADDR_NONE Then
hPort = IcmpCreateFile()
If hPort Then
Call IcmpSendEcho(hPort, dwAddress, strData, Len(strData), 0, ECHO, Len(ECHO), PING_TIMEOUT)
lStatus = ECHO.status
Call IcmpCloseHandle(hPort)
End If
Else
lStatus = INADDR_NONE
End If
End Sub
Public Function PrepareSocket() As Variant
Dim tmpWSAD As WSADATA
PrepareSocket = False
If WSAStartup(W_VERSION_REQUESTED, tmpWSAD) = WSA_SUCCESS Then
PrepareSocket = True
End If
End Function
End Class
This was first published in May 2002