title image


Smiley Re: vb-script für ping
hi



schau Dir mal folgenden Code an, hab ich vor kurzem mal gepostet. Das Programm führt für alle IPs, die in der ersten Spalte einer Excel-Tabelle stehen, einen Ping durch und schreibt neben der IP (in Spalte 2) den Status hin. Hab nur ein Timer-Ereignis hinzugefügt, das nach der in Form_Load festgelegten Zeit ausgelöst wird:



im Formular:





Option Explicit



Private Sub Form_Load()

Timer1.Enabled = True

Timer1.Intervall = 15000 'gewünschter Wert in ms

End Sub



Private Sub Timer1_Timer()

pingen

End Sub



Private Sub pingen()

Dim ECHO As ICMP_ECHO_REPLY

Dim zeile As Long



zeile = 1



While Cells(zeile, 1) ""

'Die Ping-Funktion aufrufen:

Call ping(Trim$(Cells(zeile, 1)), ECHO)

Cells(zeile, 2) = GetStatusCode(ECHO.Status)

zeile = zeile + 1

Wend

End Sub





und im Modul:





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 + 8)

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 + 18)

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



'Variablen:

'==========



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 ("Fehler bei der SocketInitialisierung!")

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 lieferte ungültiges Ergebnis!")

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$("010101")

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





Hab ich das richtig verstanden? Du brauchst das für VB-Skript? Dann is wohl nix mit Excel...kannst den Code ja noch umbauen

Gruße
Mike


Hier gehts zu meiner Homepage mikeshomepage.de

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: