用户登录  |  用户注册
首 页源码下载网络学院最新源码源码排行屏蔽广告
当前位置:新兴网络 > 网络学院 > 编程开发 > Visual Basic

VB VPN拨号连接模块代码

减小字体 增大字体 作者:佚名  来源:本站整理  发布时间:2011-01-03 10:02:37
VB VPN拨号连接源代码。
VBScript code复制代码
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

Tags:VPN 拨号 VB

作者:佚名
  • 好的评价 如果您觉得此文章好,就请您
      0%(0)
  • 差的评价 如果您觉得此文章差,就请您
      0%(0)

网络学院评论评论内容只代表网友观点,与本站立场无关!

   评论摘要(共 0 条,得分 0 分,平均 0 分) 查看完整评论