Solved

How to ping with VB6?

Posted on 2006-11-03
8
9,307 Views
Last Modified: 2012-06-22
Hello, i'd like to write a program in VB6 with a ping function, can anyone tell me how to realize this? Or give me a link to a module? (<-- I'd prefer this solution :)

thank you!
-beda79
0
Comment
Question by:beda79
8 Comments
 
LVL 6

Expert Comment

by:manch
ID: 17864989
'To run this program, you must set the startup object to 'Sub Main'
'You can do this by going to Project->Project Properties->Startup Object
'In a module
Private Const PLATFORM_ID_DOS = 300
Private Const PLATFORM_ID_OS2 = 400
Private Const PLATFORM_ID_NT = 500
Private Const PLATFORM_ID_OSF = 600
Private Const PLATFORM_ID_VMS = 700

Private Type WKSTA_INFO_102
   wki100_platform_id As Long
   pwki100_computername As Long
   pwki100_langroup As Long
   wki100_ver_major As Long
   wki100_ver_minor As Long
   pwki102_lanroot As Long
   wki102_logged_on_users As Long
End Type

Declare Function NetWkstaGetInfo Lib "netapi32" (ByVal servername As String, ByVal level As Long, lpBuf As Any) As Long
Declare Function NetApiBufferFree Lib "netapi32" (ByVal Buffer As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Sub Main()
   'code submitted by Andreas Linnemann (ALinnemann@gmx.de)
   Dim pWrkInfo As Long, WrkInfo(0) As WKSTA_INFO_102, lResult As Long
   'make sure you replace the value of the following constant
   'with a valid computer name from your LAN
   Const strComputername = "YourComputerName"
   lResult = NetWkstaGetInfo(StrConv("\\" & strComputername, vbUnicode), 102, pWrkInfo)
   If lResult = 0 Then
      Dim cname As String
      cname = String$(255, 0)
      CopyMemory WrkInfo(0), ByVal pWrkInfo, ByVal Len(WrkInfo(0))
      CopyMemory ByVal cname, ByVal WrkInfo(0).pwki100_langroup, ByVal 255
      Debug.Print "Domain: " & StripTerminator(StrConv(cname, vbFromUnicode))
      Debug.Print "Operating System: ";
      Select Case WrkInfo(0).wki100_platform_id
         Case PLATFORM_ID_DOS: Debug.Print "DOS"
         Case PLATFORM_ID_OS2:
                     If WrkInfo(0).wki100_ver_major = "4" Then
                        Debug.Print "Win9x"
                     Else
                        Debug.Print "OS2"
                     End If
         Case PLATFORM_ID_NT:
                     If WrkInfo(0).wki100_ver_major = "5" Then
                        Debug.Print "Win 2000"
                     Else
                        Debug.Print "Win NT"
                     End If
         Case PLATFORM_ID_OSF: Debug.Print "OSF"
         Case PLATFORM_ID_VMS: Debug.Print "VMS"
      End Select
      Debug.Print " Version "; WrkInfo(0).wki100_ver_major; "."; WrkInfo(0).wki100_ver_minor
      Debug.Print "Lan Root: ";
      cname = String$(255, 0)
      CopyMemory ByVal cname, ByVal WrkInfo(0).pwki102_lanroot, ByVal 255
      Debug.Print StripTerminator(StrConv(cname, vbFromUnicode))
      Debug.Print "Logged User: "; Str$(WrkInfo(0).wki102_logged_on_users), vbBlack
      NetApiBufferFree ByVal pWrkInfo
   End If
End Sub
'This function is used to stripoff all the unnecessary chr$(0)'s
Private Function StripTerminator(sInput As String) As String
    Dim ZeroPos As Integer
    'Search the first chr$(0)
    ZeroPos = InStr(1, sInput, vbNullChar)
    If ZeroPos > 0 Then
        StripTerminator = Left$(sInput, ZeroPos - 1)
    Else
        StripTerminator = sInput
    End If
End Function

Try It
0
 

Author Comment

by:beda79
ID: 17865671
Can you give me some more info on how to use this? i copied the declarations into a module and everything from sub_main into the normal code, still didn't work
0
 
LVL 26

Accepted Solution

by:
EDDYKT earned 250 total points
ID: 17865720
add the following to module


Option Explicit

Public Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000

Public Const WS32_NOT_ENOUGH_SOCKETS = -4
Public Const WS32_NOT_SUPPORTED = -3
Public Const WS32_NOT_RESPONDING = -2
Public Const IP_STATUS_BASE = 11000
Public Const IP_SUCCESS = 0
Public Const IP_BUF_TOO_SMALL = (11000 + 1)
Public Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Public Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Public Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Public Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Public Const IP_NO_RESOURCES = (11000 + 6)
Public Const IP_BAD_OPTION = (11000 + 7)
Public Const IP_HW_ERROR = (11000 + 8)
Public Const IP_PACKET_TOO_BIG = (11000 + 9)
Public Const IP_REQ_TIMED_OUT = (11000 + 10)
Public Const IP_BAD_REQ = (11000 + 11)
Public Const IP_BAD_ROUTE = (11000 + 12)
Public Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Public Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Public Const IP_PARAM_PROBLEM = (11000 + 15)
Public Const IP_SOURCE_QUENCH = (11000 + 16)
Public Const IP_OPTION_TOO_BIG = (11000 + 17)
Public Const IP_BAD_DESTINATION = (11000 + 18)
Public Const IP_ADDR_DELETED = (11000 + 19)
Public Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Public Const IP_MTU_CHANGE = (11000 + 21)
Public Const IP_UNLOAD = (11000 + 22)
Public Const IP_ADDR_ADDED = (11000 + 23)
Public Const IP_GENERAL_FAILURE = (11000 + 50)
Public Const MAX_IP_STATUS = 11000 + 50
Public Const IP_PENDING = (11000 + 255)
Public Const PING_TIMEOUT = 200
Public Const WS_VERSION_REQD = &H101
Public Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD = 1
Public Const SOCKET_ERROR = -1
Public Const WSADescription_Len = 256
Public Const WSASYS_Status_Len = 128
Public 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
Public Type HOSTENT
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLength As Integer
    hAddrList As Long
End Type
Public Type LHOSTENTRY
    hName As String
    hAddress As String
    hStatus As String
End Type
Public 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
    iMaxUdpDg As Integer
    lpszVendorInfo As Long
End Type
Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Public Declare Function IcmpCloseHandle Lib "icmp.dll" _
    (ByVal IcmpHandle As Long) As Long
Public 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
Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Public Declare Function WSAStartup Lib "WSOCK32.DLL" _
   (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Public Declare Function gethostname Lib "WSOCK32.DLL" _
   (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Public Declare Function gethostbyname Lib "WSOCK32.DLL" _
   (ByVal szHost As String) As Long
Public Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, _
    ByVal hpvSource As Long, ByVal cbCopy As Long)
Public G_lhEntry As LHOSTENTRY

Public Function IsHostAlive(lHost As String) As Boolean
    Dim ECHO As ICMP_ECHO_REPLY
    Dim pos As Integer
   
    On Error Resume Next
    IsHostAlive = False
    SysPing lHost, ECHO
    If ECHO.status = IP_SUCCESS Then IsHostAlive = True
End Function

Public Function CvtHiByte(ByVal wParam As Integer)

    On Error Resume Next
    CvtHiByte = wParam \ &H100 And &HFF&
End Function

Public Function CvtLoByte(ByVal wParam As Integer)

    On Error Resume Next
    CvtLoByte = wParam And &HFF&
End Function

Public Function GetPingString(lHost As String) As String
    Dim ECHO As ICMP_ECHO_REPLY
    Dim pos As Integer
    SysPing lHost, ECHO
   
    On Error Resume Next
    If ECHO.status = IP_SUCCESS Then
        GetPingString = "Reply from " & G_lhEntry.hAddress & ": bytes=" & Trim$(CStr(ECHO.DataSize)) _
            & " time=" & Trim$(CStr(ECHO.RoundTripTime)) & "ms TTL=" _
            & Trim$(CStr(ECHO.Options.Ttl))
    Else
        GetPingString = GetPingMsg(ECHO.status)
    End If
End Function

Public Function GetPingMsg(status As Long) As String
    Dim msg As String
   
    On Error Resume Next
    Select Case status
        Case WS32_NOT_ENOUGH_SOCKETS:  msg = "Not enough sockets available"
        Case WS32_NOT_SUPPORTED:       msg = "Socket version not supported"
        Case WS32_NOT_RESPONDING:      msg = "Winsock 32 not responding"
        Case IP_SUCCESS:               msg = "OK"
        Case IP_BUF_TOO_SMALL:         msg = "IP buf too small"
        Case IP_DEST_NET_UNREACHABLE:  msg = "Destination network unreachable"
        Case IP_DEST_HOST_UNREACHABLE: msg = "Destination host unreachable"
        Case IP_DEST_PROT_UNREACHABLE: msg = "Destination protocol unreachable"
        Case IP_DEST_PORT_UNREACHABLE: msg = "Destination port unreachable"
        Case IP_NO_RESOURCES:          msg = "IP no resources"
        Case IP_BAD_OPTION:            msg = "IP bad option"
        Case IP_HW_ERROR:              msg = "IP hardware error"
        Case IP_PACKET_TOO_BIG:        msg = "IP packet too big"
        Case IP_REQ_TIMED_OUT:         msg = "Request timed out"
        Case IP_BAD_REQ:               msg = "Bad request"
        Case IP_BAD_ROUTE:             msg = "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 address 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 address 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 message returned"
    End Select
    GetPingMsg = msg
End Function

Public Function GetHostInfo(lHost As String) As LHOSTENTRY
    Dim WSAD As WSADATA
    Dim Rval As Long
    Dim hostname As String * 256
    Dim hostent_addr As Long
    Dim host As HOSTENT
    Dim hostip_addr As Long
    Dim temp_ip_address() As Byte
    Dim ival As Integer
    Dim ip_address As String
     
    On Error Resume Next
    Rval = WSAStartup(WS_VERSION_REQD, WSAD)
    If Rval <> 0 Then
        GetHostInfo.hStatus = WS32_NOT_RESPONDING
        Exit Function
    End If
    If CvtLoByte(WSAD.wversion) < WS_VERSION_MAJOR Or _
       (CvtLoByte(WSAD.wversion) = WS_VERSION_MAJOR And _
        CvtHiByte(WSAD.wversion) < WS_VERSION_MINOR) Then
        GetHostInfo.hStatus = WS32_NOT_SUPPORTED
        WSACleanup
        Exit Function
    End If
    If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
        GetHostInfo.hStatus = WS32_NOT_ENOUGH_SOCKETS
        WSACleanup
        Exit Function
    End If
     
    GetHostInfo.hStatus = SOCKET_ERROR
    GetHostInfo.hName = Trim$(LCase$(lHost))
    hostname = Left$(lHost + String(256, Chr$(0)), 256)
    If (CheckIPAddress(lHost) = False) Then
        hostent_addr = gethostbyname(hostname)
        If hostent_addr = 0 Then
            WSACleanup
            Exit Function
        End If
        RtlMoveMemory host, hostent_addr, LenB(host)
        RtlMoveMemory hostip_addr, host.hAddrList, 4
        ReDim temp_ip_address(1 To host.hLength)
        RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
        For ival = 1 To host.hLength
            ip_address = ip_address & temp_ip_address(ival) & "."
        Next
        ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
    Else
        ip_address = lHost
    End If
    GetHostInfo.hAddress = ip_address
    GetHostInfo.hStatus = IP_SUCCESS
    WSACleanup
End Function

Public Function SysPing(lhostname As String, ECHO As ICMP_ECHO_REPLY, Optional EchoString As String) As Long
    Dim WSAD As WSADATA
    Dim hPort As Long
    Dim dwAddr As Long
    Dim iOpt As Long
    Dim Rval As Long
    Dim eString As String
    Dim szLoByte As String
    Dim szHiByte As String
    Dim szBuf As String
   
    On Error Resume Next
    eString = "ABCDEFGHIJKLMNOPQRSTUVWXYZ012345": If Not EchoString = "" Then eString = EchoString
    G_lhEntry = GetHostInfo(lhostname)
    If Not G_lhEntry.hStatus = 0 Then
        SysPing = IP_BAD_DESTINATION
        ECHO.status = IP_BAD_DESTINATION
        Exit Function
    End If
    dwAddr = CvtIPAddrClng(G_lhEntry.hAddress)
    If dwAddr = 0 Then
        SysPing = IP_BAD_DESTINATION
        ECHO.status = IP_BAD_DESTINATION
        Exit Function
    End If
    Rval = WSAStartup(WS_VERSION_REQD, WSAD)
    If Rval <> 0 Then
        SysPing = WS32_NOT_RESPONDING
        ECHO.status = WS32_NOT_RESPONDING
        Exit Function
    End If
    If CvtLoByte(WSAD.wversion) < WS_VERSION_MAJOR Or _
       (CvtLoByte(WSAD.wversion) = WS_VERSION_MAJOR And _
        CvtHiByte(WSAD.wversion) < WS_VERSION_MINOR) Then
        SysPing = WS32_NOT_SUPPORTED
        ECHO.status = WS32_NOT_SUPPORTED
        WSACleanup
        Exit Function
    End If
    If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
        SysPing = WS32_NOT_ENOUGH_SOCKETS
        ECHO.status = WS32_NOT_ENOUGH_SOCKETS
        WSACleanup
        Exit Function
    End If
    hPort = IcmpCreateFile()
    Rval = IcmpSendEcho(hPort, dwAddr, eString, Len(eString), 0, ECHO, Len(ECHO), PING_TIMEOUT)
    If Rval = 1 Then
        SysPing = IP_SUCCESS
    Else
        If ECHO.status = 0 Then ECHO.status = IP_DEST_NET_UNREACHABLE
        SysPing = ECHO.status * -1
    End If
    IcmpCloseHandle hPort
    WSACleanup
End Function

Public Function CvtIPAddrClng(ByVal Tmp As String) As Long
    Dim ival As Integer
    Dim IpWord(4) As String
   
    On Error Resume Next
    CvtIPAddrClng = 0: ival = 0
    While InStr(Tmp, ".") > 0
        ival = ival + 1
        IpWord(ival) = Mid(Tmp, 1, InStr(Tmp, ".") - 1)
        Tmp = Mid(Tmp, InStr(Tmp, ".") + 1)
    Wend
    ival = ival + 1
    IpWord(ival) = Tmp
    If ival <> 4 Then Exit Function
    CvtIPAddrClng = Val("&H" & Right("00" & Hex(IpWord(4)), 2) & _
        Right("00" & Hex(IpWord(3)), 2) & Right("00" & Hex(IpWord(2)), 2) & _
        Right("00" & Hex(IpWord(1)), 2))
End Function

Public Function CheckIPAddress(Addr As String) As Boolean
    Dim I As Integer, pos As Integer, Pos1 As Integer, Tmp As String
   
    On Error Resume Next
    Pos1 = 1
    For I = 1 To 4
        pos = IIf(I < 4, InStr(Pos1, Addr, "."), Len(Addr) + 1)
        If pos = 0 Then Exit Function
        Tmp = Mid$(Addr, Pos1, pos - Pos1)
        If Len(Tmp) = 0 Or Not IsNumeric(Tmp) Or _
                CInt(Tmp) > 255 Or CInt(Tmp) < 0 Or _
                InStr(1, Tmp, ".") Then Exit Function
        Pos1 = pos + 1
    Next
    CheckIPAddress = True
End Function




from form


Option Explicit

Private Sub Command1_Click()
Debug.Print IsHostAlive("127.0.0.1")
End Sub
0
 

Author Comment

by:beda79
ID: 17866108
thank you, this module works, the only thing i don't understand is when i pass a variable instead of a direct string (like: IsHostAlive(currIP) instead of IsHostAlive("127.0.0.1") i get an errormessage, do you have any idea why?
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 76

Expert Comment

by:GrahamSkan
ID: 17866150
What is the error and what is the type of your currIP variable?
0
 

Author Comment

by:beda79
ID: 17866153
i found the problem, i declared the variable not in the right way, thanks
0
 

Expert Comment

by:HansenIT
ID: 21003017
Hi,
I have a question about this code. I think there is a standard timeout value something around 600 - 650 msec. Is it possible to increase this value, for example to 2000msec ?
I have to check slow lines and they are giving to much time-outs. This because te RTT are going sometimes above 1000msec
In a dos box you can get ping replys until 5000 msec
thanks
0
 

Expert Comment

by:Nirarc
ID: 21880346
For those wanting a just simple and small bit of "Yes/No" code, the following function by MMete works very well.  Very elegant.

Maarten
Function PingSilent(strComputer)
 

  Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}")._

  ExecQuery("select * from Win32_PingStatus where address = '"_

  & strComputer & "'")

            

  For Each objStatus in objPing

    If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then 

      PingSilent = 0    ' strComputer is Not reachable

    Else

      PingSilent = 1    ' strComputer is Live

    End If

  Next
 

End Function

Open in new window

0

Featured Post

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now