VB 实现 创建拨号连接，并进行拨号，断开拨号操作

Private Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'拨号/断网
  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 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

Private Sub Command1_Click()
    Call DialUp("htPPPoE")
End Sub

Private Sub Command2_Click()
    Call HangUp
End Sub

Private Sub Form_Load()
       Dim sEntryName As String, sUsername As String, sPassword As String
     
       GoTo pppoe

pppoe:
'创建PPPoE
       sEntryName = "htPPPoE"
       sUsername = "wangwb"
       sPassword = "123"
     
       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 Sub

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

   
  '拨号
  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

 

从网上找了好久，整理了一下，调试通过了，目前还有个问题，就是可以挂断连接，但是没法删除链接，正在找解决方法。