cinetstatus.cls

控制拨号连接的类,提供拨号,挂段,脱机工作等方法,检测连接状态

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CInetStatus"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'**************************************************************************
'
'                                说     明
'    这个类提供了检测和控制拨号连接的途径,它的属性和方法很简单,就不再多说了,
'你一看就明白,要注意的是,读取它的属性之前,为了保证数据有效性,应先使用
'Refresh方法.
'    我以后会继续改进这个类,需要更新的版本,请关注我们的网站.
'
'**************************************************************************
'
'VB爱好者乐园(http://www.vbgood.com/)
'2000年11月11日
'作者:方舟
'Email:[e-mail]
'
'**************************************************************************
'
'
'
'***************************************************************************
'WinInet API 声明
'***************************************************************************
'InternetGetConnectedState常数
Private Const INTERNET_CONNECTION_MODEM = &H1
Private Const INTERNET_CONNECTION_LAN = &H2
Private Const INTERNET_CONNECTION_PROXY = &H4
Private Const INTERNET_RAS_INSTALLED = &H10
Private Const INTERNET_CONNECTION_OFFLINE = &H20
Private Const INTERNET_CONNECTION_CONFIGURED = &H40
'InternetAutodial常数
Private Const INTERNET_AUTODIAL_FORCE_ONLINE = 1&
Private Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2&
Private Const INTERNET_AUTODIAL_FAILIFSECURITYCHECK = 4&

Private Const INTERNET_DIAL_FORCE_PROMPT = &H2000
Private Const INTERNET_DIAL_SHOW_OFFLINE = &H4000
Private Const INTERNET_DIAL_UNATTENDED = &H8000
'
Private Const INTERNET_OPTION_CONNECTED_STATE = 50
Private Const INTERNET_STATE_DISCONNECTED_BY_USER = &H10
Private Const ISO_FORCE_DISCONNECTED = &H1
Private Const INTERNET_STATE_CONNECTED = &H1
'
Private Type INTERNET_CONNECTED_INFO
    dwConnectedState    As Long
    dwFlags             As Long
End Type
'
'***************************************************************************
'WinInet API 声明
'***************************************************************************
'
Private Declare Function InternetSetOption Lib "wininet.dll" Alias "InternetSetOptionA" (ByVal hInternet As Long, ByVal dwOption As Long, lpBuffer As Any, ByVal dwBufferLength As Long) As Long

