Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: YAcosta en Noviembre 13, 2012, 04:15:56 pm
-
Saludos
Necesito tener un label que me indique si tengo conexión a internet o no en tiempo real.
Encontré dos códigos. Usando un timer con interval a 500 probe con este código:
Option Explicit
'Funcion Api que obtiene información sobre el estado de Red
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Const INTERNET_CONNECTION_MODEM_BUSY As Long = &H8
Private Const INTERNET_CONNECTION_OFFLINE As Long = &H20
Private Const INTERNET_CONNECTION_CONFIGURED As Long = &H40
Private dwflags As Long
' Función Booleana para saber si se está conectado a internet
Private Function Online() As Boolean
Online = InternetGetConnectedState(0&, 0&)
End Function
Private Sub Timer1_Timer()
If CBool(Online()) Then
Label1 = "Conectados"
Else
Label1 = "DesConectados"
End If
End Sub
Y funciona bien, me voy al router y desconecto el cable de poder y el label cambia a desconectado. Luego conecto el cable de poder y en un rato el estado cambia a conectado. Esto va bien. Probe luego con el segundo codigo el cual requiere un modulo:
Modulo:
Option Explicit
' Funciones Api
'''''''''''''''''''''''''''
Public Declare Function RasEnumConnections Lib "RasApi32.dll" _
Alias "RasEnumConnectionsA" ( _
lpRasCon As Any, _
lpcb As Long, _
lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" _
Alias "RasGetConnectStatusA" ( _
ByVal hRasCon As Long, _
lpStatus As Any) As Long
' constantes
''''''''''''''''''''''''''''''
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32
' Estructuras
''''''''''''''''''''''''''''
Public Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Public Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Public Function Conectado() As Boolean
Dim TC(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim ret As Long
Dim Tstatus As RASCONNSTATUS95
TC(0).dwSize = 412
lg = 256 * TC(0).dwSize
ret = RasEnumConnections(TC(0), lg, lpcon)
If ret <> 0 Then
MsgBox "error", vbCritical
Exit Function
End If
Tstatus.dwSize = 160
ret = RasGetConnectStatus(TC(0).hRasCon, Tstatus)
'retorno
If Tstatus.RasConnState = &H2000 Then
Conectado = True
Else
Conectado = False
End If
End Function
Formulario:
Private Sub Timer1_Timer()
If Conectado Then
Label1 = "Conectado"
Else
Label1 = "Desconectado"
End If
End Sub
Y siempre me da Desconectado ¿porque?, lei el código pero no logro entender porque no funciona este segundo codigo, ambos los saque de recursosvisualbasic.
Usare el primer codigo pero no queria quedarme con la duda de porque no funciona el segundo codigo.
Gracias
-
Hola, encontre algo acerca del segundo en este post:
http://www.vbforums.com/printthread.php?t=10198
Y segun dice un comentario, su uso es solo para Dial-up
Vi tambien este codigo para comprobar si tu conexion es por modem o lan:
Modulo:
Option Explicit
Public Declare Function InternetGetConnectedState _
Lib "wininet.dll" (ByRef lpSFlags As Long, _
ByVal dwReserved As Long) As Long
Public Const INTERNET_CONNECTION_LAN As Long = &H2
Public Const INTERNET_CONNECTION_MODEM As Long = &H1
Public Function ViaLAN() As Boolean
Dim SFlags As Long
'return the flags associated with the connection
Call InternetGetConnectedState(SFlags, 0&)
'True if the Sflags has a LAN connection
ViaLAN = SFlags And INTERNET_CONNECTION_LAN
End Function
Public Function ViaModem() As Boolean
Dim SFlags As Long
'return the flags associated with the connection
Call InternetGetConnectedState(SFlags, 0&)
'True if the Sflags has a modem connection
ViaModem = SFlags And INTERNET_CONNECTION_MODEM
End Function
Formulario con 2 textbox y un command button
Option Explicit
Private Sub Command1_Click()
Text1 = "Conexion Lan :" & ViaLAN()
Text2 = "Conexion Modem :" & ViaModem()
End Sub
-
Retomo el tema porque se me presento un problema que por poco me deja mal.
Usando este codigo checo unos enlaces a internet
'------ para la conexión a internet ------------------
Public Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long
Public Const INTERNET_CONNECTION_MODEM_BUSY As Long = &H8
Public Const INTERNET_RAS_INSTALLED As Long = &H10
Public Const INTERNET_CONNECTION_OFFLINE As Long = &H20
Public Const INTERNET_CONNECTION_CONFIGURED As Long = &H40
'---------------------------------------------------------------
Public Function HayInternet() As Boolean
HayInternet = InternetGetConnectedState(0&, 0&)
End Function
Private Sub LeyendoEnlaces()
If HayInternet Then
Dim hOpen As Long, hFile As Long, sBuffer As String, ret As Long
sBuffer = Space(1000)
hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0) 'Aqui se me cuelga
hFile = InternetOpenUrl(hOpen, sUrl, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&) 'Open the url
InternetReadFile hFile, sBuffer, 1000, ret
InternetCloseHandle hFile
InternetCloseHandle hOpen
...
...
...
End Sub
Entonces sucede lo siguiente.
1.- Cuando el aplicativo corre en una PC conectada a un router y el router esta apagado la función HayInternet me devuelve False y no hace nada con internet saliendo hacia otros procedimientos. Todo perfecto. Si la función devuelve True entonces lee unos enlaces los cuales manipulo. Esto lo probé en mi PC y ejecuto perfecto, lo lleve a 4 clientes y todo muy bien, Ojo que todos esos 4 clientes usan el aplicativo en red.
2.- Pero el sabado en un quinto cliente el aplicativo empezó a colgarse, abro un browser y no había internet, el router estaba prendido y bien conectado, conclusión el proveedor no le daba internet pero... ¿porque se cuelga mi aplicativo?, me voy al codigo y veo la funcion HayInternet me sigue devolviendo True... entonces concebí mal esa funcion ya que esta no me verifica si hay internet o no, creo que me verifica si estoy conectado a la red o no.... Para salir del paso apague esas funciones y el cliente pudo andar.
3.- Llegue a mi casa y volvi a probar y todo funcionaba bien, ahora abro una maquina virtual y alli levanto el aplicativo. La maquina virtual se alimenta del internet de la PC host. El aplicativo tambien corre bien, la funcion entrega True. Apago el router, naturalmente la red del host sale como desconectada pero no la red de la PC virtual. Levanto el aplicativo y nuevamente se cuelga, la función me sigue dando true. Luego si sigo se me cuelga en hOpen = InternetOpen(scUserAgent,.....
¿Como podria hacer para resolver esto? la función que uso al parecer solo me da true o false si el router esta prendido y conectado directamente a la pc ¿? no capto este tema. ¿Que otra consulta o funcion debo agregar?
Muchas Gracias.
-
Hola Yvan es medio chivo ese tema fijate que hasta los navegadores se toman su tiempo, la diferencia es que estos no se cuelgan, por lo que pude ver lo mejor que encontre hasta el momento es con el api InternetCheckConnection , esta se demora uno 11 segundo aproximadamente (si es que no hay internet), colgar se va a colgar, pero bueno, tuvieras que chekear almenos una url, si esta falla es casi un 99% de que no hay internet. y en ese caso no haces mas las consultas que mencionas.
por cierto No es InternetOpen el que produce el cuelgue, es InternetOpenUrl
ejemplo de InternetCheckConnection
Private Const FLAG_ICC_FORCE_CONNECTION = &H1
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Sub Form_Load()
'KPD-Team 2001
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
If InternetCheckConnection("http://www.allapi.net/", FLAG_ICC_FORCE_CONNECTION, 0&) = 0 Then
MsgBox "Connection to http://www.allapi.net/ failed!", vbInformation
Else
MsgBox "Connection to http://www.allapi.net/ succeeded!", vbInformation
End If
End Sub
por hay te combiene poner un cartel de espera antes de chequear la coneccion, para que no parezca que se cuelga el programa.
-
otra forma pero tiene una buena y una mala, la buena es que no cuelga el programa, la mala es que tarda mucho, pero si te das un poco de maña, lo haces con un timer en en segundo plano, no se cual es la forma en que vos vas haciendo las consultas, pero bueno, son casos especiales. ademas vos no tenes la culpa de que a tu cliente no le ande internet XD
Option Explicit
Private Sub Form_Load()
MsgBox CheckConnection("http://www.google.com/")
End Sub
Public Function CheckConnection(sURL) As Boolean
Dim xml As Object
Set xml = CreateObject("Microsoft.XMLHTTP")
xml.Open "GET", sURL, True
xml.Send
Do While xml.readyState <> 4
DoEvents
Loop
CheckConnection = CBool(xml.Status = 0)
Debug.Print xml.Status
Set xml = Nothing
End Function
-
Muchas gracias Leandro por el apoyo.... esto ultimo que acabas de comentar me interesa muchisimo, porque lo de la buena (que no se cuelga me interesa) y lo de la mala que se tarda mucho... +/- ¿cuanto es mucho?... incluso si tarda cinco minutos no me hace problema. Mi sistema lo usan todo el dia, y lo que yo cargo en un unImage son una imagenes publicitarias de otros servicios que brindo y tambien les aviso de una nueva version, estas imagenes yo las ponto en mi host y las rutas a esas imagenes los tengo en un archivo de texto tambien en el host. Cargo el archivo de texto, leo las direcciones y muestro las imagenes en ratios de 1 minuto cada una. Que empiece a hacer esto al minuto o a los 5 minutos de que inician el programa no me afecta siempre que no se les cuelgue. Hasta ahora me funcionó y ante esa eventualidad queria estar preparado.
Cierto me equivoque en la linea donde se cuelga.
Voy a probar este ultimo código que publicaste, gracia amigo.
-
He aplicado el codigo donde preguntamos por google.com, trabajando en la maquina virtual, no se porque cuando apago el router y lo vuelvo a enchufar y espero sigue asumiendo que estamos desconectados. En un momento cerre el VB6 y al volver entrar me reconocio, volvi a hacer la operacion de apagar y prender y cerrar VB6 y hasta ahora asume desconectado.
Cuando estamos desconectados en la parte de Do While xml.readyState <> 4 entra a un loop infinito que logicamente no me cuelga el programa por el DoEvents, pero preferi poner un limite que si despues de 500 vueltas no da valor es que no hay internet y salga del loop con el mensaje de que no hay internet. Entonces el codigo me va quedando asi:
Dim ciclos As Integer
Option Explicit
Public Function CheckConnection(sURL) As Boolean
Dim xml As Object
Set xml = CreateObject("Microsoft.XMLHTTP")
xml.Open "GET", sURL, True
xml.Send
Do While xml.readyState <> 4 'cuando no hay internet este loop se hace infinito
DoEvents
ciclos = ciclos + 1
If ciclos = 500 Then 'No se si 500 sea muy poco lo cierto es que lo realiza casi de inmediato
CheckConnection = False
ciclos = 0
Set xml = Nothing
Exit Function
End If
Loop
CheckConnection = CBool(xml.Status = 0)
Set xml = Nothing
End Function
Private Sub Timer1_Timer()
If CheckConnection("http://www.google.com/") Then
Label1 = "Hay Internet"
Else
Label1 = "No Hay Internet"
End If
End Sub
Sucede que se queda como "pegado" porque siempre me termina saliendo "No hay Internet" a pesar de que si hay internet. ¿porque puede estar pasando esto?
Gracias
-
Algo no estoy destruyendo bien? o algo falta inicializar? porque cuando lo ejecute la primera vez si me salio Hay Internet... luego ya no.
[youtube]http://www.youtube.com/watch?v=-235mH0eyN4[/youtube]
El aplicativo tiene 5 minutos levantado y aun el codigo del timer no detecta la presencia del internet.
-
Encontre este codigo, tarda como 8 a 10 segundos. para actualizar el estado dale click como 4 5 veces al boton y a ver que tal.
Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal lpszConnectionName As String, ByVal dwNameLen As Integer, ByVal dwReserved As Long) As Long
Public Function CheckInternetConnection() As Boolean
Dim aux As String * 255
Dim r As Long
r = InternetGetConnectedStateEx(r, aux, 254, 0)
If r = 1 Then
CheckInternetConnection = True
Else
CheckInternetConnection = False
End If
End Function
Private Sub Command1_Click()
If (CheckInternetConnection = True) Then
MsgBox "si!"
Else
MsgBox "no"
End If
End Sub
-
Gracias Enter. Pero lamentablemente no funciono para mis propositos.
Te muestro el escenario. Estando dentro de una Maquina Virtual con internet y cambiando el codigo del comand1 a un timer y que me avise mediante un label:
1.- Ejecute y reconocio internet. Mensaje en label "Hay Internet", bien alli.
2.- Deshabilite la conexion de red de la maquina virtual en caliente y el programa cambio a "No Hay internet". Bien hasta aqui.
3.- Habilite en caliente y el programa respondio: "Hay Internet", bien alli.
4.- Teniendo el programa abierto fui al router y lo apague... el programa seguia con "Hay Internet"
5.- Cerre el programa porque quiza InternetGetConnectedStateEx necesita ser reiniciado.
6.- Abri el programa nuevamente y siguio dando "Hay internet" teniendo el router aun apagado.
No se me colgo en ningun momento pero no me esta dando la informacion que necesito, parece que ese codigo checa si la red esta habilitida no si hay presencia de internet, me parece.
P.D: La web de tu firma ya no existe, considera cambiarla o usa un wordpress aunque el nombre de dominio cambiaria a www.enterpy.wordpress.com lo haces una vez y te olvidas para siempre sin necesidad de mantenerlo.
-
A ver este creo que funciona como quieres. Apague y prendí el router y lo hace bien.
Private Declare Function InternetGetConnectedState Lib "wininet" (ByRef dwflags As Long, ByVal dwReserved As Long) As Long
Private Const CONNECT_LAN As Long = &H2
Private Const CONNECT_MODEM As Long = &H1
Private Const CONNECT_PROXY As Long = &H4
Private Const CONNECT_OFFLINE As Long = &H20
Private Const CONNECT_CONFIGURED As Long = &H40
Public Function IsWebConnected(Optional ByRef ConnType As String) As Boolean
Dim dwflags As Long
Dim WebTest As Boolean
ConnType = ""
WebTest = InternetGetConnectedState(dwflags, 0&)
Select Case WebTest
Case dwflags And CONNECT_LAN: ConnType = "LAN"
Case dwflags And CONNECT_MODEM: ConnType = "Modem"
Case dwflags And CONNECT_PROXY: ConnType = "Proxy"
Case dwflags And CONNECT_OFFLINE: ConnType = "Offline"
Case dwflags And CONNECT_CONFIGURED: ConnType = "Configured"
Case dwflags And CONNECT_RAS: ConnType = "Remote"
End Select
IsWebConnected = WebTest
End Function
Private Sub Timer1_Timer()
Dim msg As String
If IsWebConnected(msg) Then
Picture1.BackColor = vbGreen
Else
Picture1.BackColor = vbRed
End If
End Sub
-
esa la de poner una comprobante de ciclos es buena, pero no de esa forma, 500 ciclos es prácticamente nada, no da tiempo a conectar lo mejor es manejarse con tiempo en segundos ya que los ciclos según la pc pueden variar
mira de esta forma le doy un tiempo de 5 segundos, vos si queres dale menos.
Option Explicit
Public Function CheckConnection(sURL) As Boolean
Dim xml As Object
Dim lTime As Long
Set xml = CreateObject("Microsoft.XMLHTTP")
xml.Open "GET", sURL, True
xml.Send
lTime = Timer
Do While xml.readyState <> 4
DoEvents
If lTime + 5 < Timer Then '5 Segundos de espera
CheckConnection = False
Set xml = Nothing
Exit Function
End If
Loop
CheckConnection = CBool(xml.Status = 0)
Set xml = Nothing
End Function
Private Sub Timer1_Timer()
If CheckConnection("http://www.google.com/") Then
Label1 = "Hay Internet"
Else
Label1 = "No Hay Internet"
End If
End Sub
ojo el timer dale mas de 5 segundos de vueltas sino es como que se juntan.
-
A ver este creo que funciona como quieres. Apague y prendí el router y lo hace bien.
Private Declare Function InternetGetConnectedState Lib "wininet" (ByRef dwflags As Long, ByVal dwReserved As Long) As Long
Private Const CONNECT_LAN As Long = &H2
Private Const CONNECT_MODEM As Long = &H1
Private Const CONNECT_PROXY As Long = &H4
Private Const CONNECT_OFFLINE As Long = &H20
Private Const CONNECT_CONFIGURED As Long = &H40
Public Function IsWebConnected(Optional ByRef ConnType As String) As Boolean
Dim dwflags As Long
Dim WebTest As Boolean
ConnType = ""
WebTest = InternetGetConnectedState(dwflags, 0&)
Select Case WebTest
Case dwflags And CONNECT_LAN: ConnType = "LAN"
Case dwflags And CONNECT_MODEM: ConnType = "Modem"
Case dwflags And CONNECT_PROXY: ConnType = "Proxy"
Case dwflags And CONNECT_OFFLINE: ConnType = "Offline"
Case dwflags And CONNECT_CONFIGURED: ConnType = "Configured"
Case dwflags And CONNECT_RAS: ConnType = "Remote"
End Select
IsWebConnected = WebTest
End Function
Private Sub Timer1_Timer()
Dim msg As String
If IsWebConnected(msg) Then
Picture1.BackColor = vbGreen
Else
Picture1.BackColor = vbRed
End If
End Sub
Doc, dame el mismo problema de siempre, desconecto y sigue apareciendo conectado (o en verde en tu codigo). El problema es que tu estas probando con una conexion directa y no desde una maquina virtual. Con conexion directa o en red todos los codigos me funcionan, pero no desde una maquina virtual para simular lo que me sucede con el cliente del problema.
Ahora voy a ver el codigo de Leandro
-
Es desde una maquina virtual amigo
-
Leandro, se redujo bastante los inconvenientes, pero aun sigue un pequeño inconveniente, no muy grave pero inconveniente al fin, permíteme mostrarte este vídeo de 7 minutos para explicarte mejor el tema.
[youtube]http://www.youtube.com/watch?v=bajUAAxf8hY[/youtube]
-
Es desde una maquina virtual amigo
Si, y simula perfectamente cuando tienes el router y todo ok pero tu proveedor de internet no te provee internet. Por eso comentaba que prueben este tema dentro de una maquina virtual.
-
Cuando dije es una maquina virtual te estaba diciendo que tambien lo probe en una maquina virtual.
Aca te dejo una captura desde el celular mientras los estaba probando.
[youtube]http://www.youtube.com/watch?v=RtUGiEIeBPI&feature=youtu.be[/youtube]
-
Yvan en cuanto lo tenes al timer?, se me hace que no se descarga el objeto., otra cosa que se pasaba por alto es cancelar el blucle en caso de cerrar el form
aver proba asi, no cambia mucho solo aumento el timer
Option Explicit
Dim bCancel As Long
Public Function CheckConnection(sURL) As Boolean
Dim xml As Object
Dim lTime As Long
Set xml = CreateObject("Microsoft.XMLHTTP")
xml.Open "GET", sURL, True
xml.Send
bCancel = False
lTime = Timer
Do While xml.readyState <> 4
If bCancel Then Exit Function
DoEvents
If lTime + 10 < Timer Then '5 Segundos de espera
CheckConnection = False
Set xml = Nothing
Exit Function
End If
Loop
CheckConnection = CBool(xml.Status = 0)
Set xml = Nothing
End Function
Private Sub Form_Load()
Timer1.Interval = 12000
End Sub
Private Sub Form_Unload(Cancel As Integer)
bCancel = True
End Sub
Private Sub Timer1_Timer()
If CheckConnection("http://www.google.com/") Then
Label1 = "Hay Internet"
Else
Label1 = "No Hay Internet"
End If
End Sub
estoy casi seguro que tenes el timer mas rapido que el tiempo de espera.
-
Este es otro metodo tambien me funciona muy bien hace ping constantemente a un ip determinado. y si todo va bien dice OK, o sino lista los errores posibles.
FUENTE: http://support.microsoft.com/kb/300197/es (http://support.microsoft.com/kb/300197/es)
EN UN MODULO.
Option Explicit
'Icmp constants converted from
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wmisdk/wmi/win32_pingstatus.asp
Private Const ICMP_SUCCESS As Long = 0
Private Const ICMP_STATUS_BUFFER_TO_SMALL = 11001 'Buffer Too Small
Private Const ICMP_STATUS_DESTINATION_NET_UNREACH = 11002 'Destination Net Unreachable
Private Const ICMP_STATUS_DESTINATION_HOST_UNREACH = 11003 'Destination Host Unreachable
Private Const ICMP_STATUS_DESTINATION_PROTOCOL_UNREACH = 11004 'Destination Protocol Unreachable
Private Const ICMP_STATUS_DESTINATION_PORT_UNREACH = 11005 'Destination Port Unreachable
Private Const ICMP_STATUS_NO_RESOURCE = 11006 'No Resources
Private Const ICMP_STATUS_BAD_OPTION = 11007 'Bad Option
Private Const ICMP_STATUS_HARDWARE_ERROR = 11008 'Hardware Error
Private Const ICMP_STATUS_LARGE_PACKET = 11009 'Packet Too Big
Private Const ICMP_STATUS_REQUEST_TIMED_OUT = 11010 'Request Timed Out
Private Const ICMP_STATUS_BAD_REQUEST = 11011 'Bad Request
Private Const ICMP_STATUS_BAD_ROUTE = 11012 'Bad Route
Private Const ICMP_STATUS_TTL_EXPIRED_TRANSIT = 11013 'TimeToLive Expired Transit
Private Const ICMP_STATUS_TTL_EXPIRED_REASSEMBLY = 11014 'TimeToLive Expired Reassembly
Private Const ICMP_STATUS_PARAMETER = 11015 'Parameter Problem
Private Const ICMP_STATUS_SOURCE_QUENCH = 11016 'Source Quench
Private Const ICMP_STATUS_OPTION_TOO_BIG = 11017 'Option Too Big
Private Const ICMP_STATUS_BAD_DESTINATION = 11018 'Bad Destination
Private Const ICMP_STATUS_NEGOTIATING_IPSEC = 11032 'Negotiating IPSEC
Private Const ICMP_STATUS_GENERAL_FAILURE = 11050 'General Failure
Public Const WINSOCK_ERROR = "Windows Sockets not responding correctly."
Public Const INADDR_NONE As Long = &HFFFFFFFF
Public Const WSA_SUCCESS = 0
Public Const WS_VERSION_REQD As Long = &H101
'Clean up sockets.
'http://support.microsoft.com/default.aspx?scid=kb;EN-US;q154512
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
'Open the socket connection.
'http://support.microsoft.com/default.aspx?scid=kb;EN-US;q154512
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
'Create a handle on which Internet Control Message Protocol (ICMP) requests can be issued.
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wcesdkr/htm/_wcesdk_icmpcreatefile.asp
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
'Convert a string that contains an (Ipv4) Internet Protocol dotted address into a correct address.
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/wsapiref_4esy.asp
Private Declare Function inet_addr Lib "WSOCK32.DLL" (ByVal cp As String) As Long
'Close an Internet Control Message Protocol (ICMP) handle that IcmpCreateFile opens.
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wcesdkr/htm/_wcesdk_icmpclosehandle.asp
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
'Information about the Windows Sockets implementation
'http://support.microsoft.com/default.aspx?scid=kb;EN-US;q154512
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To 256) As Byte
szSystemStatus(0 To 128) As Byte
iMaxSockets As Long
iMaxUDPDG As Long
lpVendorInfo As Long
End Type
'Send an Internet Control Message Protocol (ICMP) echo request, and then return one or more replies.
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wcetcpip/htm/cerefIcmpSendEcho.asp
Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Long, ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal Timeout As Long) As Long
'This structure describes the options that will be included in the header of an IP packet.
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wcetcpip/htm/cerefIP_OPTION_INFORMATION.asp
Private Type IP_OPTION_INFORMATION
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
'This structure describes the data that is returned in response to an echo request.
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wcesdkr/htm/_wcesdk_icmp_echo_reply.asp
Public Type ICMP_ECHO_REPLY
address As Long
Status As Long
RoundTripTime As Long
DataSize As Long
Reserved As Integer
ptrData As Long
Options As IP_OPTION_INFORMATION
Data As String * 250
End Type
'-- Ping a string representation of an IP address.
' -- Return a reply.
' -- Return long code.
Public Function ping(sAddress As String, Reply As ICMP_ECHO_REPLY) As Long
Dim hIcmp As Long
Dim lAddress As Long
Dim lTimeOut As Long
Dim StringToSend As String
'Short string of data to send
StringToSend = "hello"
'ICMP (ping) timeout
lTimeOut = 1000 'ms
'Convert string address to a long representation.
lAddress = inet_addr(sAddress)
If (lAddress <> -1) And (lAddress <> 0) Then
'Create the handle for ICMP requests.
hIcmp = IcmpCreateFile()
If hIcmp Then
'Ping the destination IP address.
Call IcmpSendEcho(hIcmp, lAddress, StringToSend, Len(StringToSend), 0, Reply, Len(Reply), lTimeOut)
'Reply status
ping = Reply.Status
'Close the Icmp handle.
IcmpCloseHandle hIcmp
Else
Debug.Print "failure opening icmp handle."
ping = -1
End If
Else
ping = -1
End If
End Function
'Clean up the sockets.
'http://support.microsoft.com/default.aspx?scid=kb;EN-US;q154512
Public Sub SocketsCleanup()
WSACleanup
End Sub
'Get the sockets ready.
'http://support.microsoft.com/default.aspx?scid=kb;EN-US;q154512
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = ICMP_SUCCESS
End Function
'Convert the ping response to a message that you can read easily from constants.
'For more information about these constants, visit the following Microsoft Web site:
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wmisdk/wmi/win32_pingstatus.asp
Public Function EvaluatePingResponse(PingResponse As Long) As String
Select Case PingResponse
'Success
'Case ICMP_SUCCESS: EvaluatePingResponse = "Success!"
Case ICMP_SUCCESS: EvaluatePingResponse = "OK"
'Some error occurred
Case ICMP_STATUS_BUFFER_TO_SMALL: EvaluatePingResponse = "Buffer Too Small"
Case ICMP_STATUS_DESTINATION_NET_UNREACH: EvaluatePingResponse = "Destination Net Unreachable"
Case ICMP_STATUS_DESTINATION_HOST_UNREACH: EvaluatePingResponse = "Destination Host Unreachable"
Case ICMP_STATUS_DESTINATION_PROTOCOL_UNREACH: EvaluatePingResponse = "Destination Protocol Unreachable"
Case ICMP_STATUS_DESTINATION_PORT_UNREACH: EvaluatePingResponse = "Destination Port Unreachable"
Case ICMP_STATUS_NO_RESOURCE: EvaluatePingResponse = "No Resources"
Case ICMP_STATUS_BAD_OPTION: EvaluatePingResponse = "Bad Option"
Case ICMP_STATUS_HARDWARE_ERROR: EvaluatePingResponse = "Hardware Error"
Case ICMP_STATUS_LARGE_PACKET: EvaluatePingResponse = "Packet Too Big"
Case ICMP_STATUS_REQUEST_TIMED_OUT: EvaluatePingResponse = "Request Timed Out"
Case ICMP_STATUS_BAD_REQUEST: EvaluatePingResponse = "Bad Request"
Case ICMP_STATUS_BAD_ROUTE: EvaluatePingResponse = "Bad Route"
Case ICMP_STATUS_TTL_EXPIRED_TRANSIT: EvaluatePingResponse = "TimeToLive Expired Transit"
Case ICMP_STATUS_TTL_EXPIRED_REASSEMBLY: EvaluatePingResponse = "TimeToLive Expired Reassembly"
Case ICMP_STATUS_PARAMETER: EvaluatePingResponse = "Parameter Problem"
Case ICMP_STATUS_SOURCE_QUENCH: EvaluatePingResponse = "Source Quench"
Case ICMP_STATUS_OPTION_TOO_BIG: EvaluatePingResponse = "Option Too Big"
Case ICMP_STATUS_BAD_DESTINATION: EvaluatePingResponse = "Bad Destination"
Case ICMP_STATUS_NEGOTIATING_IPSEC: EvaluatePingResponse = "Negotiating IPSEC"
Case ICMP_STATUS_GENERAL_FAILURE: EvaluatePingResponse = "General Failure"
'Unknown error occurred
Case Else: EvaluatePingResponse = "Unknown Response"
End Select
End Function
EN UN FORMULARIO.
Private Sub Timer1_Timer()
Dim Reply As ICMP_ECHO_REPLY
Dim lngSuccess As Long
Dim strIPAddress As String
'Get the sockets ready.
If SocketsInitialize() Then
'Address to ping
strIPAddress = "173.194.37.19" 'IP GOOGLE
lngSuccess = ping(strIPAddress, Reply)
If EvaluatePingResponse(lngSuccess) = "OK" Then
Picture1.BackColor = vbGreen
Else
Picture1.BackColor = vbRed
End If
'Clean up the sockets.
SocketsCleanup
Else
Debug.Print WINSOCK_ERROR
End If
End Sub
-
Cuando dije es una maquina virtual te estaba diciendo que tambien lo probe en una maquina virtual.
Aca te dejo una captura desde el celular mientras los estaba probando.
Si mi broder, efectivamente tienes razon, voy a volver a revisar todo a ver que esta pasando.
-
Yvan en cuanto lo tenes al timer?, se me hace que no se descarga el objeto., otra cosa que se pasaba por alto es cancelar el blucle en caso de cerrar el form
...
estoy casi seguro que tenes el timer mas rapido que el tiempo de espera.
Saludos doc, buenas y malas noticias. Efectivamente tenia el timer en 1000 de interval. Lo cambie a 12,000 y use el ultimo código que publicas, ejecute y lamentablemente sigo teniendo el mismo efecto, osea cuando cierro y ejecuto el proyecto ya teniendo el internet restaurado me sigue saliendo "No hay Internet" y solo se restablece si cierro el VB6 como mostré en el ultimo video.
Probare también lo del ping que comenta Enter.
-
Este es otro metodo tambien me funciona muy bien hace ping constantemente a un ip determinado. y si todo va bien dice OK, o sino lista los errores posibles.
....
No amigo, no me resulto, gracias por darme una mano, pero no me resulto, no lo he probado totalmente, es mas ni siquiera apague el router porque ni bien ejecute el codigo el formulario se relentiza demasiado, osea, esta cambiando de rojo a verde (no se porque) y mientras voy escribiendo en un textbox, lo que voy escribiendo se frena o se congela y luego aparece el texto que escribi, por eso no profundice mas en este aporte. Igual muchas gracias por tu tiempo, pero voy a usar el ultimo codigo de Leandro que al menos me cubre en un alto porcentaje la solución del problema.
Muchas gracias.
-
Que raro che por que como te mostré en el vídeo la 2da opción me funciona bastante bien desactivando las redes, volviendo a activar y por ultimo apagando y prendiendo el router directamente.
-
¿Pero chequeaste poniendo un textbox por ejemplo y mientras se ejecuta ese programa ir escribiendo? Es alli donde se frena lo que uno escribe.
-
Creo que el Timer se está ahogando. :P
Yo suelo desactivar los Timers al inicio del evento Timer() y los activo al final del mismo. De este modo no damos a nuestro PC tanto trabajo. Además, teniendo en cuenta que lo pruebas en una VM, le costará más. :-\
Prueba así (fíjate en las líneas destacadas):
Option Explicit
Private Declare Function InternetCheckConnectionA Lib "wininet.dll" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Const FLAG_ICC_FORCE_CONNECTION As Long = &H1
Public Function IsInternetOn() As Boolean
IsInternetOn = InternetCheckConnectionA("http://www.google.com/", FLAG_ICC_FORCE_CONNECTION, 0&)
End Function
Private Sub Timer1_Timer()
Timer1.Enabled = False
If IsInternetOn Then
Label1 = "Hay Internet"
Else
Label1 = "No Hay Internet"
End If
Timer1.Enabled = True
End Sub
DoEvents! :P
-
Saludos Psyke1.
Probé tu código tal cual (proyecto nuevo como todos los anteriores), pero creo que ya empezaré a tirar lo toalla porque al parecer debe tratarse de alguna excepción en vista que a todos le funciona al 100 pero a mi no, e imagino que es algo que deba ver con mi maquina virtual, luego armaré otra y probaré en ella.
(El timer lo puse a 12 segundos y use tu código)
Estos fueron los resultados y los ejecuté en este orden, cada cambio lo mencionaré.
Con el programa en ejecución:
1.- Detectó conexión a internet: OK
2.- Deshabilité la red la maquina virtual: No hay Internet: OK
3.- Habilite la red y el programa lo reconoció: OK
4.- Desconecte el router y el label siguió con Hay Internet: Espere 2 minutos e igual, debugee y IsInternetOn me sigue dando true a pesar de estar el router apagado.
Detuve el programa y lo volví a ejecutar (ojo, sigue router apagado)
5.- El programa se colgó y se colgó feo. Quedo congelado y luego de un rato me detecto que no hay internet pero siguió quedándose colgado. Lo tuve que detener en la primera que me dejo hacerlo.
Prendí el router
6.- Ejecute el programa y me reconoció el internet. A diferencia de los códigos anteriores esta vez no fue necesario cerrar el VB6 para el segundo intento.
Este código no presento el problema de no operar bien en el segundo intento y me obligaba a cerrar el VB6 pero me cuelga cuando no hay internet, motivo inicial de este post.
Gracias por tu tiempo
-
Esto es viejo pero parece que aun no esta resuelto.... yo tengo una manera que es haciendole PING a la pagina. esta bueno y no genera el problema que tenes....
Aca va >>
Esto en un Modulo !!!
Option Explicit
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
'Icmp constants converted from
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wmisdk/wmi/win32_pingstatus.asp
Private Const ICMP_SUCCESS As Long = 0
Private Const ICMP_STATUS_BUFFER_TO_SMALL = 11001 'Buffer Too Small
Private Const ICMP_STATUS_DESTINATION_NET_UNREACH = 11002 'Destination Net Unreachable
Private Const ICMP_STATUS_DESTINATION_HOST_UNREACH = 11003 'Destination Host Unreachable
Private Const ICMP_STATUS_DESTINATION_PROTOCOL_UNREACH = 11004 'Destination Protocol Unreachable
Private Const ICMP_STATUS_DESTINATION_PORT_UNREACH = 11005 'Destination Port Unreachable
Private Const ICMP_STATUS_NO_RESOURCE = 11006 'No Resources
Private Const ICMP_STATUS_BAD_OPTION = 11007 'Bad Option
Private Const ICMP_STATUS_HARDWARE_ERROR = 11008 'Hardware Error
Private Const ICMP_STATUS_LARGE_PACKET = 11009 'Packet Too Big
Private Const ICMP_STATUS_REQUEST_TIMED_OUT = 11010 'Request Timed Out
Private Const ICMP_STATUS_BAD_REQUEST = 11011 'Bad Request
Private Const ICMP_STATUS_BAD_ROUTE = 11012 'Bad Route
Private Const ICMP_STATUS_TTL_EXPIRED_TRANSIT = 11013 'TimeToLive Expired Transit
Private Const ICMP_STATUS_TTL_EXPIRED_REASSEMBLY = 11014 'TimeToLive Expired Reassembly
Private Const ICMP_STATUS_PARAMETER = 11015 'Parameter Problem
Private Const ICMP_STATUS_SOURCE_QUENCH = 11016 'Source Quench
Private Const ICMP_STATUS_OPTION_TOO_BIG = 11017 'Option Too Big
Private Const ICMP_STATUS_BAD_DESTINATION = 11018 'Bad Destination
Private Const ICMP_STATUS_NEGOTIATING_IPSEC = 11032 'Negotiating IPSEC
Private Const ICMP_STATUS_GENERAL_FAILURE = 11050 'General Failure
Public Const WINSOCK_ERROR = "Windows Sockets not responding correctly."
Public Const INADDR_NONE As Long = &HFFFFFFFF
Public Const WSA_SUCCESS = 0
Public Const WS_VERSION_REQD As Long = &H101
'Clean up sockets.
'http://support.microsoft.com/default.aspx?scid=kb;EN-US;q154512
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
'Open the socket connection.
'http://support.microsoft.com/default.aspx?scid=kb;EN-US;q154512
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
'Create a handle on which Internet Control Message Protocol (ICMP) requests can be issued.
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wcesdkr/htm/_wcesdk_icmpcreatefile.asp
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
'Convert a string that contains an (Ipv4) Internet Protocol dotted address into a correct address.
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/wsapiref_4esy.asp
Private Declare Function inet_addr Lib "WSOCK32.DLL" (ByVal cp As String) As Long
'Close an Internet Control Message Protocol (ICMP) handle that IcmpCreateFile opens.
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wcesdkr/htm/_wcesdk_icmpclosehandle.asp
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
'Information about the Windows Sockets implementation
'http://support.microsoft.com/default.aspx?scid=kb;EN-US;q154512
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To 256) As Byte
szSystemStatus(0 To 128) As Byte
iMaxSockets As Long
iMaxUDPDG As Long
lpVendorInfo As Long
End Type
'Send an Internet Control Message Protocol (ICMP) echo request, and then return one or more replies.
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wcetcpip/htm/cerefIcmpSendEcho.asp
Private Declare Function IcmpSendEcho Lib "icmp.dll" _
(ByVal IcmpHandle As Long, _
ByVal DestinationAddress As Long, _
ByVal RequestData As String, _
ByVal RequestSize As Long, _
ByVal RequestOptions As Long, _
ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Long, _
ByVal Timeout As Long) As Long
'This structure describes the options that will be included in the header of an IP packet.
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wcetcpip/htm/cerefIP_OPTION_INFORMATION.asp
Private Type IP_OPTION_INFORMATION
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
'This structure describes the data that is returned in response to an echo request.
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wcesdkr/htm/_wcesdk_icmp_echo_reply.asp
Public Type ICMP_ECHO_REPLY
address As Long
Status As Long
RoundTripTime As Long
DataSize As Long
Reserved As Integer
ptrData As Long
Options As IP_OPTION_INFORMATION
Data As String * 250
End Type
'-- Ping a string representation of an IP address.
' -- Return a reply.
' -- Return long code.
Public Function ping(sAddress As String, Reply As ICMP_ECHO_REPLY) As Long
Dim hIcmp As Long
Dim lAddress As Long
Dim lTimeOut As Long
Dim StringToSend As String
'Short string of data to send
StringToSend = "hello"
'ICMP (ping) timeout
lTimeOut = 1000 'ms
'Convert string address to a long representation.
lAddress = inet_addr(sAddress)
If (lAddress <> -1) And (lAddress <> 0) Then
'Create the handle for ICMP requests.
hIcmp = IcmpCreateFile()
If hIcmp Then
'Ping the destination IP address.
Call IcmpSendEcho(hIcmp, lAddress, StringToSend, Len(StringToSend), 0, Reply, Len(Reply), lTimeOut)
'Reply status
ping = Reply.Status
'Close the Icmp handle.
IcmpCloseHandle hIcmp
Else
Debug.Print "failure opening icmp handle."
ping = -1
End If
Else
ping = -1
End If
End Function
'Clean up the sockets.
'http://support.microsoft.com/default.aspx?scid=kb;EN-US;q154512
Public Sub SocketsCleanup()
WSACleanup
End Sub
'Get the sockets ready.
'http://support.microsoft.com/default.aspx?scid=kb;EN-US;q154512
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = ICMP_SUCCESS
End Function
'Convert the ping response to a message that you can read easily from constants.
'For more information about these constants, visit the following Microsoft Web site:
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wmisdk/wmi/win32_pingstatus.asp
Public Function EvaluatePingResponse(PingResponse As Long) As String
Select Case PingResponse
'Success
Case ICMP_SUCCESS: EvaluatePingResponse = "Online"
'Some error occurred
Case ICMP_STATUS_BUFFER_TO_SMALL: EvaluatePingResponse = "Buffer Too Small"
Case ICMP_STATUS_DESTINATION_NET_UNREACH: EvaluatePingResponse = "Destination Net Unreachable"
Case ICMP_STATUS_DESTINATION_HOST_UNREACH: EvaluatePingResponse = "Destination Host Unreachable"
Case ICMP_STATUS_DESTINATION_PROTOCOL_UNREACH: EvaluatePingResponse = "Destination Protocol Unreachable"
Case ICMP_STATUS_DESTINATION_PORT_UNREACH: EvaluatePingResponse = "Destination Port Unreachable"
Case ICMP_STATUS_NO_RESOURCE: EvaluatePingResponse = "No Resources"
Case ICMP_STATUS_BAD_OPTION: EvaluatePingResponse = "Bad Option"
Case ICMP_STATUS_HARDWARE_ERROR: EvaluatePingResponse = "Hardware Error"
Case ICMP_STATUS_LARGE_PACKET: EvaluatePingResponse = "Packet Too Big"
Case ICMP_STATUS_REQUEST_TIMED_OUT: EvaluatePingResponse = "Caido" 'Request Timed Out
Case ICMP_STATUS_BAD_REQUEST: EvaluatePingResponse = "Bad Request"
Case ICMP_STATUS_BAD_ROUTE: EvaluatePingResponse = "Bad Route"
Case ICMP_STATUS_TTL_EXPIRED_TRANSIT: EvaluatePingResponse = "TimeToLive Expired Transit"
Case ICMP_STATUS_TTL_EXPIRED_REASSEMBLY: EvaluatePingResponse = "TimeToLive Expired Reassembly"
Case ICMP_STATUS_PARAMETER: EvaluatePingResponse = "Parameter Problem"
Case ICMP_STATUS_SOURCE_QUENCH: EvaluatePingResponse = "Source Quench"
Case ICMP_STATUS_OPTION_TOO_BIG: EvaluatePingResponse = "Option Too Big"
Case ICMP_STATUS_BAD_DESTINATION: EvaluatePingResponse = "Bad Destination"
Case ICMP_STATUS_NEGOTIATING_IPSEC: EvaluatePingResponse = "Negotiating IPSEC"
Case ICMP_STATUS_GENERAL_FAILURE: EvaluatePingResponse = "General Failure"
'Unknown error occurred
Case Else: EvaluatePingResponse = "Unknown Response"
End Select
End Function
Esto en El formulario, Particularmente en un timer con 5 segundos...
Dim Reply As ICMP_ECHO_REPLY
Dim lngSuccess As Long
Dim strIPAddress As String
If SocketsInitialize() Then
strIPAddress = "8.8.8.8" > DNS DE GOOGLE generalmente usado para hacer ping, podes poner la de tu pagina web o la que vos quieras...
lngSuccess = ping(strIPAddress, Reply)
If EvaluatePingResponse(lngSuccess) <> "Online" Then
Debug.Print "NO HAY INTERNET"
Else
Debug.Print "HAY INTERNET"
End If
SocketsCleanup
Else
Debug.Print WINSOCK_ERROR
End If
El resultado es instantaneo... yo lo eh probado y funciona perfecto y no tiene el problema que vos decis...
SALUDOS =)
-
Hola amigo estuve viendo tu video y me parece que no se liberan los recursos del objeto que creas y la mejor prueba es que al cargar el visual de nuevo anda correcto.
Dejame hacer unas pruebas y te hago el comentario mas claro
-
YO lo probe exactamente como vos lo estas haciendo y me funciona correctamente de las 2 maneras dentro de la VM y fuera .
Solo que no se si lo que tu dices de desconectar el router es quitarle la alimentacion o desconectar el cable de red del mismo. (esto ultimo es lo que yo hice)
Ojala te sirva
-
intenta con esto!
Option Explicit
Dim xml As Object
Public Function CheckConnection(sURL) As Boolean
Dim lTime As Long
xml.Open "GET", sURL, True
xml.Send
lTime = Timer
Do While xml.readyState <> 4
DoEvents
If lTime + 5 < Timer Then '5 Segundos de espera
CheckConnection = False
Exit Function
End If
Loop
CheckConnection = CBool(xml.Status = 0)
End Function
Private Sub Form_Load()
Set xml = CreateObject("Microsoft.XMLHTTP")
Timer1 = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Timer1 = False
Set xml = Nothing
End Sub
Private Sub Timer1_Timer()
If CheckConnection("http://www.google.com.ar/") Then
Label1 = "Hay Internet"
Else
Label1 = "No Hay Internet"
End If
End Sub
-
Bueno debido a que es un tema interesante. cree un pequeño modulo para facilitarle la vida a muchos...
Aca dejo el link de descarga de mi dropbox DESCARGAR (https://dl.dropboxusercontent.com/u/6160346/Vb6/mPing.bas)
Es muy muy muy simple...
Insertamos un Timer en el formulario y dentro del timer colocamos la siguiente linea.
Debug.Print mPing.PingRequest
Nos va a devolver un resultado Boolean osea Verdadero o Falso
Lo unico que habria que hacer es un IF comparando si hay o no conexion
Ademas puse como opcional que se pueda cambiar el DNS, en este caso puse los dns de google 8.8.8.8 pero simplemente agregando la ip entre paracentesis podemos cambiarlo rapidamente de esta manera:
Debug.Print mPing.PingRequest("192.168.1.1")
Espero les haya servido, SALUDOS
PD: El timer ponganle intervalo 5 o 10 segundos puede que al hacer tanto tiempo ping dependiendo el host nos bloquee el accesso.
-
Estimados Todos
Las disculpas del caso por reabrir el post, pero considero que es un post de importancia y sería bueno saber si se llego a resolver.
Saludos, desde algún lugar de Lima-Perú
-
Hola. Estoy esscribiendo desde tierras lejanas a la mia :-)
Primero, MIL DISCULPAS por no responder debidamente sobre el tema, el tema sucedio en el 2012 y recuerdo (porque ya es mucho tiempo) que no lo logre resolver, insisti un poco mas pero en ese momento ya no me dio el conocimiento y termine por abortar el tema. Luego en el 2014 Bazzoka y luego SKL dieron alternativas pero al haber sido dos años despues ya no los probe y me disculpo por no informarlo.
Afortunadamente conservo aun ese proyecto asi que cuando llegue a Peru (12/08/15) voy a volver a probarlo con las alternativas que me dieron para poder informar debidamente sus resultados.
Fuerte abrazo