r@nger

SERVERLARA PİNG ATMAK:
------------------- Anfang Code Module1 -------------------

Option Explicit

Private Declare Function IcmpCreateFile Lib "icmp.dll" () _
As Long

Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal _
IcmpHandle As Long) As Long

Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal _
IcmpHandle As Long, ByVal DestinationAddress As Long, _
ByVal RequestData As String, ByVal RequestSize As _
Integer, ByVal RequestOptions As Long, ReplyBuffer As _
ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal _
TimeOut As Long) As Long

Private Declare Function WSAGetLastError Lib "wsock32.dll" () _
As Long

Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal _
wVersionRequired As Long, lpWSAData As WSAData) As Long

Private Declare Function WSACleanUp Lib "wsock32.dll"Alias _
"WSACleanup" () As Long

Private Declare Function GetHostName Lib "wsock32.dll"Alias _
"gethostname" (ByVal szHost As String, ByVal dwHostLen _
As Long) As Long

Private Declare Function GetHostByName Lib "wsock32.dll"Alias _
"gethostbyname" (ByVal szHost As String) As Long

Private Declare Sub CopyMemory Lib "kernel32"Alias _
"RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As _
Long, ByVal cbCopy As Long)

Private Declare Function htonl Lib "wsock32.dll" (ByVal hostlong _
As Long) As Long

Private Declare Function htons Lib "wsock32.dll" (ByVal hostshort _
As Long) As Integer

Private Declare Function inet_addr Lib "wsock32.dll" (ByVal cp _
As String) As Long

Private Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn _
As Long) As Long

Private Declare Function ntohl Lib "wsock32.dll" (ByVal netlong _
As Long) As Long

Private Declare Function ntohs Lib "wsock32.dll" (ByVal netshort _
As Long) As Integer

Private Type ICMP_OPTIONS
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type

Public Type ICMP_ECHO_REPLY
Address As Long
Status As Long
RoundTripTime As Long
DataSize As Integer
Reserved As Integer
DataPointer As Long
Options As ICMP_OPTIONS
Data As String * 250
End Type

Private Type hostent
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type

Const MAX_WSADescription = 256
Const MAX_WSASYSStatus = 128
Const MAXGETHOSTSTRUCT = 1024

Private Type WSAData
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Integer
wMaxUDPDG As Integer
dwVendorInfo As Long
End Type

Private Type hostent_async
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
h_asyncbuffer(MAXGETHOSTSTRUCT) As Byte
End Type

Const IP_STATUS_BASE = 11000
Const IP_SUCCESS = 0
Const IP_BUF_TOO_SMALL = (11000 + 1)
Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Const IP_NO_RESOURCES = (11000 + 6)
Const IP_BAD_OPTION = (11000 + 7)
Const IP_HW_ERROR = (11000 + Cool
Const IP_PACKET_TOO_BIG = (11000 + 9)
Const IP_REQ_TIMED_OUT = (11000 + 10)
Const IP_BAD_REQ = (11000 + 11)
Const IP_BAD_ROUTE = (11000 + 12)
Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Const IP_PARAM_PROBLEM = (11000 + 15)
Const IP_SOURCE_QUENCH = (11000 + 16)
Const IP_OPTION_TOO_BIG = (11000 + 17)
Const IP_BAD_DESTINATION = (11000 + 1Cool
Const IP_ADDR_DELETED = (11000 + 19)
Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Const IP_MTU_CHANGE = (11000 + 21)
Const IP_UNLOAD = (11000 + 22)
Const IP_ADDR_ADDED = (11000 + 23)
Const IP_GENERAL_FAILURE = (11000 + 50)
Const MAX_IP_STATUS = 11000 + 50
Const IP_PENDING = (11000 + 255)
Const PING_TIMEOUT = 200
Const WS_VERSION_REQD = &H101
Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Const MIN_SOCKETS_REQD = 1
Const SOCKET_ERROR = -1
Const INADDR_NONE = &HFFFFFFFF

'Degiskenler
'==========

Public Const hostent_size = 16
Public PointerToPointer, IPLong As Long

Dim hostent_async As hostent_async
Dim ICMPOPT As ICMP_OPTIONS

Public Function GetHost(ByVal Host$) As Long
Dim ListAddress As Long
Dim ListAddr As Long
Dim LH&, phe&
Dim Start As Boolean
Dim heDestHost As hostent
Dim addrList&, repIP&

Start = SocketsInitialize
If Start = False Then
GetHost = 0
MsgBox ("Socket Hatasi!")
Exit Function
End If

LH = inet_addr(Host$)
repIP = LH
If LH = INADDR_NONE Then
phe = GetHostByName(Host$)
If phe <> 0 Then
CopyMemory heDestHost, ByVal phe, hostent_size
CopyMemory addrList, ByVal heDestHost.hAddrList, 4
CopyMemory repIP, ByVal addrList, heDestHost.hLen
Else
Call MsgBox("GetHostByName yanlis deger gönderdi!")
GetHost = INADDR_NONE
Exit Function
End If
End If
Form1.Text4.Text = CStr(repIP)
GetHost = repIP
End Function

Public Function GetStatusCode(Status As Long) As String
Dim Msg As String

Select Case Status
Case IP_SUCCESS: Msg = "ip success"
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 = CStr(Status) & " [ " & Msg & " ]"
End Function
Private Function HiByte(ByVal wParam As Integer)
HiByte = wParam \ &H100 And &HFF&
End Function

Private Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function

Public Function Ping(szAddress As String, _
ECHO As ICMP_ECHO_REPLY) As Long

Dim hPort As Long
Dim dwAddress As Long
Dim sDataToSend As String
Dim iOpt As Long
Dim a

sDataToSend = Trim$(Form1.Text3.Text)
dwAddress = GetHost(szAddress)

hPort = IcmpCreateFile()

If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), _
0, ECHO, Len(ECHO), PING_TIMEOUT) Then

