Option Explicit


Private mvarIPDestino As String
Private mvarLongitudDatos As Long
Private mvarTimeOut As Long
Private mvarEstado As Long
Private mvarDescripcion As String
Private mvarTiempo As Long

Private Const IP_STATUS_BASE = 11000
Private Const IP_SUCCESS = 0
Private Const IP_BUF_TOO_SMALL = (11000 + 1)
Private Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Private Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Private Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Private Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Private Const IP_NO_RESOURCES = (11000 + 6)
Private Const IP_BAD_OPTION = (11000 + 7)
Private Const IP_HW_ERROR = (11000 + 8)
Private Const IP_PACKET_TOO_BIG = (11000 + 9)
Private Const IP_REQ_TIMED_OUT = (11000 + 10)
Private Const IP_BAD_REQ = (11000 + 11)
Private Const IP_BAD_ROUTE = (11000 + 12)
Private Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Private Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Private Const IP_PARAM_PROBLEM = (11000 + 15)
Private Const IP_SOURCE_QUENCH = (11000 + 16)
Private Const IP_OPTION_TOO_BIG = (11000 + 17)
Private Const IP_BAD_DESTINATION = (11000 + 18)
Private Const IP_ADDR_DELETED = (11000 + 19)
Private Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Private Const IP_MTU_CHANGE = (11000 + 21)
Private Const IP_UNLOAD = (11000 + 22)
Private Const IP_ADDR_ADDED = (11000 + 23)
Private Const IP_GENERAL_FAILURE = (11000 + 50)
Private Const MAX_IP_STATUS = 11000 + 50
Private Const IP_PENDING = (11000 + 255)
Private Const PING_TIMEOUT = 200
Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
'estructuras
Private Type ICMP_OPTIONS
    Ttl             As Byte
    Tos             As Byte
    Flags           As Byte
    OptionsSize     As Byte
    OptionsData     As Long
End Type
Private ICMPOPT As ICMP_OPTIONS
Private 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 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 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" () As Long

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 SocketsCleanup() As Boolean
Dim X As Long
X = WSACleanup()
If X <> 0 Then
    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
    MsgBox "Windows Sockets for 32 bit Windows " & _
           "environments is not successfully responding."
    SocketsInitialize = False
    Exit Function
End If
If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
    HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
    szHiByte = Trim$(Str$(HiByte(WSAD.wVersion)))
    szLoByte = Trim$(Str$(LoByte(WSAD.wVersion)))
    szBuf = "Windows Sockets Version " & szLoByte & "." & szHiByte
    szBuf = szBuf & " is not supported by Windows " & _
                        "Sockets for 32 bit Windows environments."
    MsgBox szBuf, vbExclamation
    SocketsInitialize = False
    Exit Function
End If
If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
    szBuf = "This application requires a minimum of " & _
    Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
    MsgBox szBuf, vbExclamation
    SocketsInitialize = False
    Exit Function
End If
SocketsInitialize = True
End Function

Public Sub ping(dwAddress As Long)
    Dim hPort As Long

    Dim sDataToSend As String
    Dim iOpt As Long
    Dim ECHO As ICMP_ECHO_REPLY
    Dim res As Boolean
    res = SocketsInitialize
    If res Then
        
        sDataToSend = String$(mvarLongitudDatos, "A")
        hPort = IcmpCreateFile()
        If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), _
                        0, ECHO, Len(ECHO), mvarTimeOut) Then
            
         
             mvarEstado = 0
             mvarTiempo = ECHO.RoundTripTime
        Else
            mvarTiempo = 0
            mvarEstado = Abs(ECHO.status)
            If mvarEstado = 0 Then mvarEstado = IP_GENERAL_FAILURE
        End If
        Call IcmpCloseHandle(hPort)
        res = SocketsCleanup
Else
    mvarEstado = IP_GENERAL_FAILURE
    mvarTiempo = 0
