form1.frm

pppoe创建和加密

        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 Declare Function RasHangUp Lib "RasApi32.dll" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long
Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lprasconn As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Const RAS95_MaxEntryName = 256
Const RAS95_MaxDeviceName = 128
Const RAS_MaxDeviceType = 16
Const RAS95_MaxDeviceType = 16
Private 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

Private Type RASCONNSTATUS95
    dwSize As Long
    RasConnState As Long
    dwError As Long
    szDeviceType(RAS95_MaxDeviceType) As Byte
    szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Const INTERNET_DIALSTATE_DISCONNECTED = 1
Const INTERNET_AUTODIAL_FORCE_ONLINE = 1
Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2
Const INTERNET_DIAL_UNATTENDED = &H8000
Dim iHandle 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
   
'参数dwConnection指定拨号连接句柄
Private Declare Function InternetHangUp Lib "Wininet.dll" _
    (ByVal dwConnection As Long, _
    ByVal dwReserved As Long) As Long



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 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 Declare Function InternetOpen Lib "Wininet.dll" Alias "InternetOpenA" ( _
                    ByVal sAgent As String, ByVal lAccessType As Long, _
                    ByVal sProxyName As String, ByVal sProxyBypass As String, _
                    ByVal lFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "Wininet.dll" Alias "InternetOpenUrlA" ( _
                    ByVal hInternetSession As Long, ByVal sUrl As String, _
                    ByVal sHeaders As String, ByVal lHeadersLength As Long, _
                    ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadFile Lib "Wininet.dll" ( _
                    ByVal hFile As Long, ByVal sBuffer As String, _
                    ByVal lNumBytesToRead As Long, _
                    lNumberOfBytesRead As Long) As Integer
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000

Const INTERNET_OPEN_TYPE_DIRECT = 1
Const INTERNET_OPEN_TYPE_PROXY = 3
Const INTERNET_SERVICE_FTP = 1
Const FTP_TRANSFER_TYPE_BINARY = &H2
Const FTP_TRANSFER_TYPE_ASCII = &H1
 Const HKEY_CLASSES_ROOT = &H80000000
 Const HKEY_CURRENT_USER = &H80000001
 Const HKEY_LOCAL_MACHINE = &H80000002
 Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
 Const HKEY_CURRENT_CONFIG = &H80000005
 Const HKEY_DYN_DATA = &H80000006
 Const REG_NONE = 0
 Const REG_SZ = 1
 Const REG_EXPAND_SZ = 2
 Const REG_BINARY = 3
 Const REG_DWORD = 4
 Const REG_DWORD_BIG_ENDIAN = 5
 Const REG_MULTI_SZ = 7
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
Private Const INADDR_NONE As Long = &HFFFFFFFF




Private Const PING_TIMEOUT As Long = 500
Private Type ICMP_ECHO_REPLY
  Address         As Long
  status          As Long
  RoundTripTime   As Long
  DataSize        As Long
  DataPointer     As Long
  Data            As String * 250
End Type
Private Declare Function inet_addr Lib "WSOCK32.DLL" (ByVal s As String) As Long
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, _
    ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Long, _
    ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, _
    ByVal Timeout As Long) As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long

Private Declare Function SetProcessWorkingSetSize Lib "kernel32" (ByVal hProcess As Long, ByVal dwMinimumWorkingSetSize As Long, ByVal dwMaximumWorkingSetSize As Long) As Long
    Private Declare Function GetCurrentProcess Lib "kernel32" () As Long


Private Declare Function InternetConnect Lib "Wininet.dll" _
            Alias "InternetConnectA" _
            (ByVal hInternetSession As Long, _
             ByVal lpszServerName As String, _
             ByVal nProxyPort As Integer, _
             ByVal lpszUsername As String, _
             ByVal lpszPassword As String, _
             ByVal dwService As Long, _
             ByVal dwFlags As Long, _
             ByVal dwContext As Long) As Long


   Private Declare Function HttpOpenRequest Lib "Wininet.dll" _
            Alias "HttpOpenRequestA" _
            (ByVal hInternetSession As Long, _
             ByVal lpszVerb As String, _
             ByVal lpszObjectName As String, _
             ByVal lpszVersion As String, _
             ByVal lpszReferer As String, _
             ByVal lpszAcceptTypes As Long, _
             ByVal dwFlags As Long, _
             ByVal dwContext As Long) As Long

   Private Declare Function HttpSendRequest Lib "Wininet.dll" _
            Alias "HttpSendRequestA" _
            (ByVal hHttpRequest As Long, _
             ByVal sHeaders As String, _
             ByVal lHeadersLength As Long, _
             ByVal sOptional As String, _
             ByVal lOptionalLength As Long) As Boolean

   Private Declare Function InternetCloseHandle Lib "Wininet.dll" _
            (ByVal hInternetHandle As Long) As Boolean

   Private Declare Function HttpAddRequestHeaders Lib "Wininet.dll" _
             Alias "HttpAddRequestHeadersA" _
             (ByVal hHttpRequest As Long, _
             ByVal sHeaders As String, _
             ByVal lHeadersLength As Long, _
             ByVal lModifiers As Long) As Integer


Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lPBuffer As Long, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function ReadFileA Lib "kernel32" Alias "ReadFile" (ByVal hFile As Long, ByVal lPBuffer As String, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hHandle As Long) As Long

Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Private Type STARTUPINFO
    cb As Long
    lpReserved As Long
    lpDesktop As Long
    lpTitle As Long
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessID As Long
    dwThreadID As Long
End Type


Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

Private Const INFINITE = -1&
Private Const SYNCHRONIZE = &H100000
Dim iTask As Long, gret As Long, pHandle As Long
Private Type NOTIFYICONDATA
    cbSize As Long
    hwnd As Long
    uId As Long
    uFlags As Long
    ucallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type

Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const WM_MOUSEMOVE = &H200
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Declare Function GetPrivateProfileString Lib "kernel32" _
   Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
   ByVal lpKeyName As Any, ByVal lpDefault As String, _
   ByVal lpReturnedString As String, ByVal nSize As Long, _
   ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" _
   Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
   ByVal lpKeyName As Any, ByVal lpString As String, _
   ByVal lpFileName As String) As Long