Ping = ECHO.RoundTripTime
Else: Ping = ECHO.Status * -1
End If

Call IcmpCloseHandle(hPort)
a = SocketsCleanup
End Function

Private Function AddressStringToLong(ByVal Tmp As String) As Long
Dim i As Integer
Dim parts(1 To 4) As String

i = 0
While InStr(Tmp, ".") > 0
i = i + 1
parts(i) = Mid(Tmp, 1, InStr(Tmp, ".") - 1)
Tmp = Mid(Tmp, InStr(Tmp, ".") + 1)
Wend

i = i + 1
parts(i) = Tmp

If i <> 4 Then
AddressStringToLong = 0
Exit Function
End If

AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _
Right("00" & Hex(parts(3)), 2) & _
Right("00" & Hex(parts(2)), 2) & _
Right("00" & Hex(parts(1)), 2))
End Function

Private Function SocketsCleanup() As Boolean
Dim X As Long

X = WSACleanUp()
If X <> 0 Then
Call MsgBox("Windows Sockets error " & Trim$(Str$(X)) & _
" occurred in Cleanup.", vbExclamation)
SocketsCleanup = False
Else
SocketsCleanup = True
End If
End Function

Private Function SocketsInitialize() As Boolean
Dim WSAD As WSAData
Dim X As Integer

Dim szLoByte As String, szHiByte As String, szBuf As String

X = WSAStartup(WS_VERSION_REQD, WSAD)
If X <> 0 Then
Call MsgBox("Windows Sockets for 32 bit Windows " & _
"environments is not successfully responding.")
SocketsInitialize = False
Exit Function
End If

SocketsInitialize = True
End Function

'-------------------- Kod Module1 Sonu--------------------

'-------------------- Kod Form1 ---------------------------

Option Explicit

Private Sub Command1_Click()
Dim ECHO As ICMP_ECHO_REPLY
Dim pos As Integer

'Ping Fonksiyonunu cagir
Call Ping(Trim$(Text2.Text), ECHO)

'Sonucu Göster
Text1(0) = GetStatusCode(ECHO.Status)
Text1(1) = ECHO.Address
Text1(2) = ECHO.RoundTripTime & " ms"
Text1(3) = ECHO.DataSize & " bytes"

If Left$(ECHO.Data, 1) <> Chr$(0) Then
pos = InStr(ECHO.Data, Chr$(0))
Text1(4) = Left$(ECHO.Data, pos - 1)
End If

Text1(5) = ECHO.DataPointer
End Sub

ALINTIDIR

__________________
Geri döndüm