Option Explicit

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
Private Const RAS_MaxDeviceType = 16
Private Const RAS95_MaxDeviceName = 128
Public Const RAS95_MaxCallbackNumber = RAS95_MaxPhoneNumber
Public Type RASCONN95
    dwSize As Long
    hRasConn As Long
    szEntryName(RAS95_MaxEntryName) As Byte
    szDeviceType(RAS_MaxDeviceType) As Byte
    szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Public Type RASENTRYNAME95
    dwSize As Long
    szEntryName(RAS95_MaxEntryName) As Byte
End Type
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调用错误代号 *
'**********************************
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)
'**********************************
'* RAS连接状态声明 *
'**********************************
Enum RasConnState
    RASCS_OpenPort = 0
    RASCS_PortOpened             '1
    RASCS_ConnectDevice          '2
    RASCS_DeviceConnected        '3
    RASCS_AllDevicesConnected    '4
    RASCS_Authenticate           '5
    RASCS_AuthNotify             '6
    RASCS_AuthRetry
    RASCS_AuthCallback
    RASCS_AuthChangePassword
    RASCS_AuthProject
    RASCS_AuthLinkSpeed
    RASCS_AuthAck
    RASCS_ReAuthenticate
    RASCS_Authenticated
    RASCS_PrepareForCallback
    RASCS_WaitForModemReset
    RASCS_WaitForCallback
    RASCS_Projected
    RASCS_StartAuthentication  '19
    RASCS_CallbackComplete
    RASCS_LogonNetwork         '21
    RASCS_Interactive = &H1000
    RASCS_RetryAuthentication
    RASCS_CallbackSetByCaller
    RASCS_PasswordExpired
    rascs_connected = &H2000
    RASCS_Disconnected
End Enum
'**********************************
'* 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, ByVal lpvNotifier As Long, lphRasConn As Long) As Long
Public Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" (lprasconn As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasEnumEntries Lib "rasapi32.dll" Alias "RasEnumEntriesA" (ByVal reserved As String, ByVal lpszPhonebook As String, lprasentryname As Any, lpcb As Long, lpcEntries As Long) As Long
Public Declare Function RasHangUp Lib "rasapi32.dll" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long


'Sleep
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
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 GetConnections() > 0 Then
Form1.Label11.Caption = "已连接，不能再连接一次,如需连接请先挂断。"
= False
= True
AddConnection = lngRetCode: Exit Function
End If
lprasdialparams.dwSize = 1052
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)
Screen.MousePointer = vbHourglass '改变鼠标样式
hRasConn = 0
 DoEvents
'若使用以下CallBack function的方式，则RasDial()不等连线成功或失败便结束。
           lngRetCode = RasDial(ByVal APINULL, vbNullString, lprasdialparams, 0, AddressOf RasDialFunc, hRasConn) '异步通信
'若第二、三个叁数都是0则，RasDial会等连线成功或失败後才执行下一行指令
          'lngRetCode = RasDial(ByVal APINULL, vbNullString, lprasdialparams, APINULL, ByVal APINULL, hRasConn)
 DoEvents
 Screen.MousePointer = vbDefault '改变鼠标样式
'测试有没有错误
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 Sub RemoveConnection()
    Dim s As Long, L As Long, ln As Long, a$, RasConn As Long, Ret As Long

    ReDim R(255) As RASCONN95

    R(0).dwSize = 412
    s = 256 * R(0).dwSize
    L = RasEnumConnections(R(0), s, ln)
    For L = 0 To ln - 1
        a$ = StrConv(R(L).szEntryName(), vbUnicode)
        a$ = left$(a$, InStr(a$, Chr$(0)) - 1)
        RasConn = R(L).hRasConn
        '这里将挂断连接
        Ret = RasHangUp(ByVal RasConn)
        Sleep (2000)
    Next
