网上找了一个VB的拨号连接代码，贴上收藏

Option Explicit

''''''''''''''''''''''''''''''''

Public Const mod_strConnName_VPN = "VPN连接"

Public Const mod_ver_VPN = "1.0.0"



''''''''''''''''''''''''''''''''

Public hRasConn As Long '?¨ò?ò??????òRASμ÷ó?μ?è?????±ú

Public Const APINULL = 0&

Public Const UNLEN = 256

Public Const DNLEN = 15

Public Const PWLEN = 256

Public Const RAS95_MaxPhoneNumber = 128

Public Const RAS95_MaxEntryName = 256

Public Const RAS95_MaxCallbackNumber = RAS95_MaxPhoneNumber



Public Type RASDIALPARAMS95

    dwSize As Long

    szEntryName(RAS95_MaxEntryName) As Byte

    szPhoneNumber(RAS95_MaxPhoneNumber) As Byte

    szCallbackNumber(RAS95_MaxCallbackNumber) As Byte

    szUserName(UNLEN) As Byte

    szPassword(PWLEN) As Byte

    szDomain(DNLEN) As Byte

End Type

'**********************************

'* RASμ÷ó?′í?ó′úo? *

'**********************************

Public Const NOT_SUPPORTED = 120&

Public Const RASBASEERROR = 600&

Public Const SUCCESS = 0&

Public Const ERROR_PORT_ALREADY_OPEN = (RASBASEERROR + 2)

Public Const ERROR_UNKNOWN = (RASBASEERROR + 35)

Public Const ERROR_REQUEST_TIMEOUT = (RASBASEERROR + 38)

Public Const ERROR_PASSWD_EXPIRED = (RASBASEERROR + 48)

Public Const ERROR_NO_DIALIN_PERMISSION = (RASBASEERROR + 49)

Public Const ERROR_SERVER_NOT_RESPONDING = (RASBASEERROR + 50)

Public Const ERROR_UNRECOGNIZED_RESPONSE = (RASBASEERROR + 52)

Public Const ERROR_NO_RESPONSES = (RASBASEERROR + 60)

Public Const ERROR_DEVICE_NOT_READY = (RASBASEERROR + 66)

Public Const ERROR_LINE_BUSY = (RASBASEERROR + 76)

Public Const ERROR_NO_ANSWER = (RASBASEERROR + 78)

Public Const ERROR_NO_CARRIER = (RASBASEERROR + 79)

Public Const ERROR_NO_DIALTONE = (RASBASEERROR + 80)

Public Const ERROR_AUTHENTICATION_FAILURE = (RASBASEERROR + 91)

Public Const ERROR_PPP_TIMEOUT = (RASBASEERROR + 118)



'//

'Public Const RAS95_MaxEntryName = 256

Public Const RAS95_MaxDeviceName = 128

Public Const RAS_MaxDeviceType = 16



Public Type RASCONN95

    'set dwsize to 412

    dwSize As Long

    hRasConn As Long

    szEntryName(RAS95_MaxEntryName) As Byte

    szDeviceType(RAS_MaxDeviceType) As Byte

    szDeviceName(RAS95_MaxDeviceName) As Byte

End Type

'/







'**********************************

'* RAS API éù?÷ *

'**********************************

Public Declare Function lstrcpy Lib "KERNEL32" Alias "lstrcpyA" (lpString1 As Any, ByVal lpString2 As String) As Long

Public Declare Function RasDial Lib "RasApi32.DLL" Alias "RasDialA" (lpRasDialExtensions As Any, ByVal lpszPhonebook As String, lprasdialparams As Any, ByVal dwNotifierType As Long, lpvNotifier As Long, lphRasConn As Long) As Long

Public Declare Function RasHangUp Lib "RasApi32.DLL" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long

Public Declare Function RasEnumConnections Lib "RasApi32.DLL" Alias "RasEnumConnectionsA" (lprasconn As Any, lpcb As Long, lpcConnections As Long) As Long



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



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



Dim lprasconn95() As RASCONN95



'创建连接

