如何用代码创建虚拟专用网络连接(VPN)连接?

Question

可以配置IP,USERNAME,PASSWORD

Answer 1

拨号、断网、枚举连接名称，判断是否在线、连接方式。
http://blog.csdn.net/Modest/archive/2006/10/20/1342633.aspxOption 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'网络状态
Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" Alias "InternetGetConnectedStateExA" (ByRef lpdwFlags As Long, ByVal lpszConnectionName As String, ByVal dwNameLen As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef dwFlags As Long, ByVal dwReserved As Long) As Long
Private Const INTERNET_CONNECTION_MODEM As Long = &H1      '本系统使用调制解调器与因特网相连
Private Const INTERNET_CONNECTION_LAN As Long = &H2        '本系统通过LAN与因特网相连
Private Const INTERNET_CONNECTION_PROXY As Long = &H4      '本系统使用proxy代理服务器与因特网相连
Private Const INTERNET_CONNECTION_MODEM_BUSY As Long = &H8 '未使用
Private Const INTERNET_RAS_INSTALLED As Long = &H10
Private Const INTERNET_CONNECTION_OFFLINE As Long = &H20
Private Const INTERNET_CONNECTION_CONFIGURED As Long = &H40'枚举网络连接
Private Const RAS_MaxDeviceType = 16
Private Const RAS95_MaxDeviceName = 128
Private Const RAS95_MaxEntryName = 256
Private Type RASCONN95
    dwSize As Long
    hRasConn As Long
    szEntryName(RAS95_MaxEntryName) As Byte
    szDeviceType(RAS_MaxDeviceType) As Byte
    szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Private Type RASENTRYNAME95
    dwSize As Long
    szEntryName(RAS95_MaxEntryName) As Byte
End Type
Private Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" (lprasconn As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function RasEnumEntries Lib "rasapi32.dll" Alias "RasEnumEntriesA" (ByVal reserved As String, ByVal lpszPhonebook As String, lprasentryname As Any, lpcb As Long, lpcEntries As Long) As Long
Private Declare Function RasHangUp Lib "rasapi32.dll" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long'拨号
Public Function DialUp(LinkName As String) As Boolean
    InternetDial 0, LinkName, INTERNET_AUTODIAL_FORCE_UNATTENDED, Handle, 0
    DialUp = (Handle <> 0)
End Function
'断网
Public Sub HangUp()
    If Handle <> 0 Then
        InternetHangUp Handle, 0
        Handle = 0
    End If
End Sub
'枚举网络连接
Public Sub EnumConnectName(Value() As String)
    Dim s As Long, l As Long, ln As Long, a As String
    ReDim r(255) As RASENTRYNAME95    r(0).dwSize = 264
    s = 256 * r(0).dwSize
    l = RasEnumEntries(vbNullString, vbNullString, r(0), s, ln)
    ReDim Value(ln - 1)
    For l = 0 To ln - 1
        a = StrConv(r(l).szEntryName(), vbUnicode)
        Value(l) = Left$(a$, InStr(a$, Chr$(0)) - 1)
    Next
End Sub'判断是否在线
Public Function Online() As Boolean
    Online = InternetGetConnectedState(0&, 0&)
End Function
'判断是否在线并返回连接方式
Public Property Get OnlineOfLinkName(LinkName As String) As Boolean
    LinkName = Space$(128)
    OnlineOfLinkName = InternetGetConnectedStateEx(0, LinkName, 128, 0&)
End Property'如果是通过LAN的连接，则返回True
Public Function IsNetConnectViaLAN() As Boolean
    Dim dwFlags As Long
    Call InternetGetConnectedState(dwFlags, 0&)
    IsNetConnectViaLAN = dwFlags And INTERNET_CONNECTION_LAN
End Function
'如果是通过调制解调器的连接，则返回True
Public Function IsNetConnectViaModem() As Boolean
    Dim dwFlags As Long
    Call InternetGetConnectedState(dwFlags, 0&)
    IsNetConnectViaModem = dwFlags And INTERNET_CONNECTION_MODEM
End Function
'如果是通过Proxy代理服务器的连接，则返回True
Public Function IsNetConnectViaProxy() As Boolean
    Dim dwFlags As Long
    Call InternetGetConnectedState(dwFlags, 0&)
    IsNetConnectViaProxy = dwFlags And INTERNET_CONNECTION_PROXY
End Function
'如果已安装了RAS，则返回True
Public Function IsNetRASInstalled() As Boolean
    Dim dwFlags As Long
    Call InternetGetConnectedState(dwFlags, 0&)
    IsNetRASInstalled = dwFlags And INTERNET_RAS_INSTALLED
End Function
'返回当前网络状态信息字符串
Public Function GetNetConnectString() As String
    Dim dwFlags As Long
    Dim msg As String
    If InternetGetConnectedState(dwFlags, 0&) Then
        If dwFlags And INTERNET_CONNECTION_CONFIGURED Then
            msg = msg & "系统配置了网络连接" & vbCrLf
        End If
        If dwFlags And INTERNET_CONNECTION_LAN Then
            msg = msg & "系统通过局域网与因特网相连接"
        End If
        If dwFlags And INTERNET_CONNECTION_PROXY Then
            msg = msg & "并使用了Proxy代理服务"
        Else: msg = msg & "."
        End If
        If dwFlags And INTERNET_CONNECTION_MODEM Then
            msg = msg & "系统使用调制解调器与因特网相连接"
        End If
        If dwFlags And INTERNET_CONNECTION_OFFLINE Then
            msg = msg & "系统当前处于离线状态"
        End If
        If dwFlags And INTERNET_CONNECTION_MODEM_BUSY Then
            msg = msg & "系统的调制解调器未连接到因特网"
        End If
        If dwFlags And INTERNET_RAS_INSTALLED Then
            msg = msg & "本系统安装了远程访问服务"
        End If
    Else
        msg = "当前未与因特网相连"
    End If
    GetNetConnectString = msg
End Function

Answer 2

在系统中不存在VPN连接的情况下代码建立VPN连接。

Answer 3

看看这个代码，可惜就没有vpn的。楼主自己试一下吧，别忘了把结果发上来。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 = "宽带连接"
    sUsername = "super"
    sPassword = "greenbean"    If Create_PPPoE_Connection("PPPoE", 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)"
'    sDeviceType = "PPPoE"
'    sDeviceType = "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

Answer 4

如果有像sql server的事件探察器来探察windows的拨号连接建立过程就好了。

Answer 5

搞定了
If Create_PPPoE_Connection("PPPoE", sEntryName, sUsername, sPassword) Then
        MsgBox "连接建立成功！"
    Else
        MsgBox "连接建立失败！"
    End If
变成：
If Create_PPPoE_Connection("VPN", sEntryName, sUsername, sPassword) Then
        MsgBox "连接建立成功！"
    Else
        MsgBox "连接建立失败！"
    End If
就ok了
这个.dwType = 5  大于2就行了放几天结帖。

Answer 6

建立 VPN全部代码如下: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我再开个帖散分庆祝 来者有份,Modest(塞北雪貂)·(偶最欣赏楼主的分) 你一定来哦!