求vpn拨号

希望给我一个vpn拨号的例子(code)

解决方案 »

  1.   

    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     ' BroadbandPrivate 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, ByVal lpszEntry As String, lpCredentials As RASCREDENTIALS, ByVal fClearCredentials As Long) As LongPrivate Sub Form_Load()
        Dim sEntryName As String, sUsername As String, sPassword As String    GoTo vpnpppoe:
    '创建PPPoE
        sEntryName = "宽带连接 "
        sUsername = "ly001 "
        sPassword = "123456 "    If Create_PPPoE_Connection(sEntryName, sUsername, sPassword) Then
             MsgBox "连接建立成功！ "
        Else
             MsgBox "连接建立失败！ "
        End Ifvpn:
    '创建VPN
        Dim sServer As String
        sServer = "szlingyun.3322.org" '或者用域名 sServer = "www.myserver.com "
        sEntryName = "VPN连接"
        sUsername = "ly001 "
        sPassword = "123456 "    If Create_VPN_Connection(sEntryName, sServer, 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
        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
        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
    这是我抄别人的，但总是连接失败???