'代理出处：http://www.yiqun.info/page/testvpn.html
'说    明：附件中有完整的实例
Private 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 Type

Private Type RASIPADDR
    a   As Byte
    b   As Byte
    c   As Byte
    d   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

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

Option Explicit
'拨号/断网
Private Declare Function InternetDial Lib "wininet.dll" (ByVal hwndParent As Long, ByVal lpszConnectoid As String, ByVal dwFlags As Long, lpdwConnection As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetHangUp Lib "wininet.dll" (ByVal dwConnection As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Long
Private Const INTERNET_DIALSTATE_DISCONNECTED = 1
Private Const INTERNET_AUTODIAL_FORCE_ONLINE = 1
Private Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2
Private Const INTERNET_DIAL_UNATTENDED = &H8000
Private Handle As Long

'拨号
Function DialUp(LinkName As String) As Boolean
    InternetDial 0, LinkName, INTERNET_AUTODIAL_FORCE_UNATTENDED, Handle, 0
    DialUp = (Handle <> 0)
End Function

Function Create_PPPoE_Connection(ByVal sEntryName As String, ByVal sUsername As String, ByVal sPassword As String) As Boolean 'ADSL模块
    Create_PPPoE_Connection = False
    
    Dim re     As RASENTRY
    Dim sDeviceName     As String, sDeviceType       As String
    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
    
    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, 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 'VPN模块
    Create_VPN_Connection = False
    
    Dim re     As RASENTRY
    Dim sDeviceName     As String, sDeviceType       As String
    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
    
    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, sEntryName, rc, 0) = 0 Then
            Create_VPN_Connection = True
        End If
    End If
End Function

Private Sub Command1_Click()
    Call Create_VPN_Connection(Text1.Text, Text2.Text, Text3.Text, Text4.Text) '创建
    'Call Create_VPN_Connection(连接名, ip地址, 帐号, 密码)
End Sub

Private Sub Command2_Click()
    Shell "rasdial " & Text1.Text & " " & Text3.Text & " " & Text4.Text, vbNormalFocus '连接
    'Shell "rasdial " & 连接名 & " " & 帐号 & " " & 密码, vbNormalFocus
End Sub

Private Sub Command3_Click()
    Shell "rasdial " & Text1.Text & " /d", vbNormalFocus '断开
    'Shell "rasdial " & 连接名 & " /d", vbNormalFocus
End Sub

Private Sub Command4_Click()
    Shell "rasphone -r " & Text1.Text, vbNormalFocus '删除
    'Shell "rasphone -r " & 连接名, vbNormalFocus
End Sub