ps_velan
asked on
Check Interternet Connection State
How Can I check..whether my system is connecting to Internet or not..
Pl check it before send it to me..
Thanks&Regards
Thanigaivelan PS
Pl check it before send it to me..
Thanks&Regards
Thanigaivelan PS
Are you connected via a dial-up DUN or via a router?
I created a class from a few snippets found on the internet. It is very much faster than waiting for a page from www.microsoft.com.
Hope this helps :~)
Example form code:
Option Explicit
Private WithEvents Dun As cDun
Private Sub Command1_Click()
Set Dun = New cDun
Dim UplineGateway$
Dim ok
'' for dial up connections
'ok = DUN.StartDUNOK(Me.hWnd, "My Connection Name")
'If ok Then
' ok = DUN.IsConnected
'End If
'If ok Then
' MsgBox "You are connected"
'Else
' MsgBox "You are not connected"
'End If
' for dial-on-demand ISDN routers or ADSL
' you need to find the IP address of your first external gateway
' to do this use the TRACERT command like:
' www.google.com
' The first IP address is your router
' the next is your first upline gateway unless
' you are in an office which is using an inter-company
' frame relay in which case you need use the first IP
' address not manage by your company.
UplineGateway = "DNS1"
ok = Dun.PingWaitOK(UplineGatew ay, 10)
If ok Then
MsgBox "You are connected"
Else
MsgBox "You are not connected"
End If
End Sub
-------------------cDun.cl s--------- -
Option Explicit
' please report any bugs or enhancements to:
' nyoung@vipintersoft.com
' Subject line re: cDun.CLS
' please send an email to register as a user and
' to received updates and fixes.
' Sample usage:
'Option Explicit
'Private WithEvents DUN As cDun
'Private Sub Command1_Click()
'
'
'Set DUN = New cDun
'
'Dim UplineGateway$
'Dim ok
'
'' for dial up connections
'ok = DUN.StartDUNOK(Me.hWnd, "My Connection Name")
'If ok Then
' ok = DUN.IsConnected
'End If
'If ok Then
' MsgBox "You are connected"
'Else
' MsgBox "You are not connected"
'End If
'
'' for dial-on-demand ISDN routers or ADSL
'' you need to find the IP address of your first external gateway
'' to do this use the TRACERT command like:
'' www.google.com
'' The first IP address is your router
'' the next is your first upline gateway unless
'' you are in an office which is using an inter-company
'' frame relay in which case you need use the first IP
'' address not manage by your company.
'' Or use your DNS
'UplineGateway = "xxx.xxx.xxx.xxx" or "DNS1"
'
'ok = DUN.PingWaitOK(UplineGatew ay, 10)
'If ok Then
' MsgBox "You are connected"
'Else
' MsgBox "You are not connected"
'End If
'
'
'End Sub
Dim ok
' Private variables
Private mlConnectionNumber As Long
Private mbDisconnectOnTerminate As Boolean
' Used to list the DUN connections
Private Type RAS_ENTRIES
dwSize As Long
szEntryName(256) As Byte
End Type
Private Declare Function RasEnumEntriesA Lib "RasApi32.dll" _
(ByVal reserved As String, ByVal lpszPhonebook As String, _
lprasentryname As Any, lpcb As Long, lpcEntries As Long) As Long
' For the fActiveConnection function
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" _
Alias "RegOpenKeyA" (ByVal hKey As Long, _
ByVal sSubKey As String, hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal sKeyValue As String, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, nSizeData As Long) As Long
' For Dial and Hangup functions
Private Declare Function InternetDial Lib "wininet.dll" _
(ByVal hWnd As Long, ByVal sConnectoid As String, _
ByVal dwFlags As Long, lpdwConnection As Long, _
ByVal dwReserved As Long) As Long
'Returns ERROR_SUCCESS if successfull
' ERROR_INVALID_PARAMETER - one or more parameters are incorrect
' ERROR_NO_CONNECTION - There is a problem with the dial-up connection
' ERROR_USER_DISCONNECTION - The user clicked either the work offline or cancel button on the dialog box
Private Declare Function InternetHangUp Lib "wininet.dll" _
(ByVal dwConnection As Long, ByVal dwReserved As Long) As Long
' Returns ERROR_SUCCESS if successfull or an error value otherwise.
' InternetAutodial flags
Private Const INTERNET_AUTODIAL_FORCE_ON LINE = &H1
Private Const INTERNET_AUTODIAL_FORCE_UN ATTENDED = &H2
Private Const INTERNET_AUTODIAL_FAILIFSE CURITYCHEC K = &H4
' InternetDial Flags - must not conflict with InternetAutodial
' flags as they are valid here also.
Private Const INTERNET_DIAL_FORCE_PROMPT = &H2000
Private Const INTERNET_DIAL_SHOW_OFFLINE = &H4000
Private Const INTERNET_DIAL_UNATTENDED = &H8000
' Windows error constants.
Private Const ERROR_SUCCESS As Long = 0&
Private Const ERROR_INVALID_PARAMETER = 87&
' RAS error constants
Private Const RASBASE As Long = 600& 'not sure about this couldn't find raserror.h anywhere on MSDN so
'best-guessed the value based on return code of 631 for cancel button
Private Const ERROR_NO_CONNECTION = (RASBASE + 68&)
Private Const ERROR_USER_DISCONNECTION = (RASBASE + 31&)
' Events for this module
Public Event ConnectionMade()
Public Event ConnectionClosed()
'
Const RAS95_MaxEntryName = 256
Const RAS95_MaxDeviceType = 16
Const RAS95_MaxDeviceName = 32
Private Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntry Name) As Byte
szDeviceType(RAS95_MaxDevi ceType) As Byte
szDeviceName(RAS95_MaxDevi ceName) As Byte
End Type
'
Private Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDevi ceType) As Byte
szDeviceName(RAS95_MaxDevi ceName) As Byte
End Type
Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Private Const IP_SUCCESS As Long = 0
Private Const IP_STATUS_BASE As Long = 11000
Private Const IP_BUF_TOO_SMALL As Long = (11000 + 1)
Private Const IP_DEST_NET_UNREACHABLE As Long = (11000 + 2)
Private Const IP_DEST_HOST_UNREACHABLE As Long = (11000 + 3)
Private Const IP_DEST_PROT_UNREACHABLE As Long = (11000 + 4)
Private Const IP_DEST_PORT_UNREACHABLE As Long = (11000 + 5)
Private Const IP_NO_RESOURCES As Long = (11000 + 6)
Private Const IP_BAD_OPTION As Long = (11000 + 7)
Private Const IP_HW_ERROR As Long = (11000 + 8)
Private Const IP_PACKET_TOO_BIG As Long = (11000 + 9)
Private Const IP_REQ_TIMED_OUT As Long = (11000 + 10)
Private Const IP_BAD_REQ As Long = (11000 + 11)
Private Const IP_BAD_ROUTE As Long = (11000 + 12)
Private Const IP_TTL_EXPIRED_TRANSIT As Long = (11000 + 13)
Private Const IP_TTL_EXPIRED_REASSEM As Long = (11000 + 14)
Private Const IP_PARAM_PROBLEM As Long = (11000 + 15)
Private Const IP_SOURCE_QUENCH As Long = (11000 + 16)
Private Const IP_OPTION_TOO_BIG As Long = (11000 + 17)
Private Const IP_BAD_DESTINATION As Long = (11000 + 18)
Private Const IP_ADDR_DELETED As Long = (11000 + 19)
Private Const IP_SPEC_MTU_CHANGE As Long = (11000 + 20)
Private Const IP_MTU_CHANGE As Long = (11000 + 21)
Private Const IP_UNLOAD As Long = (11000 + 22)
Private Const IP_ADDR_ADDED As Long = (11000 + 23)
Private Const IP_GENERAL_FAILURE As Long = (11000 + 50)
Private Const MAX_IP_STATUS As Long = (11000 + 50)
Private Const IP_PENDING As Long = (11000 + 255)
Private Const PING_TIMEOUT As Long = 500
Private Const WS_VERSION_REQD As Long = &H101
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Const INADDR_NONE As Long = &HFFFFFFFF
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
Private Type ICMP_OPTIONS
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
Private Type ICMP_ECHO_REPLY
Address As Long
status As Long
RoundTripTime As Long
DataSize As Long 'formerly 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 Long
wMaxUDPDG As Long
dwVendorInfo As Long
End Type
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" _
(ByVal IcmpHandle As Long) As Long
Private Declare Function IcmpSendEcho Lib "icmp.dll" _
(ByVal IcmpHandle As Long, _
ByVal DestinationAddress As Long, _
ByVal RequestData As String, _
ByVal RequestSize As Long, _
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 Declare Function gethostname Lib "WSOCK32.DLL" _
(ByVal szHost As String, _
ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
(ByVal szHost As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(xDest As Any, _
xSource As Any, _
ByVal nbytes As Long)
Private Declare Function inet_addr Lib "WSOCK32.DLL" _
(ByVal s As String) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Function PingWaitOK(PingAddress As String, TimeoutSeconds As Single) As Boolean
Dim StartTime As Date
Dim failreason As String
StartTime = Now
Dim Suc As Long
Do
Suc = Ping(PingAddress, failreason)
If Suc = 0 Then
PingWaitOK = True
Exit Function
End If
If DateDiff("S", Now, StartTime) > TimeoutSeconds Then
PingWaitOK = False
Exit Function
End If
Sleep 250
Loop
End Function
Public Function GetStatusCode(status As Long) As String
Dim msg As String
Select Case status
Case IP_SUCCESS: msg = "ip success"
Case INADDR_NONE: msg = "inet_addr: bad IP format"
Case IP_BUF_TOO_SMALL: msg = "ip buf too_small"
Case IP_DEST_NET_UNREACHABLE: msg = "ip dest net unreachable"
Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable"
Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable"
Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable"
Case IP_NO_RESOURCES: msg = "ip no resources"
Case IP_BAD_OPTION: msg = "ip bad option"
Case IP_HW_ERROR: msg = "ip hw_error"
Case IP_PACKET_TOO_BIG: msg = "ip packet too_big"
Case IP_REQ_TIMED_OUT: msg = "ip req timed out"
Case IP_BAD_REQ: msg = "ip bad req"
Case IP_BAD_ROUTE: msg = "ip bad route"
Case IP_TTL_EXPIRED_TRANSIT: msg = "ip ttl expired transit"
Case IP_TTL_EXPIRED_REASSEM: msg = "ip ttl expired reassem"
Case IP_PARAM_PROBLEM: msg = "ip param_problem"
Case IP_SOURCE_QUENCH: msg = "ip source quench"
Case IP_OPTION_TOO_BIG: msg = "ip option too_big"
Case IP_BAD_DESTINATION: msg = "ip bad destination"
Case IP_ADDR_DELETED: msg = "ip addr deleted"
Case IP_SPEC_MTU_CHANGE: msg = "ip spec mtu change"
Case IP_MTU_CHANGE: msg = "ip mtu_change"
Case IP_UNLOAD: msg = "ip unload"
Case IP_ADDR_ADDED: msg = "ip addr added"
Case IP_GENERAL_FAILURE: msg = "ip general failure"
Case IP_PENDING: msg = "ip pending"
Case PING_TIMEOUT: msg = "ping timeout"
Case Else: msg = "unknown msg returned"
End Select
GetStatusCode = CStr(status) & " [ " & msg & " ]"
End Function
Public Function PingRun(sAddress As String, sDataToSend As String) As Long
'If Ping succeeds :
'.RoundTripTime = time in ms for the ping to complete,
'.Data is the data returned (NULL terminated)
'.Address is the Ip address that actually replied
'.DataSize is the size of the string in .Data
'.Status will be 0
'
'If Ping fails .Status will be the error code
Dim hPort As Long
Dim dwAddress As Long
Dim ECHO As ICMP_ECHO_REPLY
'convert the address into a long representation
dwAddress = inet_addr(sAddress)
'if a valid address..
If dwAddress <> INADDR_NONE Then
'open a port
hPort = IcmpCreateFile()
'and if successful,
If hPort Then
'ping it.
Call IcmpSendEcho(hPort, _
dwAddress, _
sDataToSend, _
Len(sDataToSend), _
0, _
ECHO, _
Len(ECHO), _
PING_TIMEOUT)
'return the status as ping succes and close
PingRun = ECHO.status
Call IcmpCloseHandle(hPort)
End If
Else:
'the address format was probably invalid
PingRun = INADDR_NONE
End If
End Function
Public Function Ping(Address As String, FailMessage As String) As Long
Dim pos As Long
Dim success As Long
If SocketsInitialize() Then
'ping the ip passing the address, text
'to send, and the ECHO structure.
success = PingRun(Address, "Echo This")
SocketsCleanup
Else
MsgBox "Windows Sockets for 32 bit Windows " & _
"environments is not successfully responding."
End If
End Function
Public Sub SocketsCleanup()
If WSACleanup() <> 0 Then
MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation
End If
End Sub
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
SocketsInitialize = WSAStartup(WS_VERSION_REQD , WSAD) = IP_SUCCESS
End Function
'
Private Sub Class_Initialize()
mlConnectionNumber = 0&
mbDisconnectOnTerminate = False
End Sub
Private Sub Class_Terminate()
If mbDisconnectOnTerminate And mlConnectionNumber <> 0 Then
Call InternetHangUp(mlConnectio nNumber, 0&)
End If
End Sub
Public Property Get Connected() As Boolean
Connected = IsConnected()
End Property
Public Property Get DisconnectOnTerminate() As Boolean
DisconnectOnTerminate = mbDisconnectOnTerminate
End Property
Public Property Let DisconnectOnTerminate(ByVa l bValue As Boolean)
mbDisconnectOnTerminate = bValue
End Property
Public Function HangUp() As Long
If mlConnectionNumber = 0 Then
HangUp = -1
Else
HangUp = InternetHangUp(mlConnectio nNumber, 0&)
mlConnectionNumber = 0&
RaiseEvent ConnectionClosed
End If
End Function
Public Sub ListDUNs(sDunList() As String)
Dim lngSize As Long
Dim lngEntries As Long
Dim strConName As String
Dim lngIndex As Long
Dim RAS(255) As RAS_ENTRIES
Erase sDunList()
RAS(0).dwSize = 264
lngSize = 256 * RAS(0).dwSize
Call RasEnumEntriesA(vbNullStri ng, vbNullString, RAS(0), lngSize, lngEntries)
lngEntries = lngEntries - 1
If lngEntries >= 0 Then
ReDim sDunList(lngEntries)
For lngIndex = 0 To lngEntries
strConName = StrConv(RAS(lngIndex).szEn tryName(), vbUnicode)
sDunList(lngIndex) = Left$(strConName, InStr(strConName, vbNullChar) - 1)
Next
End If
End Sub
Public Function IsConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95
'
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
'
RetVal = RasEnumConnections(TRasCon (0), lg, lpcon)
If RetVal <> 0 Then
MsgBox "ERROR"
Exit Function
End If
'
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCo n(0).hRasC on, Tstatus)
If Tstatus.RasConnState = &H2000 Then
IsConnected = True
Else
IsConnected = False
End If
End Function
Public Function StartDUN(hWnd As Long, strDUN As String) As Long
Dim lngResult As Long
If IsConnected Then 'mlConnectionNumber <> 0 And fActiveConnection() Then
'
' Already issued a connection
'
StartDUN = -1
Else
lngResult = InternetDial(hWnd, strDUN, INTERNET_AUTODIAL_FORCE_UN ATTENDED, mlConnectionNumber, 0&)
If lngResult = ERROR_SUCCESS Then
RaiseEvent ConnectionMade
Else
mlConnectionNumber = 0
End If
StartDUN = lngResult
End If
End Function
Private Function fActiveConnectionx() As Boolean
Dim lngKey As Long
Dim lngData As Long
Dim lngSizeData As Long
Const sSubKey = "System\CurrentControlSet\ Services\R emoteAcces s"
Const sKeyValue = "Remote Connection"
'
' Check registry for an active connection.
'
fActiveConnectionx = False
If RegOpenKey(HKEY_LOCAL_MACH INE, sSubKey, lngKey) = ERROR_SUCCESS Then
lngData = 0&
lngSizeData = Len(lngData)
If RegQueryValueEx(lngKey, sKeyValue, 0&, 0&, lngData, lngSizeData) = ERROR_SUCCESS Then
fActiveConnectionx = lngData <> 0
End If
Call RegCloseKey(lngKey)
End If
End Function
Public Function StartDUNOK(hWnd As Long, strDUN As String) As Boolean
Dim lngResult As Long
If IsConnected Then 'mlConnectionNumber <> 0 And fActiveConnection() Then
'
' Already issued a connection
'
StartDUNOK = True
Exit Function
Else
lngResult = InternetDial(hWnd, strDUN, INTERNET_AUTODIAL_FORCE_UN ATTENDED, mlConnectionNumber, 0&)
If lngResult = ERROR_SUCCESS Then
StartDUNOK = True
Exit Function
Else
mlConnectionNumber = 0
End If
StartDUNOK = False
End If
End Function
Hope this helps :~)
Example form code:
Option Explicit
Private WithEvents Dun As cDun
Private Sub Command1_Click()
Set Dun = New cDun
Dim UplineGateway$
Dim ok
'' for dial up connections
'ok = DUN.StartDUNOK(Me.hWnd, "My Connection Name")
'If ok Then
' ok = DUN.IsConnected
'End If
'If ok Then
' MsgBox "You are connected"
'Else
' MsgBox "You are not connected"
'End If
' for dial-on-demand ISDN routers or ADSL
' you need to find the IP address of your first external gateway
' to do this use the TRACERT command like:
' www.google.com
' The first IP address is your router
' the next is your first upline gateway unless
' you are in an office which is using an inter-company
' frame relay in which case you need use the first IP
' address not manage by your company.
UplineGateway = "DNS1"
ok = Dun.PingWaitOK(UplineGatew
If ok Then
MsgBox "You are connected"
Else
MsgBox "You are not connected"
End If
End Sub
-------------------cDun.cl
Option Explicit
' please report any bugs or enhancements to:
' nyoung@vipintersoft.com
' Subject line re: cDun.CLS
' please send an email to register as a user and
' to received updates and fixes.
' Sample usage:
'Option Explicit
'Private WithEvents DUN As cDun
'Private Sub Command1_Click()
'
'
'Set DUN = New cDun
'
'Dim UplineGateway$
'Dim ok
'
'' for dial up connections
'ok = DUN.StartDUNOK(Me.hWnd, "My Connection Name")
'If ok Then
' ok = DUN.IsConnected
'End If
'If ok Then
' MsgBox "You are connected"
'Else
' MsgBox "You are not connected"
'End If
'
'' for dial-on-demand ISDN routers or ADSL
'' you need to find the IP address of your first external gateway
'' to do this use the TRACERT command like:
'' www.google.com
'' The first IP address is your router
'' the next is your first upline gateway unless
'' you are in an office which is using an inter-company
'' frame relay in which case you need use the first IP
'' address not manage by your company.
'' Or use your DNS
'UplineGateway = "xxx.xxx.xxx.xxx" or "DNS1"
'
'ok = DUN.PingWaitOK(UplineGatew
'If ok Then
' MsgBox "You are connected"
'Else
' MsgBox "You are not connected"
'End If
'
'
'End Sub
Dim ok
' Private variables
Private mlConnectionNumber As Long
Private mbDisconnectOnTerminate As Boolean
' Used to list the DUN connections
Private Type RAS_ENTRIES
dwSize As Long
szEntryName(256) As Byte
End Type
Private Declare Function RasEnumEntriesA Lib "RasApi32.dll" _
(ByVal reserved As String, ByVal lpszPhonebook As String, _
lprasentryname As Any, lpcb As Long, lpcEntries As Long) As Long
' For the fActiveConnection function
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" _
Alias "RegOpenKeyA" (ByVal hKey As Long, _
ByVal sSubKey As String, hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal sKeyValue As String, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, nSizeData As Long) As Long
' For Dial and Hangup functions
Private Declare Function InternetDial Lib "wininet.dll" _
(ByVal hWnd As Long, ByVal sConnectoid As String, _
ByVal dwFlags As Long, lpdwConnection As Long, _
ByVal dwReserved As Long) As Long
'Returns ERROR_SUCCESS if successfull
' ERROR_INVALID_PARAMETER - one or more parameters are incorrect
' ERROR_NO_CONNECTION - There is a problem with the dial-up connection
' ERROR_USER_DISCONNECTION - The user clicked either the work offline or cancel button on the dialog box
Private Declare Function InternetHangUp Lib "wininet.dll" _
(ByVal dwConnection As Long, ByVal dwReserved As Long) As Long
' Returns ERROR_SUCCESS if successfull or an error value otherwise.
' InternetAutodial flags
Private Const INTERNET_AUTODIAL_FORCE_ON
Private Const INTERNET_AUTODIAL_FORCE_UN
Private Const INTERNET_AUTODIAL_FAILIFSE
' InternetDial Flags - must not conflict with InternetAutodial
' flags as they are valid here also.
Private Const INTERNET_DIAL_FORCE_PROMPT
Private Const INTERNET_DIAL_SHOW_OFFLINE
Private Const INTERNET_DIAL_UNATTENDED = &H8000
' Windows error constants.
Private Const ERROR_SUCCESS As Long = 0&
Private Const ERROR_INVALID_PARAMETER = 87&
' RAS error constants
Private Const RASBASE As Long = 600& 'not sure about this couldn't find raserror.h anywhere on MSDN so
'best-guessed the value based on return code of 631 for cancel button
Private Const ERROR_NO_CONNECTION = (RASBASE + 68&)
Private Const ERROR_USER_DISCONNECTION = (RASBASE + 31&)
' Events for this module
Public Event ConnectionMade()
Public Event ConnectionClosed()
'
Const RAS95_MaxEntryName = 256
Const RAS95_MaxDeviceType = 16
Const RAS95_MaxDeviceName = 32
Private Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntry
szDeviceType(RAS95_MaxDevi
szDeviceName(RAS95_MaxDevi
End Type
'
Private Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDevi
szDeviceName(RAS95_MaxDevi
End Type
Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Private Const IP_SUCCESS As Long = 0
Private Const IP_STATUS_BASE As Long = 11000
Private Const IP_BUF_TOO_SMALL As Long = (11000 + 1)
Private Const IP_DEST_NET_UNREACHABLE As Long = (11000 + 2)
Private Const IP_DEST_HOST_UNREACHABLE As Long = (11000 + 3)
Private Const IP_DEST_PROT_UNREACHABLE As Long = (11000 + 4)
Private Const IP_DEST_PORT_UNREACHABLE As Long = (11000 + 5)
Private Const IP_NO_RESOURCES As Long = (11000 + 6)
Private Const IP_BAD_OPTION As Long = (11000 + 7)
Private Const IP_HW_ERROR As Long = (11000 + 8)
Private Const IP_PACKET_TOO_BIG As Long = (11000 + 9)
Private Const IP_REQ_TIMED_OUT As Long = (11000 + 10)
Private Const IP_BAD_REQ As Long = (11000 + 11)
Private Const IP_BAD_ROUTE As Long = (11000 + 12)
Private Const IP_TTL_EXPIRED_TRANSIT As Long = (11000 + 13)
Private Const IP_TTL_EXPIRED_REASSEM As Long = (11000 + 14)
Private Const IP_PARAM_PROBLEM As Long = (11000 + 15)
Private Const IP_SOURCE_QUENCH As Long = (11000 + 16)
Private Const IP_OPTION_TOO_BIG As Long = (11000 + 17)
Private Const IP_BAD_DESTINATION As Long = (11000 + 18)
Private Const IP_ADDR_DELETED As Long = (11000 + 19)
Private Const IP_SPEC_MTU_CHANGE As Long = (11000 + 20)
Private Const IP_MTU_CHANGE As Long = (11000 + 21)
Private Const IP_UNLOAD As Long = (11000 + 22)
Private Const IP_ADDR_ADDED As Long = (11000 + 23)
Private Const IP_GENERAL_FAILURE As Long = (11000 + 50)
Private Const MAX_IP_STATUS As Long = (11000 + 50)
Private Const IP_PENDING As Long = (11000 + 255)
Private Const PING_TIMEOUT As Long = 500
Private Const WS_VERSION_REQD As Long = &H101
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Const INADDR_NONE As Long = &HFFFFFFFF
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
Private Type ICMP_OPTIONS
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
Private Type ICMP_ECHO_REPLY
Address As Long
status As Long
RoundTripTime As Long
DataSize As Long 'formerly 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 Long
wMaxUDPDG As Long
dwVendorInfo As Long
End Type
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" _
(ByVal IcmpHandle As Long) As Long
Private Declare Function IcmpSendEcho Lib "icmp.dll" _
(ByVal IcmpHandle As Long, _
ByVal DestinationAddress As Long, _
ByVal RequestData As String, _
ByVal RequestSize As Long, _
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 Declare Function gethostname Lib "WSOCK32.DLL" _
(ByVal szHost As String, _
ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
(ByVal szHost As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(xDest As Any, _
xSource As Any, _
ByVal nbytes As Long)
Private Declare Function inet_addr Lib "WSOCK32.DLL" _
(ByVal s As String) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Function PingWaitOK(PingAddress As String, TimeoutSeconds As Single) As Boolean
Dim StartTime As Date
Dim failreason As String
StartTime = Now
Dim Suc As Long
Do
Suc = Ping(PingAddress, failreason)
If Suc = 0 Then
PingWaitOK = True
Exit Function
End If
If DateDiff("S", Now, StartTime) > TimeoutSeconds Then
PingWaitOK = False
Exit Function
End If
Sleep 250
Loop
End Function
Public Function GetStatusCode(status As Long) As String
Dim msg As String
Select Case status
Case IP_SUCCESS: msg = "ip success"
Case INADDR_NONE: msg = "inet_addr: bad IP format"
Case IP_BUF_TOO_SMALL: msg = "ip buf too_small"
Case IP_DEST_NET_UNREACHABLE: msg = "ip dest net unreachable"
Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable"
Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable"
Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable"
Case IP_NO_RESOURCES: msg = "ip no resources"
Case IP_BAD_OPTION: msg = "ip bad option"
Case IP_HW_ERROR: msg = "ip hw_error"
Case IP_PACKET_TOO_BIG: msg = "ip packet too_big"
Case IP_REQ_TIMED_OUT: msg = "ip req timed out"
Case IP_BAD_REQ: msg = "ip bad req"
Case IP_BAD_ROUTE: msg = "ip bad route"
Case IP_TTL_EXPIRED_TRANSIT: msg = "ip ttl expired transit"
Case IP_TTL_EXPIRED_REASSEM: msg = "ip ttl expired reassem"
Case IP_PARAM_PROBLEM: msg = "ip param_problem"
Case IP_SOURCE_QUENCH: msg = "ip source quench"
Case IP_OPTION_TOO_BIG: msg = "ip option too_big"
Case IP_BAD_DESTINATION: msg = "ip bad destination"
Case IP_ADDR_DELETED: msg = "ip addr deleted"
Case IP_SPEC_MTU_CHANGE: msg = "ip spec mtu change"
Case IP_MTU_CHANGE: msg = "ip mtu_change"
Case IP_UNLOAD: msg = "ip unload"
Case IP_ADDR_ADDED: msg = "ip addr added"
Case IP_GENERAL_FAILURE: msg = "ip general failure"
Case IP_PENDING: msg = "ip pending"
Case PING_TIMEOUT: msg = "ping timeout"
Case Else: msg = "unknown msg returned"
End Select
GetStatusCode = CStr(status) & " [ " & msg & " ]"
End Function
Public Function PingRun(sAddress As String, sDataToSend As String) As Long
'If Ping succeeds :
'.RoundTripTime = time in ms for the ping to complete,
'.Data is the data returned (NULL terminated)
'.Address is the Ip address that actually replied
'.DataSize is the size of the string in .Data
'.Status will be 0
'
'If Ping fails .Status will be the error code
Dim hPort As Long
Dim dwAddress As Long
Dim ECHO As ICMP_ECHO_REPLY
'convert the address into a long representation
dwAddress = inet_addr(sAddress)
'if a valid address..
If dwAddress <> INADDR_NONE Then
'open a port
hPort = IcmpCreateFile()
'and if successful,
If hPort Then
'ping it.
Call IcmpSendEcho(hPort, _
dwAddress, _
sDataToSend, _
Len(sDataToSend), _
0, _
ECHO, _
Len(ECHO), _
PING_TIMEOUT)
'return the status as ping succes and close
PingRun = ECHO.status
Call IcmpCloseHandle(hPort)
End If
Else:
'the address format was probably invalid
PingRun = INADDR_NONE
End If
End Function
Public Function Ping(Address As String, FailMessage As String) As Long
Dim pos As Long
Dim success As Long
If SocketsInitialize() Then
'ping the ip passing the address, text
'to send, and the ECHO structure.
success = PingRun(Address, "Echo This")
SocketsCleanup
Else
MsgBox "Windows Sockets for 32 bit Windows " & _
"environments is not successfully responding."
End If
End Function
Public Sub SocketsCleanup()
If WSACleanup() <> 0 Then
MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation
End If
End Sub
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
SocketsInitialize = WSAStartup(WS_VERSION_REQD
End Function
'
Private Sub Class_Initialize()
mlConnectionNumber = 0&
mbDisconnectOnTerminate = False
End Sub
Private Sub Class_Terminate()
If mbDisconnectOnTerminate And mlConnectionNumber <> 0 Then
Call InternetHangUp(mlConnectio
End If
End Sub
Public Property Get Connected() As Boolean
Connected = IsConnected()
End Property
Public Property Get DisconnectOnTerminate() As Boolean
DisconnectOnTerminate = mbDisconnectOnTerminate
End Property
Public Property Let DisconnectOnTerminate(ByVa
mbDisconnectOnTerminate = bValue
End Property
Public Function HangUp() As Long
If mlConnectionNumber = 0 Then
HangUp = -1
Else
HangUp = InternetHangUp(mlConnectio
mlConnectionNumber = 0&
RaiseEvent ConnectionClosed
End If
End Function
Public Sub ListDUNs(sDunList() As String)
Dim lngSize As Long
Dim lngEntries As Long
Dim strConName As String
Dim lngIndex As Long
Dim RAS(255) As RAS_ENTRIES
Erase sDunList()
RAS(0).dwSize = 264
lngSize = 256 * RAS(0).dwSize
Call RasEnumEntriesA(vbNullStri
lngEntries = lngEntries - 1
If lngEntries >= 0 Then
ReDim sDunList(lngEntries)
For lngIndex = 0 To lngEntries
strConName = StrConv(RAS(lngIndex).szEn
sDunList(lngIndex) = Left$(strConName, InStr(strConName, vbNullChar) - 1)
Next
End If
End Sub
Public Function IsConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95
'
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
'
RetVal = RasEnumConnections(TRasCon
If RetVal <> 0 Then
MsgBox "ERROR"
Exit Function
End If
'
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCo
If Tstatus.RasConnState = &H2000 Then
IsConnected = True
Else
IsConnected = False
End If
End Function
Public Function StartDUN(hWnd As Long, strDUN As String) As Long
Dim lngResult As Long
If IsConnected Then 'mlConnectionNumber <> 0 And fActiveConnection() Then
'
' Already issued a connection
'
StartDUN = -1
Else
lngResult = InternetDial(hWnd, strDUN, INTERNET_AUTODIAL_FORCE_UN
If lngResult = ERROR_SUCCESS Then
RaiseEvent ConnectionMade
Else
mlConnectionNumber = 0
End If
StartDUN = lngResult
End If
End Function
Private Function fActiveConnectionx() As Boolean
Dim lngKey As Long
Dim lngData As Long
Dim lngSizeData As Long
Const sSubKey = "System\CurrentControlSet\
Const sKeyValue = "Remote Connection"
'
' Check registry for an active connection.
'
fActiveConnectionx = False
If RegOpenKey(HKEY_LOCAL_MACH
lngData = 0&
lngSizeData = Len(lngData)
If RegQueryValueEx(lngKey, sKeyValue, 0&, 0&, lngData, lngSizeData) = ERROR_SUCCESS Then
fActiveConnectionx = lngData <> 0
End If
Call RegCloseKey(lngKey)
End If
End Function
Public Function StartDUNOK(hWnd As Long, strDUN As String) As Boolean
Dim lngResult As Long
If IsConnected Then 'mlConnectionNumber <> 0 And fActiveConnection() Then
'
' Already issued a connection
'
StartDUNOK = True
Exit Function
Else
lngResult = InternetDial(hWnd, strDUN, INTERNET_AUTODIAL_FORCE_UN
If lngResult = ERROR_SUCCESS Then
StartDUNOK = True
Exit Function
Else
mlConnectionNumber = 0
End If
StartDUNOK = False
End If
End Function
Sorry for typo forgot the TRACERT
' to do this use the TRACERT command like:
' TRACERT www.google.com
' to do this use the TRACERT command like:
' TRACERT www.google.com
Put this in a module, if u put in form itself, change the public to private
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 Const INTERNET_CONNECTION_PROXY = &H4
Public Const INTERNET_CONNECTION_MODEM_ BUSY = &H8
Public Function Online() As Boolean
Online = InternetGetConnectedState( 0&, 0&)
End Function
Public Function ViaLAN() As Boolean
Dim sFlags As Long
Call InternetGetConnectedState( sFlags, 0&)
ViaLAN = sFlags And INTERNET_CONNECTION_LAN
End Function
Public Function ViaModem() As Boolean
Dim sFlags As Long
Call InternetGetConnectedState( sFlags, 0&)
ViaModem = sFlags And INTERNET_CONNECTION_MODEM
End Function
Public Function ViaProxy() As Boolean
Dim sFlags As Long
Call InternetGetConnectedState( sFlags, 0&)
ViaProxy = sFlags And INTERNET_CONNECTION_PROXY
End Function
Put this in a form
==================
Private Sub Command1_Click()
Text1 = ViaLAN()
Text2 = ViaModem()
Text3 = Online()
Text4 = ViaProxy()
End Sub
This works fine for me man. even i tried with dialup network.
Bhaski
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 Const INTERNET_CONNECTION_PROXY = &H4
Public Const INTERNET_CONNECTION_MODEM_
Public Function Online() As Boolean
Online = InternetGetConnectedState(
End Function
Public Function ViaLAN() As Boolean
Dim sFlags As Long
Call InternetGetConnectedState(
ViaLAN = sFlags And INTERNET_CONNECTION_LAN
End Function
Public Function ViaModem() As Boolean
Dim sFlags As Long
Call InternetGetConnectedState(
ViaModem = sFlags And INTERNET_CONNECTION_MODEM
End Function
Public Function ViaProxy() As Boolean
Dim sFlags As Long
Call InternetGetConnectedState(
ViaProxy = sFlags And INTERNET_CONNECTION_PROXY
End Function
Put this in a form
==================
Private Sub Command1_Click()
Text1 = ViaLAN()
Text2 = ViaModem()
Text3 = Online()
Text4 = ViaProxy()
End Sub
This works fine for me man. even i tried with dialup network.
Bhaski
Hi,Men. This works fine
Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Private Const RAS95_MaxEntryName = 256
Private Const RAS95_MaxDeviceType = 16
Private Const RAS95_MaxDeviceName = 32
Private Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntry Name) As Byte
szDeviceType(RAS95_MaxDevi ceType) As Byte
szDeviceName(RAS95_MaxDevi ceName) As Byte
End Type
Private Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDevi ceType) As Byte
szDeviceName(RAS95_MaxDevi ceName) As Byte
End Type
Public Function IsConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
RetVal = RasEnumConnections(TRasCon (0), lg, lpcon)
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCo n(0).hRasC on, Tstatus)
If Tstatus.RasConnState = &H2000 Then
IsConnected = True
Else
IsConnected = False
End If
End Function
Private Sub Form_Load()
'åñëè åñòü ñîåäèíåíèå, òî IsConnected() = True, èíà÷å False
MsgBox IsConnected()
End Sub
Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Private Const RAS95_MaxEntryName = 256
Private Const RAS95_MaxDeviceType = 16
Private Const RAS95_MaxDeviceName = 32
Private Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntry
szDeviceType(RAS95_MaxDevi
szDeviceName(RAS95_MaxDevi
End Type
Private Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDevi
szDeviceName(RAS95_MaxDevi
End Type
Public Function IsConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
RetVal = RasEnumConnections(TRasCon
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCo
If Tstatus.RasConnState = &H2000 Then
IsConnected = True
Else
IsConnected = False
End If
End Function
Private Sub Form_Load()
'åñëè åñòü ñîåäèíåíèå, òî IsConnected() = True, èíà÷å False
MsgBox IsConnected()
End Sub
PLEASE DO NOT ACCEPT THIS COMMENT AS AN ANSWER!
No comment has been added lately, so it's time to clean up this TA.
I will leave a recommendation in Community Support that this question is:
----- PAQ/no refund -----
reason: the question is too ambiguous to tell what it means and there are so many solutions here that do different things. Could the question mean:
1) How can I tell if my internet connection is working through code
2) How can I tell if my dialup is currently being used to connect to the INet vs a BBS
3) How can I tell when a page has finished loading?
4) How can I tell if my user has internet capabilities?
5) How can I retrieve the errors from trying to cnnect to the internet?
I just can't tell what the questioner was asking and as they abandoned the question and hard work was put forth by all it should have a price.
Just my $.02. Leave your recommendations here.
Please leave any comments here within the
next seven days.
No comment has been added lately, so it's time to clean up this TA.
I will leave a recommendation in Community Support that this question is:
----- PAQ/no refund -----
reason: the question is too ambiguous to tell what it means and there are so many solutions here that do different things. Could the question mean:
1) How can I tell if my internet connection is working through code
2) How can I tell if my dialup is currently being used to connect to the INet vs a BBS
3) How can I tell when a page has finished loading?
4) How can I tell if my user has internet capabilities?
5) How can I retrieve the errors from trying to cnnect to the internet?
I just can't tell what the questioner was asking and as they abandoned the question and hard work was put forth by all it should have a price.
Just my $.02. Leave your recommendations here.
Please leave any comments here within the
next seven days.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
I use the open method in order to fetch a specific page and then i look at the status value. If it is 200 then the page can be reached. you can use this function to test for internet access.
(it does fire up my automatic connection when i call it)
here is an example function :
Private Sub Command1_Click()
Dim xmlConTest As New MSXML2.XMLHTTP
xmlConTest.open "GET", "http://www.microsoft.com/default.asp", False
xmlConTest.send
If xmlConTest.Status = 200 Then
MsgBox "You can reach the internet"
Else
MsgBox "There are some errors but i am to lazy to analyze them...."
End If
End Sub