Private Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal hwndParent As Long) As Long
Private Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Long
Private Declare Function InternetDial Lib "wininet.dll" Alias "InternetDialA" (ByVal hwndParent As Long, ByVal lpszConnectoid As String, ByVal dwFlags As Long, lpdwConnection As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetGoOnline Lib "wininet.dll" Alias "InternetGoOnlineA" (ByVal lpszURL As String, ByVal hwndParent As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetHangUp Lib "wininet.dll" (ByVal dwConnection As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (lpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" Alias "InternetGetConnectedStateExA" (lpdwFlags As Long, lpszConnectionName As Long, dwNameLen As Long, ByVal dwReserved As Long) As Long
'***************************************************************************
'Win32API 声明
'***************************************************************************
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
'
Private Const ERROR_SUCCESS = 0&
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Const LANG_USER_DEFAULT = &H400&
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
'
'********************************************************************************
'自定义数据类型
'********************************************************************************
Public Enum AutoDialsFlags
    ADF_FORCE_ONLINE = INTERNET_AUTODIAL_FORCE_ONLINE
    ADF_FORCE_UNATTENDED = INTERNET_AUTODIAL_FORCE_UNATTENDED
End Enum

Public Enum DialsFlags
    DF_FORCE_ONLINE = INTERNET_AUTODIAL_FORCE_ONLINE
    DF_FORCE_UNATTENDED = INTERNET_AUTODIAL_FORCE_UNATTENDED
    DF_DIAL_FORCE_PROMPT = INTERNET_DIAL_FORCE_PROMPT
    DF_DIAL_UNATTENDED = INTERNET_DIAL_UNATTENDED
End Enum
'********************************************************************************
'用于保存类属性的内部变量
'********************************************************************************
Private mvarUseModem                As Boolean
Private mvarUseLAN                  As Boolean
Private mvarUseProxy                As Boolean
Private mvarIsRasInstalled          As Boolean
Private mvarIsOffline               As Boolean
Private mvarIsConnectionConfigured  As Boolean
Private mvarConnectionName          As String
Private mvarIsConnected             As Boolean
'
Private m_lConnectionID As Long

Public Function SetGlobalOnline() As Boolean
'********************************************************************************
'作用:转为全局联机模式
'********************************************************************************
Dim ConInfo As INTERNET_CONNECTED_INFO, lRetValue As Long

On Error GoTo SetGlobalOnline_Err_Handler

ConInfo.dwConnectedState = INTERNET_STATE_CONNECTED

lRetValue = InternetSetOption(0&, INTERNET_OPTION_CONNECTED_STATE, ConInfo, Len(ConInfo))

    If lRetValue <> 0 Then
        SetGlobalOnline = True
    Else
        SetGlobalOnline = False
    End If
    Exit Function
SetGlobalOnline_Err_Handler:
    Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.SetGlobalOnline", Err.Description
End Function

Public Function SetGlobalOffline() As Boolean
'********************************************************************************
'作用:转为全局脱机模式
'********************************************************************************
    Dim ConInfo As INTERNET_CONNECTED_INFO, lRetValue As Long

On Error GoTo SetGlobalOffline_Err_Handler

    ConInfo.dwConnectedState = INTERNET_STATE_DISCONNECTED_BY_USER
    ConInfo.dwFlags = ISO_FORCE_DISCONNECTED

    lRetValue = InternetSetOption(0&, INTERNET_OPTION_CONNECTED_STATE, ConInfo, Len(ConInfo))

    If lRetValue <> 0 Then
        SetGlobalOffline = True
    Else
        SetGlobalOffline = False
    End If
    Exit Function
SetGlobalOffline_Err_Handler:
    Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.SetGlobalOffline", Err.Description
End Function


Public Function HangUp()
'********************************************************************************
'断开与Internet的连接
'********************************************************************************
    Dim lRetValue As Long

On Error GoTo HangUp_Err_Handler

    lRetValue = InternetHangUp(m_lConnectionID, 0&)
    HangUp = (lRetValue = ERROR_SUCCESS)


HangUp_Err_Handler:
    Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.HangUp", Err.Description

End Function

Public Function Dial(hwndParentWindow As Long, strConnectionName As String, lOption As DialsFlags, Optional bShowOfflineButton As Boolean = False) As Boolean
'********************************************************************************
'连接到Internet
'********************************************************************************
    Dim lFlags As Long, lRetValue As Long

On Error GoTo Dial_Err_Handler
    '
    If bShowOfflineButton Then
        lFlags = lOption Or INTERNET_DIAL_SHOW_OFFLINE
    Else
        lFlags = lOption
    End If
    '
    lRetValue = InternetDial(hwndParentWindow, strConnectionName, lFlags, m_lConnectionID, 0&)
    Dial = IIf(lRetValue <> 0, True, False)
    Exit Function

Dial_Err_Handler:
    Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.Dial", Err.Description

End Function


Public Function AutodialHangup() As Boolean
'********************************************************************************
'断开默认拨号连接,成功返回true,失败返回False
'********************************************************************************
On Error GoTo AutodialHangup_Err_Handler
    Dim lRetValue As Long
    lRetValue = InternetAutodialHangup(0)
    AutodialHangup = IIf(lRetValue <> 0, True, False)
    Exit Function

AutodialHangup_Err_Handler:
    Err.Raise vbObjectError + 1000 + Err.Number, "CInetStatus.AutodialHangup", Err.Description

End Function

Public Function Autodial(hwndParentWindow As Long, lOption As AutoDialsFlags, Optional bFailIfSecurityCheck As Boolean = True) As Boolean
'********************************************************************************
'建立默认拨号连接,成功返回true,失败返回False
'********************************************************************************
    Dim lFlags As Long, lRetValue As Long

On Error GoTo Autodial_Err_Handler
    '
    If bFailIfSecurityCheck Then
        lFlags = lOption Or INTERNET_AUTODIAL_FAILIFSECURITYCHECK
    Else
        lFlags = lOption
    End If
    
    lRetValue = InternetAutodial(lFlags, hwndParentWindow)
    
    Autodial = IIf(lRetValue <> 0, True, False)
    
    Exit Function

Autodial_Err_Handler:
    Err.Raise vbObjectError + 1000 + Err.Number, "CInetStatus.Autodial", Err.Description

End Function


Public Sub Refresh()

    Dim strConnectionName   As String
    Dim lNameLen            As Long
    Dim lRetVal             As Long
    Dim lConnectionFlags    As Long
    Dim lPtr                As Long
    Dim lNameLenPtr         As Long

On Error GoTo Refresh_Err_Handler

    strConnectionName = Space(256)
    lNameLen = 256
    lPtr = StrPtr(strConnectionName)
    lNameLenPtr = VarPtr(lNameLen)

    lRetVal = InternetGetConnectedStateEx(lConnectionFlags, ByVal lPtr, ByVal lNameLen, 0&)

    mvarIsConnected = IIf(lRetVal <> 0, True, False)
    mvarUseModem = lConnectionFlags And INTERNET_CONNECTION_MODEM
    mvarUseLAN = lConnectionFlags And INTERNET_CONNECTION_LAN
    mvarUseProxy = lConnectionFlags And INTERNET_CONNECTION_PROXY
    mvarIsRasInstalled = lConnectionFlags And INTERNET_RAS_INSTALLED
    mvarIsOffline = lConnectionFlags And INTERNET_CONNECTION_OFFLINE
    mvarIsConnectionConfigured = lConnectionFlags And INTERNET_CONNECTION_CONFIGURED
    mvarConnectionName = StringFromPointer(lPtr)

    Exit Sub

Refresh_Err_Handler:
    Err.Raise vbObjectError + Err.Number, "CInetStatus.Refresh", Err.Description
End Sub

Public Property Get IsConnected() As Boolean
    IsConnected = mvarIsConnected
End Property

Public Property Get ConnectionName() As String
    ConnectionName = mvarConnectionName
End Property

Public Property Get IsConnectionConfigured() As Boolean
    IsConnectionConfigured = mvarIsConnectionConfigured
End Property

Public Property Get IsOffline() As Boolean
    IsOffline = mvarIsOffline
End Property

Public Property Get IsRasInstalled() As Boolean
    IsRasInstalled = mvarIsRasInstalled
End Property

Public Property Get UseProxy() As Boolean
    UseProxy = mvarUseProxy
End Property

Public Property Get UseLAN() As Boolean
    UseLAN = mvarUseLAN
End Property

Public Property Get UseModem() As Boolean
    UseModem = mvarUseModem
End Property

'***************************************************************************
'其他相关函数
'***************************************************************************

Private Function StringFromPointer(ByVal lPointer As Long) As String
'***************************************************************************
'根据指针取得字符串
'***************************************************************************
   Dim strTemp As String
   Dim lRetVal As Long
   
   strTemp = String$(lstrlen(ByVal lPointer), 0)
   lRetVal = lstrcpy(ByVal strTemp, ByVal lPointer)
   If lRetVal Then StringFromPointer = strTemp
   
End Function