Dim f1, ll1, ppzt, pprun, update, acturl, actkey, activeppoe
Dim t As NOTIFYICONDATA

Function KeyED(txt, keyss)


     encrypt_key = MD5(keyss)
             ctr = 1
             tmp = ""
             For i = 1 To Len(txt)
                 If ctr > Len(encrypt_key) Then
                             ctr = 1
                     End If
                     tmp = tmp & Chr(Asc(Mid(txt, i, 1)) Xor Asc(Mid(encrypt_key, ctr, 1)))
                     ctr = ctr + 1
             Next


             KeyED = tmp


End Function


Function Encrypt(txt, keyss)
Dim dih As New Class1
On Error Resume Next
     Randomize (CDbl(Timer()))
             encrypt_key = MD5(((32000 * Rnd) + 0))
             tmp = ""
             ctr = 1
             txt = dih.Base64Encode(CStr(txt))
             For i = 1 To Len(txt)
             If ctr > Len(encrypt_key) Then
                             ctr = 1
                     End If
             
             tmp = tmp & Mid(encrypt_key, ctr, 1) & Chr(Asc(Mid(txt, i, 1)) Xor Asc(Mid(encrypt_key, ctr, 1)))
              ctr = ctr + 1
             Next



             Encrypt = dih.Base64Encode(KeyED(tmp, keyss))


End Function



Function Decrypt(txt2 As String, keyss As String)
Dim dih As New Class1

    txt = dih.Base64Decode(txt2)
     txt = KeyED(txt, keyss)
    
     tmp = ""
     For i = 1 To Len(txt) - 3
             keyss = Mid(txt, i, 1)
             i = i + 1
             tmp = tmp & (Chr(Asc(Mid(txt, i, 1)) Xor Asc(keyss)))
     Next
     Decrypt = dih.Base64Decode(CStr(tmp))


End Function

Function DialUp(LinkName As String) As Boolean

    InternetDial 0, LinkName, INTERNET_AUTODIAL_FORCE_UNATTENDED, iHandle, 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