End Sub

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 Sub RasDialFunc(ByVal unMsg As Long, ByVal ConnState As Long, ByVal dwError As Long)
Select Case ConnState
  
    Case RASCS_OpenPort
       Form1.Label11.Caption = "正在打开端口......"
    Case RASCS_PortOpened
       Form1.Label11.Caption = "端口已打开。"
    Case RASCS_ConnectDevice
        Form1.Label11.Caption = "正在连接设备......"
    Case RASCS_DeviceConnected
        Form1.Label11.Caption = "设备已连接。"
    Case RASCS_AllDevicesConnected
       Form1.Label11.Caption = "所有设备均已连接。"
    Case RASCS_Authenticate
        Form1.Label11.Caption = "验证用户名及密码......"
    Case RASCS_AuthNotify
       Form1.Label11.Caption = "验证通告......"
    Case RASCS_AuthRetry
       Form1.Label11.Caption = "验证重试......"
    Case RASCS_AuthCallback
       Form1.Label11.Caption = "验证回叫......"
    Case RASCS_AuthChangePassword
       Form1.Label11.Caption = "RASCS_AuthChangePassword"
    Case RASCS_AuthProject
       Form1.Label11.Caption = "验证项目......"
    Case RASCS_AuthLinkSpeed
       Form1.Label11.Caption = "验证连接速度......"
    Case RASCS_AuthAck
       Form1.Label11.Caption = "验证请求......"
    Case RASCS_ReAuthenticate
       Form1.Label11.Caption = "重新验证......"
    Case RASCS_Authenticated
       Form1.Label11.Caption = "验证完成！"
    Case RASCS_PrepareForCallback
       Form1.Label11.Caption = "准备回叫"
    Case RASCS_WaitForModemReset
       Form1.Label11.Caption = "等待调制解调器复位......"
    Case RASCS_WaitForCallback
       Form1.Label11.Caption = "等待回叫......"
    Case RASCS_Projected
       Form1.Label11.Caption = "RASCS_Projected"
    Case RASCS_StartAuthentication
       Form1.Label11.Caption = "开始鉴定......"
    Case RASCS_CallbackComplete
       Form1.Label11.Caption = "回叫完成！"
    Case RASCS_LogonNetwork
       Form1.Label11.Caption = "正在登录网络......"
    Case RASCS_Interactive
       Form1.Label11.Caption = "连接已经成功！"
    Case RASCS_RetryAuthentication
       Form1.Label11.Caption = "重新鉴定......"
    Case RASCS_CallbackSetByCaller
       Form1.Label11.Caption = "设置回叫......"
    Case RASCS_PasswordExpired
       Form1.Label11.Caption = "口令错误！"
    Case rascs_connected
       Form1.Label11.Caption = "连接成功！"
= False
= True
call start
Exit Sub
    Case RASCS_Disconnected
       Form1.Label11.Caption = "连接已断开！"
End Select

Select Case dwError

    Case 605
         Form1.Label11.Caption = dwError & "错误:无法设置端口信息。"
    Case 606
         Form1.Label11.Caption = dwError & "错误:无法连接端口。"
    Case 617
         Form1.Label11.Caption = dwError & "错误:端口或设备已断开连接。"
    Case 618
         Form1.Label11.Caption = dwError & "错误:端口尚未打开。"
    Case 619, 628
         Form1.Label11.Caption = dwError & "错误:端口已断开连接。"
    Case 621, 622, 623, 624, 625
         Form1.Label11.Caption = dwError & "错误:不存在的连接！"
    Case 629
        Form1.Label11.Caption = dwError & "错误:端口已由远程机器断开连接。"
    Case 633, 651, 734
        Form1.Label11.Caption = dwError & "错误:调制解调器（其他设备）已在使用。"
    Case 634
         Form1.Label11.Caption = dwError & "错误:无法在远程网络上注册您的计算机。"
    Case 642
         Form1.Label11.Caption = dwError & "错误:您的一个 NetBIOS 名称已在远程网络上注册。"
    Case 646
         Form1.Label11.Caption = dwError & "错误:不允许本帐户在此时间登录。"
    Case 647
         Form1.Label11.Caption = dwError & "错误:帐户已禁用。"
    Case 648
         Form1.Label11.Caption = dwError & "错误:该帐户的密码已过期。"
    Case 649
         Form1.Label11.Caption = dwError & "错误:帐户没有远程访问权限。"
    Case 676
         Form1.Label11.Caption = dwError & "错误:线路忙。"
    Case 678, 809
         Form1.Label11.Caption = dwError & "错误:远程计算机没有响应或者连接被远程计算机终止。"
    Case 691
         Form1.Label11.Caption = dwError & "错误:用户名和/或密码无效而拒绝访问或电信VPDN到期,请续费!"
    Case 708
         Form1.Label11.Caption = dwError & "错误:帐户已过期。"
    Case 709
         Form1.Label11.Caption = dwError & "错误:在域上更改密码时出错。"
    Case 734
         Form1.Label11.Caption = dwError & "错误:PPP协议控制终止。"
    Case 741
         Form1.Label11.Caption = dwError & "错误:核对属性设置是否正确。"
    Case 720
         Form1.Label11.Caption = dwError & "错误:不能建立到远程计算机的连接。您可能需要更改些连接的网络设置。"
    Case 768
         Form1.Label11.Caption = dwError & "错误:因为错误的加密数据造成连接请求失败。"
    Case 769
         Form1.Label11.Caption = dwError & "错误:服务器IP出错。"
    Case 770
         Form1.Label11.Caption = dwError & "错误:远程设备拒绝连接请求。"
    Case 771
         Form1.Label11.Caption = dwError & "错误:因为网络忙造成连接请求失败。"
    Case 756
         Form1.Label11.Caption = dwError & "错误:拔号连接正在进行。"
    Case 774
         Form1.Label11.Caption = dwError & "错误:因为临时性错误导致连接请求失败。请再试着连接。"
    Case 775
         Form1.Label11.Caption = dwError & "错误:连接被远程服务器阻止。"
    Case 781, 789
         Form1.Label11.Caption = dwError & "错误:L2TP连接尝试失败,请运行基本设置下的注册表修改,然后重启电脑!"
    Case Else
        If dwError <> 0 Then Form1.Label11.Caption = dwError & "没有更详细的错误信息,拨号失败,重拨!"
