VB开发的有拨号状态显示状态栏里,要如何改
VB开发的有拨号状态显示状态栏里,要如何改'调用方法:
'拨号: temp = AddConnection("连接名", "", "", username, Password, "") 'ADSL
'temp=0 成功,否则失败
'断线: HangUpAll
Option Explicit
Public hRasConn As Long '?¨ò?ò??????òRASμ÷ó?μ?è?????±ú
Public Const APINULL = 0&
Public Const UNLEN = 256
Public Const DNLEN = 15
Public Const PWLEN = 256
Public Const RAS95_MaxPhoneNumber = 128
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxCallbackNumber = RAS95_MaxPhoneNumber
Public Type RASDIALPARAMS95
dwSize As Long
szEntryName(RAS95_MaxEntryName) As Byte
szPhoneNumber(RAS95_MaxPhoneNumber) As Byte
szCallbackNumber(RAS95_MaxCallbackNumber) As Byte
szUserName(UNLEN) As Byte
szPassword(PWLEN) As Byte
szDomain(DNLEN) As Byte
End Type
'**********************************
'* RASμ÷ó?′í?ó′úo? *
'**********************************
Public Const NOT_SUPPORTED = 120&
Public Const RASBASEERROR = 600&
Public Const SUCCESS = 0&
Public Const ERROR_PORT_ALREADY_OPEN = (RASBASEERROR + 2)
Public Const ERROR_UNKNOWN = (RASBASEERROR + 35)
Public Const ERROR_REQUEST_TIMEOUT = (RASBASEERROR + 38)
Public Const ERROR_PASSWD_EXPIRED = (RASBASEERROR + 48)
Public Const ERROR_NO_DIALIN_PERMISSION = (RASBASEERROR + 49)
Public Const ERROR_SERVER_NOT_RESPONDING = (RASBASEERROR + 50)
Public Const ERROR_UNRECOGNIZED_RESPONSE = (RASBASEERROR + 52)
Public Const ERROR_NO_RESPONSES = (RASBASEERROR + 60)
Public Const ERROR_DEVICE_NOT_READY = (RASBASEERROR + 66)
Public Const ERROR_LINE_BUSY = (RASBASEERROR + 76)
Public Const ERROR_NO_ANSWER = (RASBASEERROR + 78)
Public Const ERROR_NO_CARRIER = (RASBASEERROR + 79)
Public Const ERROR_NO_DIALTONE = (RASBASEERROR + 80)
Public Const ERROR_AUTHENTICATION_FAILURE = (RASBASEERROR + 91)
Public Const ERROR_PPP_TIMEOUT = (RASBASEERROR + 118)
'//////////////////////////////////////////////////////////////////////
'Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceName = 128
Public Const RAS_MaxDeviceType = 16
Public Type RASCONN95
'set dwsize to 412
dwSize As Long
hRasConn As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
'/////////////////////////////////////////////////////////////////////////////////
'**********************************
'* RAS API éù?÷ *
'**********************************
Public Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, ByVal lpString2 As String) As Long
Public Declare Function RasDial Lib "RasApi32.DLL" Alias "RasDialA" (lpRasDialExtensions As Any, ByVal lpszPhonebook As String, lprasdialparams As Any, ByVal dwNotifierType As Long, lpvNotifier As Long, lphRasConn As Long) As Long
Public Declare Function RasHangUp Lib "RasApi32.DLL" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long
Public Declare Function RasEnumConnections Lib "RasApi32.DLL" Alias "RasEnumConnectionsA" (lprasconn As Any, lpcb As Long, lpcConnections As Long) As Long
Public Function AddConnection(strNewEntryName As String, strNewPhoneNumber As String, strNewCallbackNumber As String, strNewUsername As String, strNewPassword As String, strNewDomain As String) As Integer
'拨号连接
Dim lngRetCode As Long
Dim lngRetLstrcpy As Long
Dim lngRetHangUp As Long
Dim lprasdialparams As RASDIALPARAMS95
If IsConnectionByName(strNewEntryName) = True Then
AddConnection = -1: Exit Function '已连接
End If
lprasdialparams.dwSize = 1052
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)
Screen.MousePointer = vbHourglass
hRasConn = 0 '
lngRetCode = RasDial(ByVal APINULL, vbNullString, lprasdialparams, APINULL, ByVal APINULL, hRasConn)
Screen.MousePointer = vbDefault
If lngRetCode Then
lngRetHangUp = RasHangUp(hRasConn)
End If
AddConnection = lngRetCode
End Function
Public Function GetConnections() As Integer
'获取所有连接总数
Dim lngRetCode As Long
Dim lpcb As Long
Dim lpcConnections As Long
Dim intArraySize As Integer
ReDim lprasconn95(intArraySize) As RASCONN95
lprasconn95(0).dwSize = 412
lpcb = 256 * lprasconn95(0).dwSize
lngRetCode = RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)
' If lngRetCode = 0 Then
' End If
GetConnections = lpcConnections
End Function
Public Function IsConnectionByName(ByVal strEntryName As String) As Boolean
'判断某名称的连接是否已经存在
Dim lngRetCode As Long
Dim lpcb As Long
Dim lpcConnections As Long
Dim intArraySize As Integer
Dim intLooper As Long
Dim bszEntryName() As Byte, i%, bFind As Boolean
ReDim bszEntryName(RAS95_MaxEntryName)
ReDim lprasconn95(intArraySize) As RASCONN95
lprasconn95(0).dwSize = 412
lpcb = 256 * lprasconn95(0).dwSize
lngRetCode = RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)
lstrcpy bszEntryName(0), strEntryName
IsConnectionByName = False
If lngRetCode = 0 Then
If lpcConnections > 0 Then
For intLooper = 0 To lpcConnections - 1
bFind = True
For i = 0 To RAS95_MaxEntryName
If lprasconn95(intLooper).szEntryName(i) <> bszEntryName(i) Then
bFind = False
Exit For
End If
Next
If bFind = True Then
IsConnectionByName = True
Exit For
End If
Next
End If
End If
End Function
'/////////////////////////////////////////////////////
Public Function HangUpAll() As Boolean
'挂断所有连接
Dim lngRetCode As Long
Dim lpcb As Long
Dim lpcConnections As Long
Dim intArraySize As Integer
Dim intLooper As Integer
ReDim lprasconn95(intArraySize) As RASCONN95
lprasconn95(0).dwSize = 412
lpcb = 256 * lprasconn95(0).dwSize
lngRetCode = RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)
If lngRetCode = 0 Then
If lpcConnections > 0 Then
For intLooper = 0 To lpcConnections - 1
RasHangUp lprasconn95(intLooper).hRasConn
Exit For
Next
Else
HangUpAll = False
Exit Function
End If
End If
HangUpAll = True
End Function
'/////////////////////////////////////////////////////
Public Function HangUpByName(ByVal strEntryName As String) As Boolean
'挂断指定名称连接
Dim lngRetCode As Long
Dim lpcb As Long
Dim lpcConnections As Long
Dim intArraySize As Integer
Dim intLooper As Integer
Dim bszEntryName() As Byte, i%, bHangUp As Boolean
ReDim bszEntryName(RAS95_MaxEntryName)
ReDim lprasconn95(intArraySize) As RASCONN95
lprasconn95(0).dwSize = 412
lpcb = 256 * lprasconn95(0).dwSize
lngRetCode = RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)
lstrcpy bszEntryName(0), strEntryName
If lngRetCode = 0 Then
If lpcConnections > 0 Then
For intLooper = 0 To lpcConnections - 1
bHangUp = True
For i = 0 To RAS95_MaxEntryName
If lprasconn95(intLooper).szEntryName(i) <> bszEntryName(i) Then
bHangUp = False
Exit For
End If
Next
If bHangUp = True Then
RasHangUp lprasconn95(intLooper).hRasConn
HangUpByName = True
Exit For
End If
Next
Else
HangUpByName = False
Exit Function
End If
End If
End Function
'/////////////////////////////////////////////////////////
Public Function GetErrMsg(ByVal intErr As Integer)
'拨号错误码
Select Case intErr
Case -1
GetErrMsg = "已连接，不能再连接一次。你可能需要重启电脑。"
Case 605
GetErrMsg = "无法设置端口信息。"
Case 606
GetErrMsg = "无法连接端口。"
Case 617
GetErrMsg = "端口或设备已断开连接。"
Case 618
GetErrMsg = "端口尚未打开。"
Case 619, 628
GetErrMsg = "端口已断开连接。"
Case 621, 622, 623, 624, 625
GetErrMsg = "不存在的连接！"
Case 629
GetErrMsg = "端口已由远程机器断开连接。"
Case 634
GetErrMsg = "无法在远程网络上注册您的计算机。"
Case 642
GetErrMsg = "您的一个 NetBIOS 名称已在远程网络上注册。"
Case 646
GetErrMsg = "不允许本帐户在此时间登录。"
Case 647
GetErrMsg = "帐户已禁用。"
Case 648
GetErrMsg = "该帐户的密码已过期。"
Case 649
GetErrMsg = "帐户没有远程访问权限。"
Case 676
GetErrMsg = "线路忙。"
Case 678
GetErrMsg = "远程计算机不可到达。"
Case 691
GetErrMsg = "由于域上的用户名和/或密码无效而拒绝访问。"
Case 708
GetErrMsg = "帐户已过期。"
Case 709
GetErrMsg = "在域上更改密码时出错。"
Case 720
GetErrMsg = "不能建立到远程计算机的连接。您可能需要更改些连接的网络设置。"
Case 768
GetErrMsg = "因为错误的加密数据造成连接请求失败。"
Case 770
GetErrMsg = "远程设备拒绝连接请求。"
Case 771
GetErrMsg = "因为网络忙造成连接请求失败。"
Case 756
GetErrMsg = "拔号连接正在进行。"
Case 774
GetErrMsg = "因为临时性错误导致连接请求失败。请再试着连接。"
Case 775
GetErrMsg = "连接被远程服务器阻止。"
Case 800
GetErrMsg = "不能建立连接。服务器可能不能到达，或者此连接的安全参数没有正确配置。"
Case Else
GetErrMsg = "没有更详细的错误信息！"
End Select
End Function
[此贴子已经被作者于2016-2-10 17:16编辑过]