Public Function Create_PPPoE_Connection(ByVal sDeviceType As String, ByVal sEntryName As String, ByVal sUsername As String, ByVal sPassword As String, Optional ByVal dwfOptions As Long = 1024262672) 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

        '111101000011010000001100010000

        '                            -  是否手动设置IP和DNS：0-自动，1-手动

        '                     _         决定是否在右下角显示托盘图标

        '                         -     决定是否使用服务器上的网关

        '.dwfOptions = 1024262928

        .dwfOptions = dwfOptions

        .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

 

Public Function AddConnection(strNewEntryName As String, strNewPhoneNumber As String, strNewCallbackNumber As String, strNewUsername As String, strNewPassword As String, strNewDomain As String) As Integer

    '拨号连接

   

    Dim lngRetCode As Long

    Dim lngRetLstrcpy As Long

    Dim lngRetHangUp As Long

    Dim lprasdialparams As RASDIALPARAMS95

   

    If IsConnectionByName(strNewEntryName) = True Then

        AddConnection = -1: Exit Function   '已连接

    End If

    lprasdialparams.dwSize = 1052 '?úWINDOWS95/98?D±?D???dwSizeéè?a1052

    'à?ó?lstrcpyoˉêy??×?·?′???±′μ?BYTEêy×é

    lngRetLstrcpy = lstrcpy(lprasdialparams.szEntryName(0), strNewEntryName)

    lngRetLstrcpy = lstrcpy(lprasdialparams.szPhoneNumber(0), strNewPhoneNumber)

    lngRetLstrcpy = lstrcpy(lprasdialparams.szCallbackNumber(0), strNewCallbackNumber)

    lngRetLstrcpy = lstrcpy(lprasdialparams.szUserName(0), strNewUsername)

    lngRetLstrcpy = lstrcpy(lprasdialparams.szPassword(0), strNewPassword)

    lngRetLstrcpy = lstrcpy(lprasdialparams.szDomain(0), strNewDomain)

    '?ò??ê1ó?í?2?í¨D?

    Screen.MousePointer = vbHourglass

    hRasConn = 0 '

    lngRetCode = RasDial(ByVal APINULL, vbNullString, lprasdialparams, APINULL, ByVal APINULL, hRasConn)

    Screen.MousePointer = vbDefault

    '2aê?óD??óD′í?ó

    If lngRetCode Then

        lngRetHangUp = RasHangUp(hRasConn)

    End If

    AddConnection = lngRetCode

End Function



Public Function GetConnections() As Integer

    '获取所有连接总数

    Dim lngRetCode As Long

    Dim lpcb As Long

    Dim lpcConnections As Long

    Dim intArraySize As Integer

   

    ReDim lprasconn95(intArraySize) As RASCONN95

    lprasconn95(0).dwSize = 412

    lpcb = 256 * lprasconn95(0).dwSize

    lngRetCode = RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)

   

   

   

    ' If lngRetCode = 0 Then

    ' End If

    GetConnections = lpcConnections

End Function



Public Function IsConnectionByName(ByVal strEntryName As String) As Boolean

    '判断某名称的连接是否已经存在

    Dim lngRetCode As Long

    Dim lpcb As Long

    Dim lpcConnections As Long

    Dim intArraySize As Integer

    Dim intLooper As Long

    Dim bszEntryName() As Byte, i%, bFind As Boolean

   

    ReDim bszEntryName(RAS95_MaxEntryName)

    ReDim lprasconn95(intArraySize) As RASCONN95

    lprasconn95(0).dwSize = 412

    lpcb = 256 * lprasconn95(0).dwSize

    lngRetCode = RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)

   

    lstrcpy bszEntryName(0), strEntryName

    IsConnectionByName = False

   

    If lngRetCode = 0 Then

        If lpcConnections > 0 Then

            For intLooper = 0 To lpcConnections - 1

                bFind = True

                For i = 0 To RAS95_MaxEntryName

                    If lprasconn95(intLooper).szEntryName(i) <> bszEntryName(i) Then

                        bFind = False

                        Exit For

                    End If

                Next

                If bFind = True Then

                    IsConnectionByName = True

                    Exit For

                End If

            Next

        End If

    End If

End Function



'/