End If
mvarDescripcion = GetStatusCode(mvarEstado)
End Sub

Private Function GetStatusCode(status As Long) As String
Dim msg As String

Select Case status
    Case IP_SUCCESS:               msg = ""
    Case IP_BUF_TOO_SMALL:         msg = "buffer demasiado pequeño"
    Case IP_DEST_NET_UNREACHABLE:  msg = "red de destino no encontrada"
    Case IP_DEST_HOST_UNREACHABLE: msg = "host destino no encontrado"
    Case IP_DEST_PROT_UNREACHABLE: msg = "dest prot unreachable"
    Case IP_DEST_PORT_UNREACHABLE: msg = "puerto destino no encontrado"
    Case IP_NO_RESOURCES:          msg = "sin recursos"
    Case IP_BAD_OPTION:            msg = "opción inválida"
    Case IP_HW_ERROR:              msg = "error hardware"
    Case IP_PACKET_TOO_BIG:        msg = "paquete demasiado grande"
    Case IP_REQ_TIMED_OUT:         msg = "timeout"
    Case IP_BAD_REQ:               msg = "respuesta incorrecta"
    Case IP_BAD_ROUTE:             msg = "ruta inválida"
    Case IP_TTL_EXPIRED_TRANSIT:   msg = "ttl finalizado"
    Case IP_TTL_EXPIRED_REASSEM:   msg = "ttl expired reassem"
    Case IP_PARAM_PROBLEM:         msg = "error en parámetros"
    Case IP_SOURCE_QUENCH:         msg = "source quench"
    Case IP_OPTION_TOO_BIG:        msg = "opción demasiado grande"
    Case IP_BAD_DESTINATION:       msg = "destino incorrecto"
    Case IP_ADDR_DELETED:          msg = "addr deleted"
    Case IP_SPEC_MTU_CHANGE:       msg = "spec mtu change"
    Case IP_MTU_CHANGE:            msg = "ip mtu_change"
    Case IP_UNLOAD:                msg = "unload"
    Case IP_ADDR_ADDED:            msg = "addr added"
    Case IP_GENERAL_FAILURE:       msg = "fallo general"
    Case IP_PENDING:               msg = "pendiente"
    Case PING_TIMEOUT:             msg = "ping timeout"
    Case Else:                     msg = "recibido mensaje desconocido"
End Select
GetStatusCode = msg
End Function

Public Property Get Tiempo() As Long
    Tiempo = mvarTiempo
End Property

Public Property Get Descripcion() As String
    Descripcion = mvarDescripcion
End Property

Public Property Get Estado() As Long
    Estado = mvarEstado
End Property

Public Property Let Timeout(ByVal vData As Long)
    mvarTimeOut = vData
    If mvarTimeOut < 1 Then mvarTimeOut = 1
End Property

Public Property Get Timeout() As Long
    Timeout = mvarTimeOut
End Property

Public Property Let LongitudDatos(ByVal vData As Long)
    mvarLongitudDatos = vData
    If mvarLongitudDatos > 250 Then mvarLongitudDatos = 250
    If mvarLongitudDatos < 1 Then mvarLongitudDatos = 1
End Property

Public Property Get LongitudDatos() As Long
    LongitudDatos = mvarLongitudDatos
End Property

Public Property Let IPDestino(ByVal vData As String)
    mvarIPDestino = vData
End Property

Public Property Get IPDestino() As String
    IPDestino = mvarIPDestino
End Property

Private Sub Class_Initialize()
mvarLongitudDatos = 32
mvarTimeOut = 4000
End Sub
Public CANCELAR As Boolean
Public SumaTiempo As Long
Public cfg_PACKCOUNT As Integer

Public INFO_RECIEN As Boolean

Public Enum eSEMAFORO
    ROJO = 0
    AMARILLO = 1
    VERDE = 2
End Enum

Public Type Hostent
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type

