贴一个收藏很久的创建VPN拨号连接的源码，版权归原作者所有。

Option Explicit Private Type RASIPADDR a As Byte b As Byte c As Byte d As Byte End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) 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 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 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 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 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 Long 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

发表于 @ 2009年06月05日　21:50:00 | 评论( loading... ) | 编辑| 举报| 收藏

旧一篇:《职业素养》 | 新一篇:WCF中使用Session