Sección de código fuente Visual basic

Ping y Trace route

Dll Activex para realizar Ping y Trace mediante el Api winsock

Este código fuente es un DLL Activex que hice en base a unos ejemplos que tenía archivados, y que permitían realizar mediante el uso de algunas funciones del Api, principalmente la librería wsock32.dll, un ping a un dominio y también un TraceRoute.

La dll tiene 2 métodos, uno llamado Ping y otro Trace. A estos se le deben enviar como parámetro un control TextBox o Label de nuestro proyecto para mostrar el resultado

La dll compilada la podés descargar desde este enlace. Dll Ping trace

Además de dichos métodos, tiene 3 propiedades que son:

NombreHost: en esta propiedad debemos indicar el nombre del dominio, puede ser también la IP
nPaquetes: se debe establecer la cantidad de paquetes a enviar, el parámetro es opcional, si no se especifica se envía por default un solo paquete
IPHost: Propiedad de solo lectura que contiene el valor, o mejor dicho la IP del Host

Pasos para crear la Dll Activex

Comenzar un proyecto de tipo Dll Activex.
Al módulo de clase por defecto llamado class1 cambiarlo por: getPing
Agregar un módulo .bas donde se definirán algunas funciones API, UDT y constantes.
Renombrar el proyecto (Proyecto1) por GPing o el que quieras (este nombre será el que aparecerá luego cuando la referencies) ... o si no, podés establecrle el nomre que tendrá, desde el menú proyecto > Propiedades de proyecto > descripción del proyecto, como está en la imagen:

vista de la ventana de Propiedades de proyecto para establecer el nombre de la Dll Activex

Pegar el siguiente código en el módulo de clase