Public Function HangUpAll() As Boolean

    '挂断所有连接

    Dim lngRetCode As Long

    Dim lpcb As Long

    Dim lpcConnections As Long

    Dim intArraySize As Integer

    Dim intLooper As Integer

   

    ReDim lprasconn95(intArraySize) As RASCONN95

    lprasconn95(0).dwSize = 412

    lpcb = 256 * lprasconn95(0).dwSize

    lngRetCode = RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)

   

    If lngRetCode = 0 Then

        If lpcConnections > 0 Then

            For intLooper = 0 To lpcConnections - 1

                RasHangUp lprasconn95(intLooper).hRasConn

                Exit For

            Next

        Else

            HangUpAll = False

            Exit Function

        End If

    End If

    HangUpAll = True

End Function

'/

Public Function HangUpByName(ByVal strEntryName As String) As Boolean

    '挂断指定名称连接

    Dim lngRetCode As Long

    Dim lpcb As Long

    Dim lpcConnections As Long

    Dim intArraySize As Integer

    Dim intLooper As Integer

    Dim bszEntryName() As Byte, i%, bHangUp As Boolean

   

    ReDim bszEntryName(RAS95_MaxEntryName)

   

    ReDim lprasconn95(intArraySize) As RASCONN95

    lprasconn95(0).dwSize = 412

    lpcb = 256 * lprasconn95(0).dwSize

    lngRetCode = RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)

    lstrcpy bszEntryName(0), strEntryName

   

    If lngRetCode = 0 Then

        If lpcConnections > 0 Then

            For intLooper = 0 To lpcConnections - 1

                bHangUp = True

                For i = 0 To RAS95_MaxEntryName

                    If lprasconn95(intLooper).szEntryName(i) <> bszEntryName(i) Then

                        bHangUp = False

                        Exit For

                    End If

                Next

                If bHangUp = True Then

                    RasHangUp lprasconn95(intLooper).hRasConn

                    HangUpByName = True

                    Exit For

                End If

            Next

        Else

            HangUpByName = False

            Exit Function

        End If

    End If

End Function







'/



Public Function GetErrMsg(ByVal intErr As Integer)

    '拨号错误码

    Select Case intErr

    Case -1

        GetErrMsg = "已连接，不能再连接一次。你可能需要重启电脑。"

    Case 605

        GetErrMsg = "无法设置端口信息。"

    Case 606

        GetErrMsg = "无法连接端口。"

    Case 617

        GetErrMsg = "端口或设备已断开连接。"

    Case 618

        GetErrMsg = "端口尚未打开。"

    Case 619, 628

        GetErrMsg = "端口已断开连接。"

    Case 621, 622, 623, 624, 625

        GetErrMsg = "不存在的连接！"

    Case 629

        GetErrMsg = "端口已由远程机器断开连接。"

    Case 634

        GetErrMsg = "无法在远程网络上注册您的计算机。"

    Case 642

        GetErrMsg = "您的一个 NetBIOS 名称已在远程网络上注册。"

    Case 646

        GetErrMsg = "不允许本帐户在此时间登录。"

    Case 647

        GetErrMsg = "帐户已禁用。"

    Case 648

        GetErrMsg = "该帐户的密码已过期。"

    Case 649

        GetErrMsg = "帐户没有远程访问权限。"

    Case 676

        GetErrMsg = "线路忙。"

    Case 678

        GetErrMsg = "远程计算机不可到达。"

    Case 691

        GetErrMsg = "由于域上的用户名和/或密码无效而拒绝访问。"

    Case 708

        GetErrMsg = "帐户已过期。"

    Case 709

        GetErrMsg = "在域上更改密码时出错。"

    Case 720

        GetErrMsg = "不能建立到远程计算机的连接。您可能需要更改些连接的网络设置。"

    Case 768

        GetErrMsg = "因为错误的加密数据造成连接请求失败。"

    Case 770

        GetErrMsg = "远程设备拒绝连接请求。"

    Case 771

        GetErrMsg = "因为网络忙造成连接请求失败。"

    Case 756

        GetErrMsg = "拔号连接正在进行。"

    Case 774

        GetErrMsg = "因为临时性错误导致连接请求失败。请再试着连接。"

    Case 775

        GetErrMsg = "连接被远程服务器阻止。"

    Case 800

        GetErrMsg = "不能建立连接。服务器可能不能到达，或者此连接的安全参数没有正确配置。"

    Case Else

        GetErrMsg = "没有更详细的错误信息！"

    End Select

End Function