代码实现VPN连接

Imports System.Runtime.InteropServices
Imports System.Data.OleDb
Public Class Class1
    ' Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Object, ByVal Source As Object, ByVal Length As Long)
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal lpvDest() As Byte, ByVal lpvSource As String, ByVal cbCopy As Integer) '
    Private Structure GUID
        Dim Data1 As Long
        Dim Data2 As Integer
        Dim Data3 As Integer
        Dim Data4() As Byte
        Public Sub Initialize()
            ReDim Data4(7)
        End Sub
    End Structure
    Private Structure RASIPADDR
        Dim a As Byte
        Dim b As Byte
        Dim c As Byte
        Dim d As Byte
    End Structure
    <StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Auto)> Private Structure RASENTRY
        Public dwSize As Long
        Public dwfOptions As Long
        Public dwCountryID As Long
        Public dwCountryCode As Long
        Public dwAlternateOffset As Long
        Public ipaddr As RASIPADDR
        Public ipaddrDns As RASIPADDR
        Public ipaddrDnsAlt As RASIPADDR
        Public ipaddrWins As RASIPADDR
        Public ipaddrWinsAlt As RASIPADDR
        Public dwFrameSize As Long
        Public dwfNetProtocols As Long
        Public dwFramingProtocol As Long
        Public szAreaCode() As Byte
        Public szLocalPhoneNumber() As Byte
        Public szScript() As Byte
        Public szAutodialDll() As Byte
        Public szAutodialFunc() As Byte
        Public szDeviceType() As Byte
        Public szDeviceName() As Byte
        Public szX25PadType() As Byte
        Public szX25Address() As Byte
        Public szX25Facilities() As Byte
        Public szX25UserData() As Byte
        Public szPrerequisitePbk() As Byte
        Public szPrerequisiteEntry() As Byte
        Public szDnsSuffix() As Byte
        Public szCustomDialDll() As Byte
        Public dwChannels As Long
        Public dwReserved1 As Long
        Public dwReserved2 As Long
        Public dwSubEntries As Long
        Public dwDialMode As Long
        Public dwDialExtraPercent As Long
        Public dwDialExtraSampleSeconds As Long
        Public dwHangUpExtraPercent As Long
        Public dwHangUpExtraSampleSeconds As Long
        Public dwIdleDisconnectSeconds As Long
        Public dwType As Long
        Public dwEncryptionType As Long
        Public dwCustomAuthKey As Long
        Public guidId As GUID
        Public dwVpnStrategy As Long
        Public dwfOptions2 As Long
        Public dwfOptions3 As Long
        Public dwTcpWindowsize As Long
        Public dwRedialCount As Long
        Public dwRedialPause As Long
        Public Sub Initialize()
            ReDim szAreaCode(10)
            ReDim szLocalPhoneNumber(128)
            ReDim szScript(259)
            ReDim szAutodialDll(259)
            ReDim szAutodialFunc(259)
            ReDim szDeviceType(128)
            ReDim szDeviceName(16)
            ReDim szX25PadType(32)
            ReDim szX25Address(200)
            ReDim szX25Facilities(200)
            ReDim szX25UserData(200)
            ReDim szPrerequisitePbk(259)
            ReDim szPrerequisiteEntry(259)
            ReDim szDnsSuffix(255)
            ReDim szCustomDialDll(259)
        End Sub
    End Structure
    <StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Auto)> Private Structure RASCREDENTIALS
        Public dwSize As Long
        Public dwMask As Long
        Public szUserName() As Byte
        Public szPassword() As Byte
        Public szDomain() As Byte
        Public Sub Initialize()
            ReDim szUserName(256)
            ReDim szPassword(256)
            ReDim szDomain(15)
        End Sub
    End Structure
    Private 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, ByVal 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, ByVal lpCredentials As RASCREDENTIALS, ByVal fClearCredentials As Long) As Long
    Public Sub testconn()
        Dim sEntryName As String, sUsername As String, sPassword As String
        '创建VPN
        Dim sServer As String
        sServer = "10.1.32.98"
        sEntryName = "VPN连接"
        sUsername = "super"
        sPassword = "greenbean"
        If Create_VPN_Connection(sEntryName, sServer, sUsername, sPassword) Then
            MsgBox("连接建立成功！")
        Else
            MsgBox("连接建立失败！")
        End If
    End Sub
    Function Create_VPN_Connection(ByVal sEntryName As String, ByVal sServer As String, ByVal sUsername As String, ByVal sPassword As String) As Boolean
        Create_VPN_Connection = False
        Dim re As RASENTRY
        Dim sDeviceName As String, sDeviceType As String
        sDeviceName = "WAN 微型端口 (L2TP)"
        sDeviceType = "vpn"
        re.Initialize()
        With re
            .dwSize = Marshal.SizeOf(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, sDeviceName, Len(sDeviceName))
            CopyMemory(.szDeviceType, sDeviceType, Len(sDeviceType))
            CopyMemory(.szLocalPhoneNumber, sServer, Len(sServer)) '服务器地址
            .dwVpnStrategy = VS_Default    'vpn类型
            .dwEncryptionType = ET_Optional '数据加密类型
        End With
        Dim rc As RASCREDENTIALS
        rc.Initialize()
        With rc
            .dwSize = Marshal.SizeOf(rc)
            .dwMask = 11
            CopyMemory(.szUserName, sUsername, Len(sUsername))
            CopyMemory(.szPassword, sPassword, Len(sPassword))
        End With
        Dim rtn As Long
        If RasSetEntryProperties(vbNullString, sEntryName, re, Marshal.SizeOf(re), 0, 0) = 0 Then
'上面这句话报错的，大家给看看吧。
'谢谢了！
            If RasSetCredentials(vbNullString, sEntryName, rc, 0) = 0 Then
                Create_VPN_Connection = True
            End If
        End If
    End Function
End Class