clsrasconnect.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 = "clsRasConnect"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private msEnterName As String
Private lpOSInfo As OSVERSIONINFO
Private sngOSVersion As String
Private boolAsync As Boolean

Public Property Get Async() As Boolean

   Async = boolAsync

End Property

Public Property Let Async(ByVal vbAsync As Boolean)

   boolAsync = vbAsync

End Property

'进行电话拨号
Public Function lAddConnect(ByVal vsDial As String) As Long
On Error GoTo err
    Dim sDial As String
    
    If vsDial = "" Then
        sDial = "2536336"
    Else
        sDial = CStr(vsDial) + " 2536336"
    End If

    GetOSInfo                               '''获取操作系统的版本号
    fcnRASEnumEntries                       '''获取连接的名字
''    fcnRASEnumConnections
'    msEnterName = "我的连接"
    lAddConnect = AddConnection(sDial)
        
    Exit Function
err:
    lAddConnect = 0
End Function

'挂断电话
Public Function bRemoveConnect(ByVal lConn As Long) As Boolean
On Error GoTo err
    
    bRemoveConnect = False
    GetOSInfo                               '''获取操作系统的版本号
    
    RemoveConnection lConn
    
    bRemoveConnect = True
    Exit Function
err:
    
End Function

Private Sub RemoveConnection(lngIndexToRem As Long)
On Error GoTo err

   Dim lngRetCode As Long
   Dim hRasConnToRem As Long
        
   'get the hRasConn for the given index
   hRasConnToRem = lngIndexToRem
   
   'Call RASHangUp
   lngRetCode = RasHangUp(hRasConnToRem)
   hRasConnToRem = 0
   Exit Sub
err:
    MsgBox "您还没有挂断电话，请确认！", vbOKOnly + vbInformation, "提示信息"
End Sub

'获取操作系统的版本号
Private Sub GetOSInfo()
    lpOSInfo.dwOSVersionInfoSize = 148
    
    If (GetVersionEx(lpOSInfo)) Then
       'set the global version variable for use in all other RAS functions. This is decl in the BAS file.
       lngWindowVersion = lpOSInfo.dwPlatformId
       'Have to combine the two DWORDS into a Single (I will bet that there is a more efficient method, but...)
       sngOSVersion = CSng(lpOSInfo.dwMajorVersion) + CSng(Val("." & Str$(lpOSInfo.dwMinorVersion)))
    Else
       MsgBox "不能获取操作系统的版本号，请稍后再试！", vbOKOnly + vbInformation, "提示信息"
    End If
End Sub

Public Function AddConnection(vsDial As String) As Long
On Error GoTo err

   'Kind of funky Add, but that is the way RAS works.
   'Since there is no way of guaranteeing the object return, I return the handle to the Connection
   Dim lngRetCode As Long
   Dim hRasConn As Long
   Dim lngRetlstrcpy As Long
   Dim intLooper As Integer
   Dim lngRetHangUp As Long
   
   
      'Doing RASDIAL call Async in a VB sort of way. Since we can not define a callback, we call
      'The API and pass in the handle of a modal form that we have in the server. We then poll the
      'connection with RASGetConnectionStatus until we see that we are connected
      If lngWindowVersion = 2 Then
         'We are running NT
         Dim lprasdialparams  As RASDIALPARAMS
         lprasdialparams.dwSize = 736
         'Using lstrcpy because StrConv fails. I let VB convert the string and fill the array
         'I should theoretically be error checking here, but chances of failure are slim and
         'I should catch it because RASDIAL will fail
         
         lngRetlstrcpy = lstrcpy(lprasdialparams.szEntryName(0), msEnterName)
         lngRetlstrcpy = lstrcpy(lprasdialparams.szPhoneNumber(0), vsDial)
         lngRetlstrcpy = lstrcpy(lprasdialparams.szCallbackNumber(0), "")
         lngRetlstrcpy = lstrcpy(lprasdialparams.szUserName(0), "aa")
         lngRetlstrcpy = lstrcpy(lprasdialparams.szPassword(0), "aa")
         lngRetlstrcpy = lstrcpy(lprasdialparams.szDomain(0), "")
         
         'Call RASDial
         If boolAsync Then
            'Asyncronous and ignoring RASDIALEXTENSIONS.
            'So that HWND is valid &HFFFFFFFF
            Load frmAsyncDial
            DoEvents
            lngRetCode = rasDial(ByVal APINULL, vbNullString, lprasdialparams, &HFFFFFFFF, frmAsyncDial.hWnd, hRasConn)
         Else
            'Syncronous and ignoring RASDIALEXTENSIONS.
            Screen.MousePointer = vbHourglass
            lngRetCode = rasDial(ByVal APINULL, vbNullString, lprasdialparams, APINULL, ByVal APINULL, hRasConn)
            Screen.MousePointer = vbDefault
         End If
         'Test for failure and raise error if so
         If lngRetCode Then
'            lngRASErrorNumber = lngRetCode
'            strRASDescription = lpRASError.fcnRASErrorString()
            lngRetHangUp = RasHangUp(hRasConn)
            hRasConn = 0
'            Err.Raise vbObjectError + lngRetCode, "Connections AddConnection Failed", "RAS Failure"
         Else
            'Return the handle to the connection to the client if they need it. See below
            'Just giving time so that Connections is updated properly
            DoEvents
         End If
      Else
         'We are running 95 (lngWindowVersion =1)
         Dim lprasdialparams95 As RASDIALPARAMS95
         lprasdialparams95.dwSize = 1052
         'Using lstrcpy because StrConv fails. I let VB convert the string and fill the array
         'I should theoretically be error checking here, but chances of failure are slim and
         'I should catch it because RASDIAL will fail
         lngRetlstrcpy = lstrcpy(lprasdialparams95.szEntryName(0), msEnterName)
         lngRetlstrcpy = lstrcpy(lprasdialparams95.szPhoneNumber(0), vsDial)
         lngRetlstrcpy = lstrcpy(lprasdialparams95.szCallbackNumber(0), "")
         lngRetlstrcpy = lstrcpy(lprasdialparams95.szUserName(0), "aa")
         lngRetlstrcpy = lstrcpy(lprasdialparams95.szPassword(0), "aa")
         lngRetlstrcpy = lstrcpy(lprasdialparams95.szDomain(0), "")
'         Dim code As Long
'         code = RasSetEntryDialParams(vbNullString, lprasdialparams95, 0&)
         'Call RASDial
         If boolAsync Then
            'Asyncronous and ignoring RASDIALEXTENSIONS.
            'So that HWND is valid
            Load frmAsyncDial
            'just to be sure
            DoEvents
            lngRetCode = rasDial(ByVal APINULL, vbNullString, lprasdialparams95, &HFFFFFFFF, frmAsyncDial.hWnd, hRasConn)
         Else
            'Syncronous and ignoring RASDIALEXTENSIONS.
            Screen.MousePointer = vbHourglass
            lngRetCode = rasDial(ByVal APINULL, vbNullString, lprasdialparams95, APINULL, ByVal APINULL, hRasConn)
            Screen.MousePointer = vbDefault
         End If
         'Test for failure and raise error if so
         If lngRetCode Then
'            lngRASErrorNumber = lngRetCode
'            strRASDescription = lpRASError.fcnRASErrorString()
            lngRetHangUp = RasHangUp(hRasConn)
            hRasConn = 0
''            Err.Raise vbObjectError + lngRetCode, "Connections AddConnection Failed", "RAS Failure"
         Else
            'Return the handle to the connection to the client if they need it. See below
            'Just giving time so that Connections is updated properly
            DoEvents
         End If
      End If
      
      'Return the handle to the connection to the client if they need it
      'Enumerate the connections so that we can return correct handle to connection object
      'This is the only way I can see to guarantee object without complex algorithms
      If boolAsync Then
         'this is sort of a kludge, but I am setting the Tag of the form to the hRasConn
         'so that I can reference it in the form without having to use public variables
        DoEvents
         frmAsyncDial.Tag = Hex$(hRasConn)
         DoEvents
         
         'show the async form so that processing stops here and get RAS_EVENTS in form
         frmAsyncDial.Show 1
      Else
         'nothing to do if synchronous
      End If
     'Refresh and return the function to the client
'      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

      If glDialConn = 0 Then
        AddConnection = 0
      Else
        AddConnection = hRasConn
      End If
      Exit Function
err:
    MsgBox "连接错误", vbOKOnly + vbExclamation, "提示信息"
    AddConnection = 0
End Function


Private Sub fcnRASEnumEntries()
 
   Dim lngRetCode As Long
   Dim lpszreserved As String
   Dim lpszPhonebook As String
   Dim lpcb As Long
   Dim lpcEntries As Long
   Dim intArraySize As Integer
   Dim intLooper As Long
   
   lpszreserved = vbNullString
   lpszPhonebook = vbNullString
   'Putting a maximum of 256 Entries. If it fails then we resize
   intArraySize = 255
   If lngWindowVersion = 2 Then
      'We are running NT
      ReDim lprasentryname(intArraySize) As RASENTRYNAME
      lprasentryname(0).dwSize = 28
      lpcb = 256 * lprasentryname(0).dwSize
      lngRetCode = RasEnumEntries(lpszreserved, lpszPhonebook, lprasentryname(0), lpcb, lpcEntries)
   Else
      'We are running 95 (lngWindowVersion =1)
      ReDim lprasentryname95(intArraySize) As RASENTRYNAME95
      lprasentryname95(0).dwSize = 264
      lpcb = 256 * lprasentryname95(0).dwSize
      lngRetCode = RasEnumEntries(lpszreserved, lpszPhonebook, lprasentryname95(0), lpcb, lpcEntries)
   End If
   
   
   Select Case lngRetCode
      Case SUCCESS
         If lpcEntries > 0 Then
            'resize array so that it is correct size based on return from function
'            ReDim arrPEntry(lpcEntries - 1) As PhoneEntry
            If lngWindowVersion = 2 Then
                'running NT
               For intLooper = 0 To 100
'                  Set arrPEntry(intLooper) = New PhoneEntry
                  'allow entryname update
'                  boolAllowUpdate = True
'                    intLooper = 1
                  msEnterName = fcnTrimNulls(StrConv(lprasentryname(intLooper).szEntryName, vbUnicode))
'                  MsgBox lpszPhonebook, vbOKOnly, "aa"
''                  arrPEntry(intLooper).Index = intLooper
''                  boolAllowUpdate = False
                    If msEnterName <> "" Then
            
                        Exit For
                    End If
               Next
            Else
               'running 95
'               For intLooper = 0 To UBound(arrPEntry())
'                  Set arrPEntry(intLooper) = New PhoneEntry
                  'allow entryname update
'                  boolAllowUpdate = True
                  msEnterName = fcnTrimNulls(StrConv(lprasentryname95(intLooper).szEntryName, vbUnicode))
''                  arrPEntry(intLooper).Index = intLooper
''                  boolAllowUpdate = False
''               Next intLooper
            End If
         End If
         'set the Phoneentries.Count
         'I doubt that this will fail, but...
''         intPCount = CInt(lpcEntries)
''         fcnRASEnumEntries = 0
      Case ERROR_BUFFER_TOO_SMALL
         'Make buffers bigger and try again
         If lngWindowVersion = 2 Then
            'running NT
            intArraySize = lpcb / lprasentryname(0).dwSize
         Else
            'running 95
            intArraySize = lpcb / lprasentryname95(0).dwSize
         End If
      Case Else
        MsgBox "不能获取连接属性，请确认是否已经建立了拨号连接？", vbOKOnly + vbInformation, "提示信息"

   End Select
  
End Sub