Option ExplicitPrivate Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End TypePrivate Type RASIPADDR a As Byte b As Byte c As Byte d As Byte End TypePrivate 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 TypePrivate Type RASCREDENTIALS dwSize As Long dwMask As Long szUserName(256) As Byte szPassword(256) As Byte szDomain(15) As Byte End TypePrivate Const ET_None As Long = 0 ' No encryption Private Const ET_Require As Long = 1 ' Require Encryption Private Const ET_RequireMax As Long = 2 ' Require max encryption Private Const ET_Optional As Long = 3 ' Do encryption if possible. None Ok. Private Const VS_Default As Long = 0 ' default (PPTP for now) Private Const VS_PptpOnly As Long = 1 ' Only PPTP is attempted. Private Const VS_PptpFirst As Long = 2 ' PPTP is tried first. Private Const VS_L2tpOnly As Long = 3 ' Only L2TP is attempted. Private Const VS_L2tpFirst As Long = 4 ' L2TP is tried first. Private Const RASET_Phone As Long = 1 ' Phone lines: modem, ISDN, X.25, etc Private Const RASET_Vpn As Long = 2 ' Virtual private network Private Const RASET_Direct As Long = 3 ' Direct connect: serial, parallel Private Const RASET_Internet As Long = 4 ' BaseCamp internet Private Const RASET_Broadband As Long = 5 ' Broadband 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, ByVal lpszEntry As String, lpCredentials As RASCREDENTIALS, ByVal fClearCredentials As Long) As Long Private Sub Command2_Click() Dim sEntryName As String, sUsername As String, sPassword As String '创建PPPoE sEntryName = "宽带连接 " sUsername = "wza.******" sPassword = "*******" If Create_PPPoE_Connection(sEntryName, sUsername, sPassword) Then MsgBox "连接建立成功！ " Else MsgBox "连接建立失败！ " End If End SubFunction Create_PPPoE_Connection(ByVal sEntryName As String, ByVal sUsername As String, ByVal sPassword As String) As Boolean Dim rtn As Long Dim re As RASENTRY Dim sDeviceName As String, sDeviceType As String Dim rc As RASCREDENTIALS Create_PPPoE_Connection = False sDeviceName = "WAN 微型端口 (PPPOE) " sDeviceType = "PPPoE" With re .dwSize = LenB(re) .dwCountryCode = 86 .dwCountryID = 86 .dwDialExtraPercent = 75 .dwDialExtraSampleSeconds = 120 .dwDialMode = 1 .dwEncryptionType = 3 .dwfNetProtocols = 4 .dwfOptions = 1024262928 .dwfOptions2 = 367 .dwFramingProtocol = 1 .dwHangUpExtraPercent = 10 .dwHangUpExtraSampleSeconds = 120 .dwRedialCount = 3 .dwRedialPause = 60 .dwType = RASET_Broadband CopyMemory .szDeviceName(0), ByVal sDeviceName, Len(sDeviceName) CopyMemory .szDeviceType(0), ByVal sDeviceType, Len(sDeviceType) End With
With rc .dwSize = LenB(rc) .dwMask = 11 CopyMemory .szUserName(0), ByVal sUsername, Len(sUsername) CopyMemory .szPassword(0), ByVal sPassword, Len(sPassword) End With
If RasSetEntryProperties(vbNullString, sEntryName, re, LenB(re), 0, 0) = 0 Then If RasSetCredentials(vbNullString, sEntryName, rc, 0) = 0 Then Create_PPPoE_Connection = True End If End If End Function Function Create_VPN_Connection(ByVal sEntryName As String, ByVal sServer As String, ByVal sUsername As String, ByVal sPassword As String) As Boolean Dim re As RASENTRY Dim rc As RASCREDENTIALS Dim rtn As Long Dim sDeviceName As String, sDeviceType As String Create_VPN_Connection = False
With rc .dwSize = LenB(rc) .dwMask = 11 CopyMemory .szUserName(0), ByVal sUsername, Len(sUsername) CopyMemory .szPassword(0), ByVal sPassword, Len(sPassword) End With
If RasSetEntryProperties(vbNullString, sEntryName, re, LenB(re), 0, 0) = 0 Then If RasSetCredentials(vbNullString, sEntryName, rc, 0) = 0 Then Create_VPN_Connection = True End If End If End Function Private Sub Command1_Click() Dim sEntryName As String, sUsername As String, sPassword As String '创建VPN Dim sServer As String sServer = "10.130.7.250 " sEntryName = "VPN连接 " sUsername = "*******" sPassword = "*******" If Create_VPN_Connection(sEntryName, sServer, sUsername, sPassword) Then MsgBox "连接建立成功！ " Else MsgBox "连接建立失败！ " End If End Sub Private Sub Form_Load()End Sub
Option ExplicitPrivate Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End TypePrivate Type RASIPADDR
a As Byte
b As Byte
c As Byte
d As Byte
End TypePrivate 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 TypePrivate Type RASCREDENTIALS
dwSize As Long
dwMask As Long
szUserName(256) As Byte
szPassword(256) As Byte
szDomain(15) As Byte
End TypePrivate Const ET_None As Long = 0 ' No encryption
Private Const ET_Require As Long = 1 ' Require Encryption
Private Const ET_RequireMax As Long = 2 ' Require max encryption
Private Const ET_Optional As Long = 3 ' Do encryption if possible. None Ok.
Private Const VS_Default As Long = 0 ' default (PPTP for now)
Private Const VS_PptpOnly As Long = 1 ' Only PPTP is attempted.
Private Const VS_PptpFirst As Long = 2 ' PPTP is tried first.
Private Const VS_L2tpOnly As Long = 3 ' Only L2TP is attempted.
Private Const VS_L2tpFirst As Long = 4 ' L2TP is tried first.
Private Const RASET_Phone As Long = 1 ' Phone lines: modem, ISDN, X.25, etc
Private Const RASET_Vpn As Long = 2 ' Virtual private network
Private Const RASET_Direct As Long = 3 ' Direct connect: serial, parallel
Private Const RASET_Internet As Long = 4 ' BaseCamp internet
Private Const RASET_Broadband As Long = 5 ' Broadband
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, ByVal lpszEntry As String, lpCredentials As RASCREDENTIALS, ByVal fClearCredentials As Long) As Long
Private Sub Command2_Click()
Dim sEntryName As String, sUsername As String, sPassword As String
'创建PPPoE
sEntryName = "宽带连接 "
sUsername = "wza.******"
sPassword = "*******"
If Create_PPPoE_Connection(sEntryName, sUsername, sPassword) Then
MsgBox "连接建立成功！ "
Else
MsgBox "连接建立失败！ "
End If
End SubFunction Create_PPPoE_Connection(ByVal sEntryName As String, ByVal sUsername As String, ByVal sPassword As String) As Boolean
Dim rtn As Long
Dim re As RASENTRY
Dim sDeviceName As String, sDeviceType As String
Dim rc As RASCREDENTIALS
Create_PPPoE_Connection = False
sDeviceName = "WAN 微型端口 (PPPOE) "
sDeviceType = "PPPoE"
With re
.dwSize = LenB(re)
.dwCountryCode = 86
.dwCountryID = 86
.dwDialExtraPercent = 75
.dwDialExtraSampleSeconds = 120
.dwDialMode = 1
.dwEncryptionType = 3
.dwfNetProtocols = 4
.dwfOptions = 1024262928
.dwfOptions2 = 367
.dwFramingProtocol = 1
.dwHangUpExtraPercent = 10
.dwHangUpExtraSampleSeconds = 120
.dwRedialCount = 3
.dwRedialPause = 60
.dwType = RASET_Broadband
CopyMemory .szDeviceName(0), ByVal sDeviceName, Len(sDeviceName)
CopyMemory .szDeviceType(0), ByVal sDeviceType, Len(sDeviceType)
End With
With rc
.dwSize = LenB(rc)
.dwMask = 11
CopyMemory .szUserName(0), ByVal sUsername, Len(sUsername)
CopyMemory .szPassword(0), ByVal sPassword, Len(sPassword)
End With
If RasSetEntryProperties(vbNullString, sEntryName, re, LenB(re), 0, 0) = 0 Then
If RasSetCredentials(vbNullString, sEntryName, rc, 0) = 0 Then
Create_PPPoE_Connection = True
End If
End If
End Function
Function Create_VPN_Connection(ByVal sEntryName As String, ByVal sServer As String, ByVal sUsername As String, ByVal sPassword As String) As Boolean
Dim re As RASENTRY
Dim rc As RASCREDENTIALS
Dim rtn As Long
Dim sDeviceName As String, sDeviceType As String
Create_VPN_Connection = False
sDeviceName = "WAN 微型端口 (L2TP) "
sDeviceType = "vpn"
With re
.dwSize = LenB(re)
.dwCountryCode = 86
.dwCountryID = 86
.dwDialExtraPercent = 75
.dwDialExtraSampleSeconds = 120
.dwDialMode = 1
.dwfNetProtocols = 4
.dwfOptions = 1024262928
.dwfOptions2 = 367
.dwFramingProtocol = 1
.dwHangUpExtraPercent = 10
.dwHangUpExtraSampleSeconds = 120
.dwRedialCount = 3
.dwRedialPause = 60
.dwType = RASET_Vpn
CopyMemory .szDeviceName(0), ByVal sDeviceName, Len(sDeviceName)
CopyMemory .szDeviceType(0), ByVal sDeviceType, Len(sDeviceType)
CopyMemory .szLocalPhoneNumber(0), ByVal sServer, Len(sServer) '服务器地址
.dwVpnStrategy = VS_Default 'vpn类型
.dwEncryptionType = ET_Optional '数据加密类型
End With
With rc
.dwSize = LenB(rc)
.dwMask = 11
CopyMemory .szUserName(0), ByVal sUsername, Len(sUsername)
CopyMemory .szPassword(0), ByVal sPassword, Len(sPassword)
End With
If RasSetEntryProperties(vbNullString, sEntryName, re, LenB(re), 0, 0) = 0 Then
If RasSetCredentials(vbNullString, sEntryName, rc, 0) = 0 Then
Create_VPN_Connection = True
End If
End If
End Function
Private Sub Command1_Click()
Dim sEntryName As String, sUsername As String, sPassword As String
'创建VPN
Dim sServer As String
sServer = "10.130.7.250 "
sEntryName = "VPN连接 "
sUsername = "*******"
sPassword = "*******"
If Create_VPN_Connection(sEntryName, sServer, sUsername, sPassword) Then
MsgBox "连接建立成功！ "
Else
MsgBox "连接建立失败！ "
End If
End Sub
Private Sub Form_Load()End Sub