宜昌市葛洲坝中学图片:使用VB创建PPPoE以及VPN拨号连接的核心代码

'小小摸摸碴 cnoldjohn 收集整理

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 Type

Private Type RASIPADDR
        a   As Byte
        b   As Byte
        c   As Byte
        d   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 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           '   Broadband

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

Option 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

'拨号
Function DialUp(LinkName As String) As Boolean
    InternetDial 0, LinkName, INTERNET_AUTODIAL_FORCE_UNATTENDED, Handle, 0
    DialUp = (Handle <> 0)
End Function

Function 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