网上找了一个VB的拨号连接代码,贴上收藏

前端之家收集整理的这篇文章主要介绍了网上找了一个VB的拨号连接代码,贴上收藏前端之家小编觉得挺不错的,现在分享给大家,也给大家做个参考。

Option Explicit

''''''''''''''''''''''''''''''''

Public Const mod_strConnName_VPN = "VPN连接"

Public Const mod_ver_VPN = "1.0.0"



''''''''''''''''''''''''''''''''

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



Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any,Source As Any,ByVal Length As Long)

Private Declare Function RasSetEntryProperties Lib "rasapi32" Alias "RasSetEntryPropertiesA" (ByVal lpszPhonebook As String,ByVal lpszEntry As String,lpRasEntry As RASENTRY,ByVal dwEntryInfoSize As Long,ByVal lpbDeviceInfo As Long,ByVal dwDeviceInfoSize As Long) As Long

Private Declare Function RasSetCredentials Lib "rasapi32" Alias "RasSetCredentialsA" (ByVal lpszPhonebook As String,lpCredentials As RASCREDENTIALS,ByVal fClearCredentials As Long) As Long



Private Type RASIPADDR

a
As Byte

b
As Byte

c
As Byte

d
As Byte

End Type



Private Type GUID

Data1
As Long

Data2
As Integer

Data3
As Integer

Data4(
7) As Byte

End Type



Private Type RASENTRY

dwSize
As Long

dwfOptions
As Long

dwCountryID
As Long

dwCountryCode
As Long

szAreaCode(
10) As Byte

szLocalPhoneNumber(
128) As Byte

dwAlternateOffset
As Long

ipaddr
As RASIPADDR

ipaddrDns
As RASIPADDR

ipaddrDnsAlt
As RASIPADDR

ipaddrWins
As RASIPADDR

ipaddrWinsAlt
As RASIPADDR

dwFrameSize
As Long

dwfNetProtocols
As Long

dwFramingProtocol
As Long

szScript(
259) As Byte

szAutodialDll(
259) As Byte

szAutodialFunc(
259) As Byte

szDeviceType(
16) As Byte

szDeviceName(
128) As Byte

szX25PadType(
32) As Byte

szX25Address(
200) As Byte

szX25Facilities(
200) As Byte

szX25UserData(
200) As Byte

dwChannels
As Long

dwReserved1
As Long

dwReserved2
As Long

dwSubEntries
As Long

dwDialMode
As Long

dwDialExtraPercent
As Long

dwDialExtraSampleSeconds
As Long

dwHangUpExtraPercent
As Long

dwHangUpExtraSampleSeconds
As Long

dwIdleDisconnectSeconds
As Long

dwType
As Long

dwEncryptionType
As Long

dwCustomAuthKey
As Long

guidId
As GUID

szCustomDialDll(
259) As Byte

dwVpnStrategy
As Long

dwfOptions2
As Long

dwfOptions3
As Long

szDnsSuffix(
255) As Byte

dwTcpWindowSize
As Long

szPrerequisitePbk(
259) As Byte

szPrerequisiteEntry(
256) As Byte

dwRedialCount
As Long

dwRedialPause
As Long

End Type



Private Type RASCREDENTIALS

dwSize
As Long

dwMask
As Long

szUserName(
256) As Byte

szPassword(
256) As Byte

szDomain(
15) As Byte

End Type



Dim lprasconn95() As RASCONN95



'创建连接

Public Function Create_PPPoE_Connection(ByVal sDeviceType As String,ByVal sEntryName As String,ByVal sUsername As String,ByVal sPassword As String,Optional ByVal dwfOptions As Long = 1024262672) As Boolean

Create_PPPoE_Connection
= False



Dim re As RASENTRY

Dim sDeviceName As String ',sDeviceType As String

sDeviceName = "WAN 微型端口 (PPTP)"



With re

.dwSize
= LenB(re)

.dwCountryCode
= 86

.dwCountryID
= 86

.dwDialExtraPercent
= 75

.dwDialExtraSampleSeconds
= 120

.dwDialMode
= 1

.dwEncryptionType
= 3

.dwfNetProtocols
= 4

'dwfOptions

'111101000011010000001100010000

' -是否手动设置IP和DNS:0-自动,1-手动

' _ 决定是否在右下角显示托盘图标

' - 决定是否使用服务器上的网关

'.dwfOptions = 1024262928

.dwfOptions = dwfOptions

.dwfOptions2
= 367

.dwFramingProtocol
= 1

.dwHangUpExtraPercent
= 10

.dwHangUpExtraSampleSeconds
= 120

.dwRedialCount
= 3

.dwRedialPause
= 60

.dwType
= 5 '3-直连 4-管理 5-宽带 7-普通

CopyMemory .szDeviceName(0),ByVal sDeviceName,Len(sDeviceName)

CopyMemory .szDeviceType(
0),ByVal sDeviceType,Len(sDeviceType)

End With



Dim rc As RASCREDENTIALS

With rc

.dwSize
= LenB(rc)

.dwMask
= 11

CopyMemory .szUserName(
0),ByVal sUsername,Len(sUsername)

CopyMemory .szPassword(
0),ByVal sPassword,Len(sPassword)

End With



Dim rtn As Long

If RasSetEntryProperties(vbNullString,sEntryName,re,LenB(re),0,0) = 0 Then

If RasSetCredentials(vbNullString,rc,0) = 0 Then

Create_PPPoE_Connection
= True

End If

End If

End Function

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 '?úWINDOWS95/98?D±?D???dwSizeéè?a1052

'à?ó?lstrcpyoˉêy??×?·?′???±′μ?BYTEêy×é

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)

'?ò??ê1ó?í?2?í¨D?

Screen.MousePointer = vbHourglass

hRasConn
= 0 '

lngRetCode = RasDial(ByVal APINULL,vbNullString,lprasdialparams,APINULL,ByVal APINULL,hRasConn)

Screen.MousePointer
= vbDefault

'2aê?óD??óD′í?ó

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),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),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,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),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

原文链接:https://www.f2er.com/vb/261704.html

猜你在找的VB相关文章