' WSock32 Variables Dim Ret As Long, sLowByte As String, sHighByte As String Dim sMsg As String, HostLen As Long, Host As String Dim Hostent As Hostent, PointerToPointer As Long, ListAddress As Long Dim WSAdata As WSAdata, DotA As Long, DotAddr As String, ListAddr As Long Dim MaxUDP As Long, MaxSockets As Long, i As Integer Dim Descripcion As String, Status As String ' ICMP Variables Dim bReturn As Boolean, hIP As Long Dim szBuffer As String Dim Addr As Long Dim Error As String Dim HostRespuesta As String Dim TraceRT As Boolean Dim TTL As Integer 'Variables para las propiedaes Private m_NombreHost As String 'Nombre del Host Private m_IPHost As String 'Ip del Host Private m_nPaquetes As Byte 'Paquetes a enviar 'si se produce un error se manda al control de salida Private Sub LeerError(ControlSalida As Object) If pIPe.Status = 0 Then Error = "Success" If pIPe.Status = 11001 Then Error = "Buffer too Small" If pIPe.Status = 11002 Then Error = "Dest Network Not Reachable" If pIPe.Status = 11003 Then Error = "Dest Host Not Reachable" If pIPe.Status = 11004 Then Error = "Dest Protocol Not Reachable" If pIPe.Status = 11005 Then Error = "Dest Port Not Reachable" If pIPe.Status = 11006 Then Error = "No Resources Available" If pIPe.Status = 11007 Then Error = "Bad Option" If pIPe.Status = 11008 Then Error = "Hardware Error" If pIPe.Status = 11009 Then Error = "Packet too Big" If pIPe.Status = 11010 Then Error = "Rqst Timed Out" If pIPe.Status = 11011 Then Error = "Bad Request" If pIPe.Status = 11012 Then Error = "Bad Route" If pIPe.Status = 11013 Then Error = "TTL Exprd in Transit" If pIPe.Status = 11014 Then Error = "TTL Exprd Reassemb" If pIPe.Status = 11015 Then Error = "Parameter Problem" If pIPe.Status = 11016 Then Error = "Source Quench" If pIPe.Status = 11017 Then Error = "Option too Big" If pIPe.Status = 11018 Then Error = " Bad Destination" If pIPe.Status = 11019 Then Error = "Address Deleted" If pIPe.Status = 11020 Then Error = "Spec MTU Change" If pIPe.Status = 11021 Then Error = "MTU Change" If pIPe.Status = 11022 Then Error = "Unload" If pIPe.Status = 11050 Then Error = "General Failure" Error = Error + " (" + CStr(pIPe.Status) + ")" DoEvents If TraceRT = False Then If pIPe.Status = 0 Then ControlSalida = ControlSalida + " Replica de " + _ HostRespuesta + ":Bytes = " + Trim$(CStr(pIPe.DataSize)) _ + " RTT = " + Trim$(CStr(pIPe.RoundTripTime)) + "ms TTL = " + _ Trim$(CStr(pIPe.Options.TTL)) + Chr$(13) + Chr$(10) Else ControlSalida = ControlSalida + " Replica de " + _ HostRespuesta + ": " + Error + Chr$(13) + Chr$(10) End If Else If TTL - 1 < 10 Then ControlSalida = ControlSalida & " Hop # 0" + _ CStr(TTL - 1) Else ControlSalida = ControlSalida + " Hop # " + _ CStr(TTL - 1) ControlSalida = ControlSalida + " " + HostRespuesta + Chr$(13) + _ Chr$(10) End If End Sub 'Recupera la Ip a partir del nombre de Host Private Sub vbGetHostByName(m_NombreHost As String) Dim szString As String Host = Trim$(m_NombreHost) szString = String(64, &H0) Host = Host + Right$(szString, 64 - Len(Host)) If gethostbyname(Host) = SOCKET_ERROR Then sMsg = "Winsock Error" & Str$(WSAGetLastError()) MsgBox sMsg, vbOKOnly, "Error" Else PointerToPointer = gethostbyname(Host) CopyMemory Hostent.h_name, ByVal _ PointerToPointer, Len(Hostent) ListAddress = Hostent.h_addr_list CopyMemory ListAddr, ByVal ListAddress, 4 CopyMemory IPLong, ByVal ListAddr, 4 CopyMemory Addr, ByVal ListAddr, 4 m_IPHost = Trim$(CStr(Asc(IPLong.Byte4)) + "." + CStr(Asc(IPLong.Byte3)) _ + "." + CStr(Asc(IPLong.Byte2)) + "." + CStr(Asc(IPLong.Byte1))) End If End Sub 'Recupera el nombre de Host Private Sub vbGetHostName() Host = String(64, &H0) If gethostname(Host, HostLen) = SOCKET_ERROR Then sMsg = "WSock32 Error" & Str$(WSAGetLastError()) MsgBox sMsg, vbOKOnly, "Error" Else Host = Left$(Trim$(Host), Len(Trim$(Host)) - 1) m_NombreHost = Host End If End Sub Private Sub vbIcmpSendEcho(ControlSalida As Object) Dim NbrOfPkts As Integer szBuffer = "abcdefghijklmnopqrstuvwabcdefghijklmnopqrstu" & _ "vwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghij" & _ "klmnopqrstuvwabcdefghijklm" szBuffer = Left$(szBuffer, Val("32")) If IsNumeric(m_nPaquetes) Then If Val(m_nPaquetes) < 1 Then m_nPaquetes = "1" Else m_nPaquetes = "1" End If If TraceRT = True Then m_nPaquetes = "1" For NbrOfPkts = 1 To Trim$(m_nPaquetes) DoEvents bReturn = IcmpSendEcho(hIP, Addr, szBuffer, Len(szBuffer), _ pIPo, pIPe, Len(pIPe) + 8, 2700) If bReturn Then HostRespuesta = CStr(pIPe.Address(0)) + "." + CStr(pIPe.Address(1)) _ + "." + CStr(pIPe.Address(2)) + "." + CStr(pIPe.Address(3)) LeerError ControlSalida Else If TraceRT Then TTL = TTL - 1 Else ' Tiempo agotado ControlSalida = ControlSalida & _ "Tiempo de espera agotado para la solicitud" & Chr$(13) _ + Chr$(10) End If End If Next NbrOfPkts If Not TraceRT Then ControlSalida = ControlSalida & Chr(13) & Chr(10) & "-----------------" & _ Chr(13) & Chr(10) End If End Sub 'Inicializa el Wsock32 Private Sub vbWSAStartup() Ret = WSAStartup(&H101, WSAdata) If Ret <> 0 Then MsgBox "WSock32.dll no responde!", vbOKOnly, "VB4032-ICMPEcho" End If If LoByte(WSAdata.wVersion) < WS_VERSION_MAJOR Or _ (LoByte(WSAdata.wVersion) = WS_VERSION_MAJOR _ And HiByte(WSAdata.wVersion) < WS_VERSION_MINOR) Then sHighByte = Trim$(Str$(HiByte(WSAdata.wVersion))) sLowByte = Trim$(Str$(LoByte(WSAdata.wVersion))) sMsg = "Version de WinSock " & sLowByte & "." & sHighByte sMsg = sMsg & " No soportado " MsgBox sMsg, vbOKOnly, "Error" Exit Sub End If If WSAdata.iMaxSockets < MIN_SOCKETS_REQD Then sMsg = "Esta aplicación requiere un minimo de " sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " sockets soportados." MsgBox sMsg, vbOKOnly, "Error" Exit Sub End If MaxSockets = WSAdata.iMaxSockets If MaxSockets < 0 Then MaxSockets = 65536 + MaxSockets End If MaxUDP = WSAdata.iMaxUdpDg If MaxUDP < 0 Then MaxUDP = 65536 + MaxUDP End If Descripcion = "" For i = 0 To WSADESCRIPTION_LEN If WSAdata.szDescription(i) = 0 Then Exit For Descripcion = Descripcion + Chr$(WSAdata.szDescription(i)) Next i Status = "" For i = 0 To WSASYS_STATUS_LEN If WSAdata.szSystemStatus(i) = 0 Then Exit For Status = Status + Chr$(WSAdata.szSystemStatus(i)) Next i End Sub 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 Private Sub vbWSACleanup() Ret = WSACleanup() If Ret <> 0 Then sMsg = "WSock32 Error - " & Trim$(Str$(Ret)) & " occurred in Cleanup" MsgBox sMsg, vbOKOnly, "Error" Exit Sub End If End Sub Private Sub vbIcmpCloseHandle() bReturn = IcmpCloseHandle(hIP) If bReturn = False Then MsgBox "Error", vbOKOnly, "Error" End If End Sub Private Sub vbIcmpCreateFile() hIP = IcmpCreateFile() If hIP = 0 Then MsgBox "Unable to Create File Handle", vbOKOnly, "VBPing32" End If End Sub Public Sub Ping(ControlSalida As Object, Optional TTL As Byte = 255) 'Initializa el Winsock vbWSAStartup If Len(m_NombreHost) = 0 Then vbGetHostName End If If m_NombreHost = "" Then MsgBox "No se especifico un nombre de Host!", vbOKOnly, "Error" vbWSACleanup Exit Sub End If 'Recupera la IP del Host vbGetHostByName m_NombreHost vbIcmpCreateFile If IsNumeric(TTL) Then If (Val(TTL) > 255) Then TTL = "255" If (Val(TTL) < 2) Then TTL = "2" Else TTL = "255" End If pIPo.TTL = Trim$(CStr(TTL)) 'Envía el ICMP Echo al control de salida vbIcmpSendEcho ControlSalida 'Cierra ICMP Handle vbIcmpCloseHandle ' Finaliza el Winsock vbWSACleanup End Sub Public Sub Trace(ControlSalida As Object, Optional TTL As Byte = 255) 'Initializa el Winsock vbWSAStartup If Len(m_NombreHost) = 0 Then vbGetHostName End If If m_NombreHost = "" Then MsgBox "No se especifico un Host!", vbOKOnly, "Error" vbWSACleanup Exit Sub End If vbGetHostByName m_NombreHost 'recupera el Handle ICMP vbIcmpCreateFile TraceRT = True 'Mostramos los resultados en el control de salida ControlSalida = ControlSalida + "Tracing Route to " + m_IPHost + _ ":" + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10) For TTL = 2 To 255 pIPo.TTL = TTL ''Mostramos los resultados en el control de salida (ICMP Echo Request) vbIcmpSendEcho ControlSalida DoEvents If HostRespuesta = m_IPHost Then ControlSalida = ControlSalida + Chr$(13) + Chr$(10) + _ "Route Trace finalizado" + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10) Exit For End If Next TTL TraceRT = False ' Cierra the ICMP Handle vbIcmpCloseHandle ' Finaliza el Winsock vbWSACleanup End Sub 'Para el nomber del Host Public Property Get NombreHost() As String NombreHost = m_NombreHost End Property Public Property Let NombreHost(ByVal vNewValue As String) m_NombreHost = vNewValue End Property 'Almacena la Ip del Host Public Property Get IPHost() As Variant IPHost = m_IPHost End Property Public Property Let IPHost(ByVal vNewValue As Variant) MsgBox "La propiedad es de solo lectura", vbInformation End Property 'Almacena la Cantidad de paquetes a enviar Public Property Get nPaquetes() As Byte nPaquetes = m_nPaquetes End Property Public Property Let nPaquetes(ByVal vNewValue As Byte) m_nPaquetes = vNewValue End Property

