conns.cls

来自「本书源码主要针对目前流行的FTP、HTTP、E-mail、Telnet、ICMP」· CLS 代码 · 共 241 行

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

'连接的个数
Private intCCount As Integer
'********************************************************************

Public Property Get Count() As Integer

   '获得连接的个数
   Dim lngRetCode

   lngRetCode = fcnRASEnumConnections()
   If lngRetCode Then
      Err.Raise vbObjectError + lngRetCode, "Connections.Count Failure", "RAS Failure"
   Else
      Count = intCCount
   End If

End Property

Private Function fcnRASEnumConnections() As Long
 
   Dim lngRetCode As Long
   Dim lpcb As Long
   Dim lpcConnections As Long
   Dim intArraySize As Integer
   Dim intLooper As Integer
   
   '定义256个连接，如果不够，可以再增加
   intArraySize = 255
   If lngWindowVersion = 2 Then
      'NT系统
      ReDim lprasconn(intArraySize) As RASCONN
      lprasconn(0).dwSize = 32
      lpcb = 256 * lprasconn(0).dwSize
      lngRetCode = RasEnumConnections(lprasconn(0), lpcb, lpcConnections)
   Else
      '95/98系统
      '定义结构体数组
      ReDim lprasconn95(intArraySize) As RASCONN95
      lprasconn95(0).dwSize = 412
      lpcb = 256 * lprasconn95(0).dwSize
      '获得各个活动连接
      lngRetCode = RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)
   End If
   Select Case lngRetCode
      Case SUCCESS
         '如果成功
         If lpcConnections > 0 Then
            ReDim arrConnection(lpcConnections - 1) As Connection
            If lngWindowVersion = 2 Then
                'NT系统
                For intLooper = 0 To UBound(arrConnection())
                    Set arrConnection(intLooper) = New Connection
                    '允许修改电话簿
                    boolAllowUpdate = True
                    arrConnection(intLooper).hRasConn = lprasconn(intLooper).hRasConn
                    arrConnection(intLooper).EntryName = fcnTrimNulls(StrConv(lprasconn(intLooper).szEntryName, vbUnicode))
                    arrConnection(intLooper).Index = intLooper
                    boolAllowUpdate = False
                Next intLooper
            Else
                    '95/98系统
                    For intLooper = 0 To UBound(arrConnection())
                    Set arrConnection(intLooper) = New Connection
                    '允许修改电话簿
                    boolAllowUpdate = True
                    arrConnection(intLooper).hRasConn = lprasconn95(intLooper).hRasConn
                    arrConnection(intLooper).EntryName = fcnTrimNulls(StrConv(lprasconn95(intLooper).szEntryName, vbUnicode))
                    arrConnection(intLooper).Index = intLooper
                    boolAllowUpdate = False
                Next intLooper
            End If
         End If
         '设置连接的数量
         intCCount = CInt(lpcConnections)
         fcnRASEnumConnections = 0
      Case ERROR_BUFFER_TOO_SMALL
         '设置更大的缓冲区
         If lngWindowVersion = 2 Then
            'running NT
            intArraySize = lpcb / lprasconn(0).dwSize
         Else
            'running 95
            intArraySize = lpcb / lprasconn95(0).dwSize
         End If
      Case Else
         lngRASErrorNumber = lngRetCode
         strRASDescription = lpRASError.fcnRASErrorString()
         fcnRASEnumConnections = lngRetCode
   End Select
  
End Function

