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