Colocar el siguiente código en el módulo .bas

' Constantess para wsock32 Const WS_VERSION_MAJOR = &H101 \ &H100 And &HFF& Const WS_VERSION_MINOR = &H101 And &HFF& Const MIN_SOCKETS_REQD = 0 ' Estructuras para el WSock32 Type Inet_address Byte4 As String * 1 Byte3 As String * 1 Byte2 As String * 1 Byte1 As String * 1 End Type Public IPLong As Inet_address 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 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 Type IP_OPTION_INFORMATION TTL As Byte ' Time to Live (used for traceroute) Tos As Byte ' Type of Service (usually 0) Flags As Byte ' IP header Flags (usually 0) OptionsSize As Long ' Size of Options data (usually 0, max 40) OptionsData As String * 128 ' Options data buffer End Type Public pIPo As IP_OPTION_INFORMATION Type IP_ECHO_REPLY Address(0 To 3) As Byte ' Replying Address Status As Long ' Reply Status RoundTripTime As Long ' Round Trip Time in milliseconds DataSize As Integer ' reply data size Reserved As Integer ' for system use data As Long ' pointer to echo data Options As IP_OPTION_INFORMATION ' Reply Options End Type Public pIPe As IP_ECHO_REPLY 'Api que Obtiene el nombre de Host Declare Function gethostname Lib "wsock32.dll" (ByVal hostname$, HostLen&) As Long 'Api que Obtiene La IP a partir del nombre de Host Declare Function gethostbyname& Lib "wsock32.dll" (ByVal hostname$) Declare Function WSAGetLastError Lib "wsock32.dll" () As Long 'Api para inicializar wsock32 Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired&, lpWSAData As WSAdata) As Long 'Api para finalizar wsock32 Declare Function WSACleanup Lib "wsock32.dll" () As Long Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, _ ByVal cbCopy As Long) Declare Function IcmpCreateFile Lib "icmp.dll" () As Long Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal HANDLE As Long) As Boolean Declare Function IcmpSendEcho Lib "ICMP" (ByVal IcmpHandle As Long, ByVal DestAddress As Long, _ ByVal RequestData As String, ByVal RequestSize As Integer, RequestOptns As IP_OPTION_INFORMATION, _ ReplyBuffer As IP_ECHO_REPLY, ByVal ReplySize As Long, ByVal TimeOut As Long) As Boolean

