代码创建VPN连接，问题

查以前的帖子找到下面的代码，可是我测试总是说“连接建立失败！”,是什么原因呢？我是通过路由拨ADSL上网的，是不是和这有关系？请高手指点...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 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 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 Command1_Click()
    Dim sEntryName As String, sUsername As String, sPassword As String    sEntryName = "VPN"
    sUsername = "super"
    sPassword = "greenbean"    If Create_PPPoE_Connection("VPN", sEntryName, sUsername, sPassword) Then
        MsgBox "连接建立成功！"
    Else
        MsgBox "连接建立失败！"
    End If
End SubFunction Create_PPPoE_Connection(ByVal sDeviceType As String, 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 微型端口 (PPTP)"
 
    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 = 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, sEntryName, rc, 0) = 0 Then
            Create_PPPoE_Connection = True
        End If
    End If
End Function

解决方案 »

  1.   

    你抄错了吧....
    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 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 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 = "super"
        sPassword = "greenbean"
        
        If Create_PPPoE_Connection(sEntryName, sUsername, sPassword) Then
            MsgBox "连接建立成功！"
        Else
            MsgBox "连接建立失败！"
        End If
        
    vpn:
    '创建VPN
        Dim sServer As String
        sServer = "10.1.32.98" '或者用域名 sServer = "www.myserver.com"
        sEntryName = "VPN连接"
        sUsername = "super"
        sPassword = "greenbean"    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
      

  2.   

    试了你给的这个代码，还是“连接建立失败！”，我看了一下Create_VPN_Connection这个函数，在最后的RasSetEntryProperties(vbNullString, sEntryName, re, LenB(re), 0, 0)，我中断了一下，结果是632，应该是0的话才能建立成功。
      

  3.   

    是因为操作系统的原因，winXP下就能建立成功，可在win2000下就失败啊。怎么让代码兼容win2000呢？