Option Explicit
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired&, lpWSAdata As WSAdata) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal HostName As String) As Long

Private Type WSAdata
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To 255) As Byte
    szSystemStatus(0 To 128) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type

Dim ping As cPing

Private Sub cmdCancel_Click()
CANCELAR = True
cmdCancel.Enabled = False
End Sub

Private Sub cmdConfig_Click()
Dim X As Integer
If cmdConfig.Caption = "Config >>" Then
    cmdConfig.Caption = "Ocultar"
    For X = Me.Height To 3345 Step 50
        Me.Height = X
        Me.Refresh
    Next X
Else
    cmdConfig.Caption = "Config >>"
    For X = Me.Height To 1710 Step -50
        Me.Height = X
        Me.Refresh
    Next X
End If
End Sub

Private Sub Command1_Click()
    Dim dwAddress As Long, IPDestino As String
    Dim cont As Integer, exCaption As String
    Dim hHostent As Hostent, AddrList As Long
    Dim lpWSAdata As WSAdata

    Unload Form_info
    If txtIp = "" Then Exit Sub
    ActualizarValores
    Command1.Enabled = False
    exCaption = Me.Caption
    Me.Caption = "Resolviendo Host..."
    IPDestino = txtIp
    CANCELAR = False
    cmdCancel.Enabled = True
    Semaforo AMARILLO
    Call WSAStartup(&H101, lpWSAdata)
    If GetHostByName(IPDestino + String(64 - Len(IPDestino), 0)) <> -1 Then
            CopyMemory hHostent.h_name, ByVal GetHostByName(IPDestino + String(64 - Len(IPDestino), 0)), Len(hHostent)
            CopyMemory AddrList, ByVal hHostent.h_addr_list, 4
            CopyMemory dwAddress, ByVal AddrList, 4
    End If
    Form_info.lblPorcen.ForeColor = vbBlack
    Form_info.lblTpor(0).ForeColor = Form_info.lblPorcen.ForeColor
    SumaTiempo = 0
    If dwAddress = 0 Then
        MsgBox "No hay ruta al host " & txtIp, vbCritical, "Error"
        Me.Caption = exCaption
        Semaforo ROJO
        Command1.Enabled = True
        txtIp.SetFocus
        Exit Sub
    End If
    Call WSACleanup
    
    Form_info.lblTotal = "0 de " & cfg_PACKCOUNT
    Form_info.lblSize = ping.LongitudDatos & " bytes"
    Form_info.lblLost = "0"
    Form_info.lblRecv = "0"
    Form_info.lblTime = ping.Timeout & " ms"
    Form_info.Show
    
    Me.Caption = "Haciendo Ping..."
    For cont = 1 To cfg_PACKCOUNT
        Form_info.lblTotal = "Haciendo ping " & cont & " de " & cfg_PACKCOUNT
        DoEvents
        Me.Refresh
        If CANCELAR Then Exit For
        ping.ping (dwAddress)
        If ping.Estado = 0 Then
            Form_info.lblRecv = Val(Form_info.lblRecv) + 1
            Form_info.lstPing.AddItem "Ping   " & cont & vbTab & "Tiempo: " & ping.Tiempo & " ms"
            SumaTiempo = SumaTiempo + ping.Tiempo
        Else
            Form_info.lblLost = Val(Form_info.lblLost) + 1
            Form_info.lstPing.AddItem "Ping   " & cont & vbTab & "Falló"
        End If
        Form_info.lstPing.ListIndex = Form_info.lstPing.ListCount - 1
        Form_info.lblPorcen = Round((Val(Form_info.lblRecv) / cont) * 100, 0) & "%"
        If Val(Form_info.lblRecv) > 0 Then Form_info.lblProm = Round(SumaTiempo / Val(Form_info.lblRecv), 2) & " Ms"
        
        Semaforo (IIf(ping.Estado = 0, VERDE, ROJO))
        Me.Refresh
    
    Next cont
    Form_info.lblTotal = IIf(CANCELAR, "CANCELADO", "FINALIZADO")
    Form_info.lblPorcen.ForeColor = IIf(cfg_PACKCOUNT = Val(Form_info.lblRecv), &H8000&, vbRed)
    Form_info.lstPing.AddItem String(34, "-")
    Form_info.lstPing.ListIndex = Form_info.lstPing.ListCount - 1
    Me.Caption = exCaption
    Command1.Enabled = True
    cmdCancel.Enabled = False