Public Function AddConnection(strNewEntryName As String, strNewPhoneNumber As String, strNewCallbackNumber As String, strNewUsername As String, strNewPassword As String, strNewDomain As String, boolAsync As Boolean) As Connection
'该函数的功能是建立拨号连接
'该函数返回一Connection对象
   Dim lngRetCode As Long
   Dim hRasConn As Long
   Dim lngRetlstrcpy As Long
   Dim intLooper As Integer
   Dim lngRetHangUp As Long
   
      '再vb中实现异步拨号，不过如果要直接实现异步拨号，要用到回调函数，而再vb中要实现回调函数比较困难
      '因此在调用RASDIAL函数的时候，可以传递一个模态对话框的句柄，然后通过RASGetConnectionStatus函数来
      '获取各种状态
      If lngWindowVersion = 2 Then
         'NT系统
         Dim lprasdialparams As RASDIALPARAMS
         lprasdialparams.dwSize = 736
         '最好使用函数lstrcpy，因为如果使用StrConv，可能失败
         lngRetlstrcpy = lstrcpy(lprasdialparams.szEntryName(0), strNewEntryName)
         lngRetlstrcpy = lstrcpy(lprasdialparams.szPhoneNumber(0), strNewPhoneNumber)
         lngRetlstrcpy = lstrcpy(lprasdialparams.szCallbackNumber(0), strNewCallbackNumber)
         lngRetlstrcpy = lstrcpy(lprasdialparams.szUserName(0), strNewUsername)
         lngRetlstrcpy = lstrcpy(lprasdialparams.szPassword(0), strNewPassword)
         lngRetlstrcpy = lstrcpy(lprasdialparams.szDomain(0), strNewDomain)
         '调用RASDial
         If boolAsync Then
            '异步调用同时忽略RASDIALEXTENSIONS
            '在参数传递是，其中一个是窗体的句柄
            Load frmAsyncDial
            lngRetCode = RasDial(ByVal APINULL, vbNullString, lprasdialparams, &HFFFFFFFF, frmAsyncDial.hWND, hRasConn)
         Else
            '同步拨号
            Screen.MousePointer = vbHourglass
            lngRetCode = RasDial(ByVal APINULL, vbNullString, lprasdialparams, APINULL, ByVal APINULL, hRasConn)
            Screen.MousePointer = vbDefault
         End If
         '判断是否成功
         If lngRetCode Then
            lngRASErrorNumber = lngRetCode
            strRASDescription = lpRASError.fcnRASErrorString()
            lngRetHangUp = RasHangUp(hRasConn)
            Err.Raise vbObjectError + lngRetCode, "Connections AddConnection Failed", "RAS Failure"
         Else
            '可以返回连接成功后的句柄
         End If
      Else
         '95/98系统 (lngWindowVersion =1)
         Dim lprasdialparams95 As RASDIALPARAMS95
         lprasdialparams95.dwSize = 1052
         lngRetlstrcpy = lstrcpy(lprasdialparams95.szEntryName(0), strNewEntryName)
         lngRetlstrcpy = lstrcpy(lprasdialparams95.szPhoneNumber(0), strNewPhoneNumber)
         lngRetlstrcpy = lstrcpy(lprasdialparams95.szCallbackNumber(0), strNewCallbackNumber)
         lngRetlstrcpy = lstrcpy(lprasdialparams95.szUserName(0), strNewUsername)
         lngRetlstrcpy = lstrcpy(lprasdialparams95.szPassword(0), strNewPassword)
         lngRetlstrcpy = lstrcpy(lprasdialparams95.szDomain(0), strNewDomain)
         '调用RASDial
         If boolAsync Then
            '异步调用
            '弹出对话框frmAsyncDial
            Load frmAsyncDial
            DoEvents
            lngRetCode = RasDial(ByVal APINULL, vbNullString, lprasdialparams95, &HFFFFFFFF, frmAsyncDial.hWND, hRasConn)
         Else
            '同步调用
            Screen.MousePointer = vbHourglass
            lngRetCode = RasDial(ByVal APINULL, vbNullString, lprasdialparams95, APINULL, ByVal APINULL, hRasConn)
            Screen.MousePointer = vbDefault
         End If
         '错误处理
         If lngRetCode Then
            lngRASErrorNumber = lngRetCode
            strRASDescription = lpRASError.fcnRASErrorString()
            lngRetHangUp = RasHangUp(hRasConn)
            Err.Raise vbObjectError + lngRetCode, "Connections AddConnection Failed", "RAS Failure"
         Else
            '调用成功
            DoEvents
         End If
      End If
      
      '可以在需要的时候返回连接句柄
      '或者可以遍历所有的连接，这样可以更准确地返回各个句柄
      If boolAsync Then
         frmAsyncDial.Tag = Hex$(hRasConn)
         frmAsyncDial.Show 1
      Else
         '如果是同步则不用处理
      End If
     '刷新活动连接
      lngRetCode = fcnRASEnumConnections()
      If lngRetCode Then Err.Raise vbObjectError + lngRetCode, "Connections AddConnection Failed", "RAS Failure"
      '循环获得每一个连接，如果其中一个连接等于最新建立地连接，则可以返回该连接
      '注意返回地是对象
      For intLooper = 0 To intCCount - 1
         If hRasConn = arrConnection(intLooper).hRasConn Then
            Set AddConnection = arrConnection(intLooper)
         Else
            Set AddConnection = Nothing
         End If
      Next intLooper
      
End Function

Public Sub RemoveConnection(lngIndexToRem As Long)
'删除一个连接
   Dim lngRetCode As Long
   Dim hRasConnToRem As Long
        
   '在删除以前，首先要获得句柄
   hRasConnToRem = arrConnection(lngIndexToRem).hRasConn
   
   '然后挂断该连接
   lngRetCode = RasHangUp(hRasConnToRem)
   If lngRetCode Then
         lngRASErrorNumber = lngRetCode
         strRASDescription = lpRASError.fcnRASErrorString()
         Err.Raise vbObjectError + lngRetCode, "Connections RemoveConnection Failed", "RAS Failure"
      Else
         '重新刷新活动连接
         lngRetCode = fcnRASEnumConnections()
         If lngRetCode Then Err.Raise vbObjectError + lngRetCode, "Connections RemoveConnection Failed", "RAS Failure"
   End If

End Sub

Private Sub Class_Initialize()

   Dim lngSuccess As Long
   
   '在初始化时获得所有活动连接
   lngSuccess = fcnRASEnumConnections()

End Sub