Generar la Dll e incluirla en un proyecto Exe

Ahora compilar la Dll desde el menú Archivo. Una ves generada, crear un proyecto de tipo Exe estándar para probarla.

Colocar los siguientes controles en un formulario:

Text1: acá se indica el nombre del Host (propiedad NombreHost)
Text2: Se indica elnúmero de paquetes a enviar (Propiedad NPaquetes)
txtSalida: Acá se visualiza el resultado del Ping o el TRace. Este TextBox colocar el Multiline en true y la propiedad ScrollBar en Vertical
Command1: este ejcutará el Método Ping
Command2: Ejecuta el método Trace

Los controles quedarán similares a los de la siguiente gráfico:

Desde el menú Proyecto > Referencias , añadir la dll generada.

El código del Formulario

Option Explicit Dim clsPing As getPing 'Ping '''''''''''''''''''''''''''' Private Sub Command1_Click() With clsPing .NombreHost = Text1 'Host .nPaquetes = Text2 'Cantidad de paquetes .Ping txtsalida 'Control de salida End With End Sub 'Trace ''''''''''''''''''''''''''''' Private Sub Command2_Click() With clsPing .NombreHost = Text1 'Host .Trace txtsalida 'Control de salida End With End Sub Private Sub Form_Load() 'Creamos la referencia Set clsPing = New getPing End Sub Private Sub Form_Unload(Cancel As Integer) 'Eliminamos If Not clsPing Is Nothing Then Set clsPing = Nothing End If End Sub

Buscar en Recursos vb