Option Strict Off
Imports System.Runtime.InteropServices
Module Module1
Public Const IP_SUCCESS As Integer = 0
Public Const IP_STATUS_BASE As Integer = 11000
Public Const IP_BUF_TOO_SMALL As Integer = (11000 + 1)
Public Const IP_DEST_NET_UNREACHABLE As Integer = (11000 + 2)
Public Const IP_DEST_HOST_UNREACHABLE As Integer = (11000 + 3)
Public Const IP_DEST_PROT_UNREACHABLE As Integer = (11000 + 4)
Public Const IP_DEST_PORT_UNREACHABLE As Integer = (11000 + 5)
Public Const IP_NO_RESOURCES As Integer = (11000 + 6)
Public Const IP_BAD_OPTION As Integer = (11000 + 7)
Public Const IP_HW_ERROR As Integer = (11000 + 8)
Public Const IP_PACKET_TOO_BIG As Integer = (11000 + 9)
Public Const IP_REQ_TIMED_OUT As Integer = (11000 + 10)
Public Const IP_BAD_REQ As Integer = (11000 + 11)
Public Const IP_BAD_ROUTE As Integer = (11000 + 12)
Public Const IP_TTL_EXPIRED_TRANSIT As Integer = (11000 + 13)
Public Const IP_TTL_EXPIRED_REASSEM As Integer = (11000 + 14)
Public Const IP_PARAM_PROBLEM As Integer = (11000 + 15)
Public Const IP_SOURCE_QUENCH As Integer = (11000 + 16)
Public Const IP_OPTION_TOO_BIG As Integer = (11000 + 17)
Public Const IP_BAD_DESTINATION As Integer = (11000 + 18)
Public Const IP_ADDR_DELETED As Integer = (11000 + 19)
Public Const IP_SPEC_MTU_CHANGE As Integer = (11000 + 20)
Public Const IP_MTU_CHANGE As Integer = (11000 + 21)
Public Const IP_UNLOAD As Integer = (11000 + 22)
Public Const IP_ADDR_ADDED As Integer = (11000 + 23)
Public Const IP_GENERAL_FAILURE As Integer = (11000 + 50)
Public Const MAX_IP_STATUS As Integer = (11000 + 50)
Public Const IP_PENDING As Integer = (11000 + 255)
Public Const PING_TIMEOUT As Integer = 500
Public Const WS_VERSION_REQD As Integer = &H101S
'Public Const WS_VERSION_REQD As Integer = &H202S
Public Const MIN_SOCKETS_REQD As Integer = 1
Public Const SOCKET_ERROR As Integer = -1
Public Const INADDR_NONE As Integer = &HFFFFFFFF
Public Const MAX_WSADescription As Integer = 256
Public Const MAX_WSASYSStatus As Integer = 128
Public Structure ICMP_OPTIONS
Dim Ttl As Byte
Dim Tos As Byte
Dim Flags As Byte
Dim OptionsSize As Byte
Dim OptionsData As Integer
End Structure
<StructLayout(LayoutKind.Sequential)> Public Structure ICMP_ECHO_REPLY
Dim Address As Integer
Dim status As Integer
Dim RoundTripTime As Integer
Dim DataSize As Integer 'formerly integer
Dim DataPointer As Integer
Dim Options As ICMP_OPTIONS
<VBFixedString(250), System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValTStr, SizeConst:=250)> Public Data As String
End Structure
<StructLayout(LayoutKind.Sequential)> Public Structure WSADATA
<FieldOffset(0)> Dim wVersion As Short
<FieldOffset(2)> Dim wHighVersion As Short
<VBFixedArray(MAX_WSADescription)> Dim szDescription() As Byte
<VBFixedArray(MAX_WSASYSStatus)> Dim szSystemStatus() As Byte
Dim wMaxSockets As Integer
Dim wMaxUDPDG As Integer
Dim dwVendorInfo As Integer
Public Sub Initialize()
ReDim szDescription(MAX_WSADescription)
ReDim szSystemStatus(MAX_WSASYSStatus)
End Sub
End Structure
Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Integer
Public Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Integer) As Integer
Public Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Integer, _
ByVal DestinationAddress As Integer, _
ByVal RequestData As String, _
ByVal RequestSize As Integer, _
ByVal RequestOptions As Integer, _
ByRef ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Integer, _
ByVal Timeout As Integer) As Integer
Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Integer
Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Integer, _
ByVal lpWSADATA As WSADATA) As Integer
Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Integer
Public Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, _
ByVal dwHostLen As Integer) As Integer
Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Integer
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef xDest As String, _
ByRef xSource As String, _
ByVal nbytes As Integer)
Public Declare Function inet_addr Lib "WSOCK32.DLL" (ByVal s As String) As Integer
Public Function GetStatusCode(ByRef status As Integer) As String
Dim msg As String
Select Case status
Case IP_SUCCESS : msg = "ip success"
Case INADDR_NONE : msg = "inet_addr: bad IP format"
Case IP_BUF_TOO_SMALL : msg = "ip buf too_small"
Case IP_DEST_NET_UNREACHABLE : msg = "ip dest net unreachable"
Case IP_DEST_HOST_UNREACHABLE : msg = "ip dest host unreachable"
Case IP_DEST_PROT_UNREACHABLE : msg = "ip dest prot unreachable"
Case IP_DEST_PORT_UNREACHABLE : msg = "ip dest port unreachable"
Case IP_NO_RESOURCES : msg = "ip no resources"
Case IP_BAD_OPTION : msg = "ip bad option"
Case IP_HW_ERROR : msg = "ip hw_error"
Case IP_PACKET_TOO_BIG : msg = "ip packet too_big"
Case IP_REQ_TIMED_OUT : msg = "ip req timed out"
Case IP_BAD_REQ : msg = "ip bad req"
Case IP_BAD_ROUTE : msg = "ip bad route"
Case IP_TTL_EXPIRED_TRANSIT : msg = "ip ttl expired transit"
Case IP_TTL_EXPIRED_REASSEM : msg = "ip ttl expired reassem"
Case IP_PARAM_PROBLEM : msg = "ip param_problem"
Case IP_SOURCE_QUENCH : msg = "ip source quench"
Case IP_OPTION_TOO_BIG : msg = "ip option too_big"
Case IP_BAD_DESTINATION : msg = "ip bad destination"
Case IP_ADDR_DELETED : msg = "ip addr deleted"
Case IP_SPEC_MTU_CHANGE : msg = "ip spec mtu change"
Case IP_MTU_CHANGE : msg = "ip mtu_change"
Case IP_UNLOAD : msg = "ip unload"
Case IP_ADDR_ADDED : msg = "ip addr added"
Case IP_GENERAL_FAILURE : msg = "ip general failure"
Case IP_PENDING : msg = "ip pending"
Case PING_TIMEOUT : msg = "ping timeout"
Case Else : msg = "unknown msg returned"
End Select
GetStatusCode = msg
End Function
Public Function Ping(ByRef sAddress As String, ByRef sDataToSend As String, ByRef ECHO As ICMP_ECHO_REPLY) As Integer
Dim hPort As Integer
Dim dwAddress As Integer
dwAddress = inet_addr(sAddress)
If dwAddress <> INADDR_NONE Then
hPort = IcmpCreateFile() 'open a port
If hPort Then
Call IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, ECHO, Len(ECHO), PING_TIMEOUT)
Ping = ECHO.status
'Debug.WriteLine("Address:" & ECHO.Address)
'Debug.WriteLine("status:" & ECHO.status)
'Debug.WriteLine("RoundTripTime:" & ECHO.RoundTripTime)
'Debug.WriteLine("DataSize :" & ECHO.DataSize)
'Debug.WriteLine("DataPointer:" & ECHO.DataPointer)
'Debug.WriteLine("TTL:" & ECHO.Options.Ttl)
'Debug.WriteLine("TOS:" & ECHO.Options.Tos)
Call IcmpCloseHandle(hPort)
End If
Else
Ping = INADDR_NONE
End If
End Function
Public Sub SocketsCleanup()
Dim rc As Integer
rc = WSACleanup()
If rc <> 0 Then
'If WSACleanup() <> 0 Then 実行しなくても大丈夫（？）です
' MsgBox("Windows Sockets error occurred in Cleanup.", MsgBoxStyle.Exclamation)
End If
End Sub
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
Dim rc As Integer
WSAD.Initialize()
rc = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
If rc = 0 Then
SocketsInitialize = True
Else
SocketsInitialize = False
End If
End Function
End Module
|