End Sub

Private Sub Semaforo(LIGHT_ON As eSEMAFORO)
Dim i As Byte, aColor(0 To 2) As Long
aColor(0) = &HFF&
aColor(1) = &HFFFF&
aColor(2) = &HFF00&
For i = 0 To 2
    Shape1(i).FillColor = IIf(i = LIGHT_ON, aColor(i), &HC0C0C0)
Next i
End Sub


Private Sub Form_Activate()
txtIp.SetFocus
End Sub

Private Sub Form_Load()
    Me.Height = 1710
    Set ping = New cPing
    Semaforo ROJO
    INFO_RECIEN = True
    cmdCancel.Enabled = False
    cfg_PACKCOUNT = Val(txtCant)
    ping.LongitudDatos = Val(txtSize)
    ping.Timeout = Val(txtTime)
End Sub

Private Sub salir_Click()
    End
End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub

Private Sub Frame1_DragDrop(Source As Control, X As Single, Y As Single)

End Sub

Private Sub txtCant_KeyPress(KeyAscii As Integer)
Tratar KeyAscii
End Sub

Private Sub txtCant_LostFocus()
If Val(txtCant) < 1 Then txtCant = 1
ActualizarValores
End Sub


Private Sub txtIp_GotFocus()
txtIp.SelStart = 0
txtIp.SelLength = Len(txtIp)
End Sub

Private Sub txtSize_LostFocus()
If Val(txtSize) < 1 Then txtSize = 32
If Val(txtSize) > 250 Then txtSize = 250
ActualizarValores
End Sub

Private Sub txtTime_LostFocus()
If Val(txtTime) < 1 Then txtTime = 1
ActualizarValores
End Sub

Private Sub txtSize_KeyPress(KeyAscii As Integer)
Tratar KeyAscii
End Sub


Private Sub txtTime_KeyPress(KeyAscii As Integer)
Tratar KeyAscii
End Sub

Private Sub Tratar(ByRef KeyAscii As Integer)
If (KeyAscii < vbKey0 Or KeyAscii > vbKey9) And KeyAscii <> 8 Then KeyAscii = 0
End Sub

Private Sub ActualizarValores()
cfg_PACKCOUNT = Val(txtCant)
ping.Timeout = Val(txtTime)
ping.LongitudDatos = Val(txtSize)
End Sub


Option Explicit
Dim finX As Integer, finY As Integer

Private Sub cerrar_Click()
    Unload Me
End Sub

Private Sub Form_Activate()
Dim X As Integer, Y As Integer
Dim startX As Integer, startY As Integer
If INFO_RECIEN Then
    INFO_RECIEN = False
    startY = Me.Width
    
    For Y = startY To finY Step 100
        Me.Width = Y
        Me.Height = Y
        Me.Refresh
    Next Y
    
    startX = Me.Height
    For X = startX To finX Step 100
        Me.Height = X
        Me.Refresh
    Next X

End If
End Sub

Private Sub Form_Load()
Me.Top = Form_ping.Top
Me.Left = Form_ping.Left + Form_ping.Width
If Not INFO_RECIEN Then Exit Sub
finX = Me.Height
finY = Me.Width
Me.Height = 0
Me.Width = 0
End Sub

Private Sub lblPorcen_Click()

End Sub

Private Sub lstPing_Click()

End Sub