End Select
End Sub

start代码如下


Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetIpAddrTable Lib "IPHlpApi" (pIPAdrTable As Byte, pdwSize As Long, ByVal Sort As Long) As Long

'获取IP地址
Private Const MAX_IP = 255

Private Type IPINFO
            dwAddr   As Long    'IP地址
            dwIndex   As Long
            dwMask   As Long    '掩码
            dwBCastAddr   As Long    '广播地址
            dwReasmSize   As Long
            unused1   As Integer
            unused2   As Integer
End Type


Private Type MIB_IPADDRTABLE
            dEntrys   As Long
            mIPInfo(MAX_IP)   As IPINFO
End Type
Private Type IP_Array
            mBuffer   As MIB_IPADDRTABLE
            BufferLen   As Long
End Type
Dim strIP     As String


Private Function ConvertAddressToString(longAddr As Long) As String
    Dim myByte(3)     As Byte
    Dim Cnt     As Long
    CopyMemory myByte(0), longAddr, 4
    For Cnt = 0 To 3
        ConvertAddressToString = ConvertAddressToString + CStr(myByte(Cnt)) + "."
    Next Cnt
    ConvertAddressToString = left$(ConvertAddressToString, Len(ConvertAddressToString) - 1)
End Function
Public Sub Start()

    Dim Ret     As Long, Tel       As Long
    Dim bBytes()     As Byte
    Dim Listing     As MIB_IPADDRTABLE

    On Error GoTo END1
    GetIpAddrTable ByVal 0&, Ret, True

    If Ret <= 0 Then Exit Sub

    ReDim bBytes(0 To Ret - 1) As Byte

    GetIpAddrTable bBytes(0), Ret, False
    CopyMemory Listing.dEntrys, bBytes(0), 4

    For Tel = 0 To Listing.dEntrys - 1
 CopyMemory Listing.mIPInfo(Tel), bBytes(4 + (Tel * Len(Listing.mIPInfo(0)))), Len(Listing.mIPInfo(Tel))
If InStr(1, ConvertAddressToString(Listing.mIPInfo(Tel).dwAddr), "10.26") > 0 Or InStr(1, ConvertAddressToString(Listing.mIPInfo(Tel).dwAddr), "10.6") > 0 Or InStr(1, ConvertAddressToString(Listing.mIPInfo(Tel).dwAddr), "10.86") > 0 Then
 strIP = ConvertAddressToString(Listing.mIPInfo(Tel).dwAddr)
        End If
    Next
Shell "route -p add 102.0.0.1 mask 255.255.255.0 " & strIP, vbHide
    Exit Sub
END1:
    MsgBox "ERROR"
   
End Sub