Free 50h - compteur internet multi-postes

Soyez le premier à donner votre avis sur cette source.

Vue 5 495 fois - Téléchargée 432 fois

Description

Vous vous trainez encore votre vieux forfait 50h chez free ?
Tant mieux car ce petit compteur vous sera fort utile !
Plustot que de se contenter de l'a peu pres des compteur internet qui doivent etre ouvert en permanance pour deduire le temps consomé et qui sont totalement obsolet si vous utilisez votre connection sur plusieurs ordinateur différent, ce compteur se connecte directement a la page de free et recupere votre temps de connexion restante depuis votre derniere connection.

Avantages :
- Multipost : vous pouvez vous servire de ce compteur sur plusieur PC se connectant directement a Free par modem
- Pas besoin de laisser ce compteur ouvert en permanance ! vous l'ouvrez que quand vous voulez connaitre votre temps restant !
- Il enregistre votre Nom d'utilisateur et votre mot de passe Free pour les fois suivantes ou vous vous en servez.
- Un bouton vous envoi directement sur la page des détail de votre suivi conso.

Inconvéniants :
- Ne marche que pour Free 50h
- Ne marchera plus si Free change la page de suivi conso

Le principale avantage de ce compteur est de ne pas avoir a aller sur le site de free a chaques fois que vous voulez connaitre votre temps restant et aussi de ne pas avoir besoin de se souvenir de son mot de passe Free...

Je vous conseille de télécharger le Zip,
sinon vous avez besoin de :

3 labels :
- label1 : affichage du status
- label2 : Mode Offline (dans la frame2)
- label3 : Mode Offline (dans la frame2)
2 textboxs :
- text1 : le nom d'utilisateur (dans la frame1)
- text 2 : le mot de passe (dans la frame1)
1 checkbox :
- check1 : enregistrement des para mètres
1 winsock :
- winsock1 : pour la connection
2 frames :
- frame1 : mode connecté
- frame2 : mode offline
1 timer :
- timer1 : pour verifier le status de la connexion
2 commandbuttons :
- command1
- command2
MAJ :
Le mot de passe et le nom d'utilisateurs sont maintenant stokés cryptés dans le registre pour plus de securitée.

Source / Exemple :


'DANS LA FORM

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" (ByRef lpSFlags As Long, ByVal lpszConnectionName As String, ByVal dwNameLen As Long, ByVal dwReserved As Long) As Long

Private Const MAX_COMPUTERNAME_LENGTH As Long = 31
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Const G = """"
Private Const Mark = "<TD>Temps consommé dans votre forfait :</TD> <TD align=" & G & "center" & G & "><B>"
Private Const Hors = "Coût conso hors forfait :</TD><TD align=center><B>"
Private Const Htim = "Temps de connexion hors forfait :</TD> <TD align=center><B>"
Private Const Host = "conso.freetelecom.fr"
Private Const TimeOut = 30

Dim HTML As String, PassWord As String, Auto As Boolean, CN As String, TimeCnt As Integer
Dim LastCon As String

'INTERFACE
Private Sub Command1_Click()
On Error GoTo err
If Stat = True Then
    If Frame2.Visible And Not IsFiled Then
        Frame2.Visible = False
        Label1.Caption = "Prêt"
        Exit Sub
    End If
    If IsFiled Then
        Timer1.Enabled = True 'activation du time Out
        Command1.Visible = False
        Label1.Caption = "Connexion en cours..."
        Winsock1.RemoteHost = Host
        Winsock1.RemotePort = 80
        
        Winsock1.Connect
    Else
        MsgBox "Veuillez remplire les informations de connexion !", vbExclamation + vbOKOnly, "Attention !"
    End If
    Frame2.Visible = False
Else
    Frame2.Visible = True
    If Not Auto Then MsgBox "Vous devez être connecté a internet !", vbExclamation + vbOKOnly, "Attention !"
    If LastCon <> "" Then
        'Affichage du dernier Stat sauvegarder
        Label1.Caption = LastCon
    Else 'Sinon
        Label1.Caption = "Connexion à internet requise"
    End If
    Auto = False
End If
Exit Sub
err:
Label1.Caption = "WSK open Error " & Error(err)
Resume Next
End Sub
Private Sub Command2_Click()
ShellExecute hWnd, "Open", "http://" & Host & "/conso.pl?login=" & Text1.Text & "&passwd=" & PassWord, "", App.Path, vbNormalFocus
End Sub
Private Sub Form_Load()
On Error GoTo e

CN = ComputerName()

Caption = Caption & " v" & App.Major & "." & App.Minor & " (b" & App.Revision & ")"
LastCon = GetSetting("FREE50", "infos", "last")
If GetSetting("FREE50", "infos", "isreg", "0") <> 0 Then
    Check1.Value = 1
    Dim AES As New CRijndael
    Text1.Text = AES.JustDécrypter(GetSetting("FREE50", "infos", "login"), CN)
    Text2.Text = "--- PassWord Enregistré ---"
    PassWord = AES.JustDécrypter(GetSetting("FREE50", "infos", "passw"), CN & Text1.Text)
    Auto = True
    Call Command1_Click
ElseIf Not Stat Then 'Si pas d'infos sauvé et offline
    Frame2.Visible = True
    Label1.Caption = LastCon
End If
Exit Sub
e:
Text2.Text = "Mot de passe"
End Sub
Private Sub Form_Unload(Cancel As Integer)
If IsFiled And Check1.Value = 1 Then
    SaveSetting "FREE50", "infos", "isreg", "1"
    
    Dim AES As New CRijndael
    SaveSetting "FREE50", "infos", "login", AES.JustCrypter(Text1.Text, CN)
    If Text2.Text <> "--- PassWord Enregistré ---" Then
        SaveSetting "FREE50", "infos", "passw", AES.JustCrypter(Text2.Text, CN & Text1.Text)
    End If
End If
End Sub
Private Sub Text1_GotFocus()
If Text1.Text = "login Free (votre n° de téléphone)" Then Text1.Text = ""
End Sub
Private Sub Text1_LostFocus()
If Text1.Text = "" Then Text1.Text = "login Free (votre n° de téléphone)"
End Sub
Private Sub Text2_Change()
PassWord = Text2.Text
End Sub
Private Sub Text2_GotFocus()
If Text2.Text = "Mot de passe" Or Text2.Text = "--- PassWord Enregistré ---" Then
    Text2.Text = ""
    Text2.PasswordChar = "*"
End If
End Sub
Private Sub Text2_LostFocus()
If Text2.Text = "" Then
    Text2.PasswordChar = ""
    Text2.Text = "Mot de passe"
End If
End Sub
Private Sub Timer1_Timer()
TimeCnt = TimeCnt + 1
If TimeCnt = TimeOut Then
    Timer1.Enabled = False
    Winsock1.Close
    TimeCnt = 0
    Command1.Caption = "Réesayer"
    Command1.Visible = True
    Label1.Caption = "Time Out (>30s)"
    MsgBox "La connexion au serveur n'a pu être établie dans le délai impartis," & vbCrLf & "Le serveur, ou votre connexion peuvent être a l'origine de ce probleme", vbCritical + vbOKOnly, "Time Out !"
Else
    Label1.Caption = "Connexion en cours... (" & TimeCnt & "s)"
End If
End Sub

'SOCKET FUNCTIONS
Private Sub Winsock1_Close()
On Error GoTo err
Dim Start As Integer, EndPos As Integer, Conso As String, ErrCode As Boolean
Dim H, m, S, Min, Sec, Hour

Label1.Caption = "Parsing..."
Start = InStr(HTML, Mark) + Len(Mark)
If Start <> 67 Then
    buff = Mid(HTML, Start, Len(HTML) - Start) 'Text1.Text
    EndPos = InStr(buff, "</B></TD>") - 1
    Conso = Mid(buff, 1, EndPos) 'temps consomé HTML
    'On parse l'heure, les min et sec du temps consomé
    H = Val(Left(Conso, InStr(Conso, "h") - 1))
    m = Val(Mid(Conso, InStr(Conso, "h") + 1, InStr(Conso, "m") - (InStr(Conso, "h") + 1)))
    S = Val(Mid(Conso, InStr(Conso, "m") + 1, InStr(Conso, "s") - (InStr(Conso, "m") + 1)))
    'On transforme les H:M:S en secondes et on deduit le temps restant (en sec)
    rest = 180000 - (H * 3600 + m * 60 + S)
    If rest > 0 Then
        'On transforme les secondes en H:M:S
        Min = Int(rest / 60)
        Sec = Format(rest - (60 * Min), "0#") 'reste de secondes
        Hour = Format(Int(Min / 60), "0#") 'heures
        Min = Format(Min - 60 * Hour, "0#") 'reste de minutes
        
        Label1.Caption = "Il vous reste " & Hour & "h" & Min & "m" & Sec & "s" & " (Conso = " & Conso & ")"
    Else 'Hors Forfai
        Start = InStr(HTML, Hors) + Len(Hors)
        If Start <> Len(Hors) Then
            buff = Mid(HTML, Start, Len(HTML) - Start) 'Text1.Text
            Conso = Replace(Replace(Left(buff, InStr(buff, "€")), vbCrLf, ""), ".", ",")
            
            Start = InStr(HTML, Htim) + Len(Htim)
            If Start <> Len(Htim) Then
                buff = Mid(HTML, Start, Len(HTML) - Start)
                Conso = Conso & " (+ " & Left(buff, InStr(buff, "</B>") - 1) & ")"
                Label1.Caption = "Hors Forfait " & Conso
            Else
                ErrCode = True
            End If
        Else
            ErrCode = True
        End If
    End If
    'Label1.Caption = "Il vous reste " & 50 - h - 1 & "h" & 60 - M - 1 & "m" & 60 - S & "s (" & Conso & ")"
    Command2.Visible = True
    'Sauvegarde du status dans le Registre
    SaveSetting "FREE50", "infos", "last", Label1.Caption
Else
    ErrCode = True
End If
If ErrCode Then
    Label1.Caption = "Erreur de Parsing"
    Command1.Visible = True
    Winsock1.Close
End If
Exit Sub
err:
Label1.Caption = "WSK close Error " & Error(err)
Resume Next
End Sub
Private Sub Winsock1_Connect()
On Error GoTo err

    Timer1.Enabled = False 'On désactive le time out
    Label1.Caption = "Requêtte..."
    Dim CommandeHTTP As String
    Dim URLPageWeb As String

    URLPageWeb = "/conso.pl?login=" & Text1.Text & "&passwd=" & PassWord
    'URLPageWeb = "/labo/free/conso.pl.good.htm"
    CommandeHTTP = "GET " & URLPageWeb & " HTTP/1.0" & vbCrLf & "Accept: */*" & vbCrLf & "Accept: text/html" & vbCrLf & vbCrLf
    
    Winsock1.SendData CommandeHTTP

Exit Sub
err:
Label1.Caption = "WSK connect Error " & Error(err)
Resume Next
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
On Error GoTo err

    Label1.Caption = "Reception des données en cours..."
    Dim HTTPDonnees As String
    Winsock1.GetData HTTPDonnees, vbString
    HTML = HTML & Replace(HTTPDonnees, Chr(10), vbCrLf)

Exit Sub
err:
Label1.Caption = "WSK dataIn Error " & Error(err)
Resume Next
End Sub

'FUNCTIONS
'Public Function Convtime(Secondes) As String
'Dim min, sec, h, day
''Convtime = Secondes
'min = Int(Secondes / 60)
'sec = Secondes - (60 * min) 'reste de secondes
'h = Int(min / 60) 'heures
'min = min - 60 * h 'reste de minutes
''day = Int(h / 24) 'jours
''h = h - 24 * day 'reste des heures
'Convtime = h & "h" & min & "m" & sec & "s"
'End Function
Function ComputerName() As String
Dim dwLen As Long, strString As String
dwLen = MAX_COMPUTERNAME_LENGTH + 1
strString = String(dwLen, "X")
GetComputerName strString, dwLen
strString = Left(strString, dwLen)
ComputerName = strString
End Function
Function IsFiled() As Boolean
If Text1.Text <> "" And Text1.Text <> "login Free (votre n° de téléphone)" And Text2.Text <> "" And Text2.Text <> "Mot de passe" Then IsFiled = True
End Function
Private Function Stat() As Boolean
' Cette fonction vérifie si une connexion internet est active
Dim lgLen As Long, lgFlags As Long
'Dim blConnected As Boolean
lgLen = 256
stNomConnexion = Space$(lgLen)
Stat = InternetGetConnectedStateEx(lgFlags, stNomConnexion, lgLen, 0&)
End Function

'DANS UN MODULE DE CLASSE 'CRijndael'

'*******************************************************************************
' MODULE:       CRijndael
' FILENAME:     CRijndael.cls
' AUTHOR:       Phil Fresle
' CREATED:      16-Feb-2001
' COPYRIGHT:    Copyright 2001 Phil Fresle
' EMAIL:        phil@frez.co.uk
' WEB:          http://www.frez.co.uk
'
' DESCRIPTION:
' Implementation of the AES Rijndael Block Cipher. Inspired by Mike Scott's
' implementation in C. Permission for free direct or derivative use is granted
' subject to compliance with any conditions that the originators of the
' algorithm place on its exploitation.
'
' MODIFICATION HISTORY:
' 16-Feb-2001   Phil Fresle     Initial Version
' 03-Apr-2001   Phil Fresle     Added EncryptData and DecryptData functions to
'                               make it easier to use by VB developers for
'                               encrypting and decrypting strings. These procs
'                               take large byte arrays, the resultant encoded
'                               data includes the message length inserted on
'                               the front four bytes prior to encryption.
' 19-Apr-2001   Phil Fresle     Thanks to Paolo Migliaccio for finding a bug
'                               with 256 bit key. Problem was in the gkey
'                               function. Now properly matches NIST values.
'*******************************************************************************
Option Explicit

Private m_lOnBits(30)   As Long
Private m_l2Power(30)   As Long
Private m_bytOnBits(7)  As Byte
Private m_byt2Power(7)  As Byte

Private m_InCo(3) As Byte

Private m_fbsub(255)    As Byte
Private m_rbsub(255)    As Byte
Private m_ptab(255)     As Byte
Private m_ltab(255)     As Byte
Private m_ftable(255)   As Long
Private m_rtable(255)   As Long
Private m_rco(29)       As Long

Private m_Nk        As Long
Private m_Nb        As Long
Private m_Nr        As Long
Private m_fi(23)    As Byte
Private m_ri(23)    As Byte
Private m_fkey(119) As Long
Private m_rkey(119) As Long

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

'*******************************************************************************
' Class_Initialize (SUB)
'*******************************************************************************
Private Sub Class_Initialize()
    m_InCo(0) = &HB
    m_InCo(1) = &HD
    m_InCo(2) = &H9
    m_InCo(3) = &HE
    
    ' Could have done this with a loop calculating each value, but simply
    ' assigning the values is quicker - BITS SET FROM RIGHT
    m_bytOnBits(0) = 1          ' 00000001
    m_bytOnBits(1) = 3          ' 00000011
    m_bytOnBits(2) = 7          ' 00000111
    m_bytOnBits(3) = 15         ' 00001111
    m_bytOnBits(4) = 31         ' 00011111
    m_bytOnBits(5) = 63         ' 00111111
    m_bytOnBits(6) = 127        ' 01111111
    m_bytOnBits(7) = 255        ' 11111111
    
    ' Could have done this with a loop calculating each value, but simply
    ' assigning the values is quicker - POWERS OF 2
    m_byt2Power(0) = 1          ' 00000001
    m_byt2Power(1) = 2          ' 00000010
    m_byt2Power(2) = 4          ' 00000100
    m_byt2Power(3) = 8          ' 00001000
    m_byt2Power(4) = 16         ' 00010000
    m_byt2Power(5) = 32         ' 00100000
    m_byt2Power(6) = 64         ' 01000000
    m_byt2Power(7) = 128        ' 10000000
    
    ' Could have done this with a loop calculating each value, but simply
    ' assigning the values is quicker - BITS SET FROM RIGHT
    m_lOnBits(0) = 1            ' 00000000000000000000000000000001
    m_lOnBits(1) = 3            ' 00000000000000000000000000000011
    m_lOnBits(2) = 7            ' 00000000000000000000000000000111
    m_lOnBits(3) = 15           ' 00000000000000000000000000001111
    m_lOnBits(4) = 31           ' 00000000000000000000000000011111
    m_lOnBits(5) = 63           ' 00000000000000000000000000111111
    m_lOnBits(6) = 127          ' 00000000000000000000000001111111
    m_lOnBits(7) = 255          ' 00000000000000000000000011111111
    m_lOnBits(8) = 511          ' 00000000000000000000000111111111
    m_lOnBits(9) = 1023         ' 00000000000000000000001111111111
    m_lOnBits(10) = 2047        ' 00000000000000000000011111111111
    m_lOnBits(11) = 4095        ' 00000000000000000000111111111111
    m_lOnBits(12) = 8191        ' 00000000000000000001111111111111
    m_lOnBits(13) = 16383       ' 00000000000000000011111111111111
    m_lOnBits(14) = 32767       ' 00000000000000000111111111111111
    m_lOnBits(15) = 65535       ' 00000000000000001111111111111111
    m_lOnBits(16) = 131071      ' 00000000000000011111111111111111
    m_lOnBits(17) = 262143      ' 00000000000000111111111111111111
    m_lOnBits(18) = 524287      ' 00000000000001111111111111111111
    m_lOnBits(19) = 1048575     ' 00000000000011111111111111111111
    m_lOnBits(20) = 2097151     ' 00000000000111111111111111111111
    m_lOnBits(21) = 4194303     ' 00000000001111111111111111111111
    m_lOnBits(22) = 8388607     ' 00000000011111111111111111111111
    m_lOnBits(23) = 16777215    ' 00000000111111111111111111111111
    m_lOnBits(24) = 33554431    ' 00000001111111111111111111111111
    m_lOnBits(25) = 67108863    ' 00000011111111111111111111111111
    m_lOnBits(26) = 134217727   ' 00000111111111111111111111111111
    m_lOnBits(27) = 268435455   ' 00001111111111111111111111111111
    m_lOnBits(28) = 536870911   ' 00011111111111111111111111111111
    m_lOnBits(29) = 1073741823  ' 00111111111111111111111111111111
    m_lOnBits(30) = 2147483647  ' 01111111111111111111111111111111
    
    ' Could have done this with a loop calculating each value, but simply
    ' assigning the values is quicker - POWERS OF 2
    m_l2Power(0) = 1            ' 00000000000000000000000000000001
    m_l2Power(1) = 2            ' 00000000000000000000000000000010
    m_l2Power(2) = 4            ' 00000000000000000000000000000100
    m_l2Power(3) = 8            ' 00000000000000000000000000001000
    m_l2Power(4) = 16           ' 00000000000000000000000000010000
    m_l2Power(5) = 32           ' 00000000000000000000000000100000
    m_l2Power(6) = 64           ' 00000000000000000000000001000000
    m_l2Power(7) = 128          ' 00000000000000000000000010000000
    m_l2Power(8) = 256          ' 00000000000000000000000100000000
    m_l2Power(9) = 512          ' 00000000000000000000001000000000
    m_l2Power(10) = 1024        ' 00000000000000000000010000000000
    m_l2Power(11) = 2048        ' 00000000000000000000100000000000
    m_l2Power(12) = 4096        ' 00000000000000000001000000000000
    m_l2Power(13) = 8192        ' 00000000000000000010000000000000
    m_l2Power(14) = 16384       ' 00000000000000000100000000000000
    m_l2Power(15) = 32768       ' 00000000000000001000000000000000
    m_l2Power(16) = 65536       ' 00000000000000010000000000000000
    m_l2Power(17) = 131072      ' 00000000000000100000000000000000
    m_l2Power(18) = 262144      ' 00000000000001000000000000000000
    m_l2Power(19) = 524288      ' 00000000000010000000000000000000
    m_l2Power(20) = 1048576     ' 00000000000100000000000000000000
    m_l2Power(21) = 2097152     ' 00000000001000000000000000000000
    m_l2Power(22) = 4194304     ' 00000000010000000000000000000000
    m_l2Power(23) = 8388608     ' 00000000100000000000000000000000
    m_l2Power(24) = 16777216    ' 00000001000000000000000000000000
    m_l2Power(25) = 33554432    ' 00000010000000000000000000000000
    m_l2Power(26) = 67108864    ' 00000100000000000000000000000000
    m_l2Power(27) = 134217728   ' 00001000000000000000000000000000
    m_l2Power(28) = 268435456   ' 00010000000000000000000000000000
    m_l2Power(29) = 536870912   ' 00100000000000000000000000000000
    m_l2Power(30) = 1073741824  ' 01000000000000000000000000000000
End Sub

'*******************************************************************************
' LShift (FUNCTION)
'*******************************************************************************
Private Function LShift(ByVal lValue As Long, _
                        ByVal iShiftBits As Integer) As Long
    If iShiftBits = 0 Then
        LShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And 1 Then
            LShift = &H80000000
        Else
            LShift = 0
        End If
        Exit Function
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
        err.Raise 6
    End If
    
    If (lValue And m_l2Power(31 - iShiftBits)) Then
        LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * _
            m_l2Power(iShiftBits)) Or &H80000000
    Else
        LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * _
            m_l2Power(iShiftBits))
    End If
End Function

'*******************************************************************************
' RShift (FUNCTION)
'*******************************************************************************
Private Function RShift(ByVal lValue As Long, _
                        ByVal iShiftBits As Integer) As Long
    If iShiftBits = 0 Then
        RShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And &H80000000 Then
            RShift = 1
        Else
            RShift = 0
        End If
        Exit Function
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
        err.Raise 6
    End If
    
    RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
    
    If (lValue And &H80000000) Then
        RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
    End If
End Function

'*******************************************************************************
' LShiftByte (FUNCTION)
'*******************************************************************************
Private Function LShiftByte(ByVal bytValue As Byte, _
                            ByVal bytShiftBits As Byte) As Byte
    If bytShiftBits = 0 Then
        LShiftByte = bytValue
        Exit Function
    ElseIf bytShiftBits = 7 Then
        If bytValue And 1 Then
            LShiftByte = &H80
        Else
            LShiftByte = 0
        End If
        Exit Function
    ElseIf bytShiftBits < 0 Or bytShiftBits > 7 Then
        err.Raise 6
    End If
    
    LShiftByte = ((bytValue And m_bytOnBits(7 - bytShiftBits)) * _
        m_byt2Power(bytShiftBits))
End Function

'*******************************************************************************
' RShiftByte (FUNCTION)
'*******************************************************************************
Private Function RShiftByte(ByVal bytValue As Byte, _
                            ByVal bytShiftBits As Byte) As Byte
    If bytShiftBits = 0 Then
        RShiftByte = bytValue
        Exit Function
    ElseIf bytShiftBits = 7 Then
        If bytValue And &H80 Then
            RShiftByte = 1
        Else
            RShiftByte = 0
        End If
        Exit Function
    ElseIf bytShiftBits < 0 Or bytShiftBits > 7 Then
        err.Raise 6
    End If
    
    RShiftByte = bytValue \ m_byt2Power(bytShiftBits)
End Function

'*******************************************************************************
' RotateLeft (FUNCTION)
'*******************************************************************************
Private Function RotateLeft(ByVal lValue As Long, _
                            ByVal iShiftBits As Integer) As Long
    RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function

''*******************************************************************************
'' RotateLeftByte (FUNCTION)
'*******************************************************************************
Private Function RotateLeftByte(ByVal bytValue As Byte, _
                                ByVal bytShiftBits As Byte) As Byte
    RotateLeftByte = LShiftByte(bytValue, bytShiftBits) Or _
        RShiftByte(bytValue, (8 - bytShiftBits))
End Function

'*******************************************************************************
' Pack (FUNCTION)
'*******************************************************************************
Private Function Pack(b() As Byte) As Long
    Dim lCount As Long
    Dim lTemp  As Long
    
    For lCount = 0 To 3
        lTemp = b(lCount)
        Pack = Pack Or LShift(lTemp, (lCount * 8))
    Next
End Function

'*******************************************************************************
' PackFrom (FUNCTION)
'*******************************************************************************
Private Function PackFrom(b() As Byte, _
                          ByVal k As Long) As Long
    Dim lCount As Long
    Dim lTemp  As Long
    
    For lCount = 0 To 3
        lTemp = b(lCount + k)
        PackFrom = PackFrom Or LShift(lTemp, (lCount * 8))
    Next
End Function

'*******************************************************************************
' Unpack (SUB)
'*******************************************************************************
Private Sub Unpack(ByVal a As Long, _
                   b() As Byte)
    b(0) = a And m_lOnBits(7)
    b(1) = RShift(a, 8) And m_lOnBits(7)
    b(2) = RShift(a, 16) And m_lOnBits(7)
    b(3) = RShift(a, 24) And m_lOnBits(7)
End Sub

'*******************************************************************************
' UnpackFrom (SUB)
'*******************************************************************************
Private Sub UnpackFrom(ByVal a As Long, _
                       b() As Byte, _
                       ByVal k As Long)
    b(0 + k) = a And m_lOnBits(7)
    b(1 + k) = RShift(a, 8) And m_lOnBits(7)
    b(2 + k) = RShift(a, 16) And m_lOnBits(7)
    b(3 + k) = RShift(a, 24) And m_lOnBits(7)
End Sub

'*******************************************************************************
' xtime (FUNCTION)
'*******************************************************************************
Private Function xtime(ByVal a As Byte) As Byte
    Dim b As Byte
    
    If (a And &H80) Then
        b = &H1B
    Else
        b = 0
    End If
    
    a = LShiftByte(a, 1)
    a = a Xor b
    
    xtime = a
End Function

'*******************************************************************************
' bmul (FUNCTION)
'*******************************************************************************
Private Function bmul(ByVal x As Byte, _
                      y As Byte) As Byte
    If x <> 0 And y <> 0 Then
        bmul = m_ptab((CLng(m_ltab(x)) + CLng(m_ltab(y))) Mod 255)
    Else
        bmul = 0
    End If
End Function

'*******************************************************************************
' SubByte (FUNCTION)
'*******************************************************************************
Private Function SubByte(ByVal a As Long) As Long
    Dim b(3) As Byte
    
    Unpack a, b
    b(0) = m_fbsub(b(0))
    b(1) = m_fbsub(b(1))
    b(2) = m_fbsub(b(2))
    b(3) = m_fbsub(b(3))
    
    SubByte = Pack(b)
End Function

'*******************************************************************************
' product (FUNCTION)
'*******************************************************************************
Private Function product(ByVal x As Long, _
                         ByVal y As Long) As Long
    Dim xb(3) As Byte
    Dim yb(3) As Byte
    
    Unpack x, xb
    Unpack y, yb
    product = bmul(xb(0), yb(0)) Xor bmul(xb(1), yb(1)) Xor bmul(xb(2), yb(2)) _
        Xor bmul(xb(3), yb(3))
End Function

'*******************************************************************************
' InvMixCol (FUNCTION)
'*******************************************************************************
Private Function InvMixCol(ByVal x As Long) As Long
    Dim y       As Long
    Dim m       As Long
    Dim b(3)    As Byte
    
    m = Pack(m_InCo)
    b(3) = product(m, x)
    m = RotateLeft(m, 24)
    b(2) = product(m, x)
    m = RotateLeft(m, 24)
    b(1) = product(m, x)
    m = RotateLeft(m, 24)
    b(0) = product(m, x)
    y = Pack(b)
    
    InvMixCol = y
End Function

'*******************************************************************************
' ByteSub (FUNCTION)
'*******************************************************************************
Private Function ByteSub(ByVal x As Byte) As Byte
    Dim y As Byte
    
    y = m_ptab(255 - m_ltab(x))
    x = y
    x = RotateLeftByte(x, 1)
    y = y Xor x
    x = RotateLeftByte(x, 1)
    y = y Xor x
    x = RotateLeftByte(x, 1)
    y = y Xor x
    x = RotateLeftByte(x, 1)
    y = y Xor x
    y = y Xor &H63
    
    ByteSub = y
End Function

'*******************************************************************************
' gentables (SUB)
'*******************************************************************************
Public Sub gentables()
    Dim i       As Long
    Dim y       As Byte
    Dim b(3)    As Byte
    Dim ib      As Byte
    
    m_ltab(0) = 0
    m_ptab(0) = 1
    m_ltab(1) = 0
    m_ptab(1) = 3
    m_ltab(3) = 1
    
    For i = 2 To 255
        m_ptab(i) = m_ptab(i - 1) Xor xtime(m_ptab(i - 1))
        m_ltab(m_ptab(i)) = i
    Next
    
    m_fbsub(0) = &H63
    m_rbsub(&H63) = 0
    
    For i = 1 To 255
        ib = i
        y = ByteSub(ib)
        m_fbsub(i) = y
        m_rbsub(y) = i
    Next
    
        y = 1
    For i = 0 To 29
        m_rco(i) = y
        y = xtime(y)
    Next
    
    For i = 0 To 255
        y = m_fbsub(i)
        b(3) = y Xor xtime(y)
        b(2) = y
        b(1) = y
        b(0) = xtime(y)
        m_ftable(i) = Pack(b)
        
        y = m_rbsub(i)
        b(3) = bmul(m_InCo(0), y)
        b(2) = bmul(m_InCo(1), y)
        b(1) = bmul(m_InCo(2), y)
        b(0) = bmul(m_InCo(3), y)
        m_rtable(i) = Pack(b)
    Next
End Sub

'*******************************************************************************
' gkey (SUB)
'*******************************************************************************
Public Sub gkey(ByVal nb As Long, _
                ByVal nk As Long, _
                KEY() As Byte)
                
    Dim i               As Long
    Dim j               As Long
    Dim k               As Long
    Dim m               As Long
    Dim N               As Long
    Dim C1              As Long
    Dim C2              As Long
    Dim C3              As Long
    Dim CipherKey(7)    As Long
    
    m_Nb = nb
    m_Nk = nk
    
    If m_Nb >= m_Nk Then
        m_Nr = 6 + m_Nb
    Else
        m_Nr = 6 + m_Nk
    End If
    
    C1 = 1
    If m_Nb < 8 Then
        C2 = 2
        C3 = 3
    Else
        C2 = 3
        C3 = 4
    End If
    
    For j = 0 To nb - 1
        m = j * 3
        
        m_fi(m) = (j + C1) Mod nb
        m_fi(m + 1) = (j + C2) Mod nb
        m_fi(m + 2) = (j + C3) Mod nb
        m_ri(m) = (nb + j - C1) Mod nb
        m_ri(m + 1) = (nb + j - C2) Mod nb
        m_ri(m + 2) = (nb + j - C3) Mod nb
    Next
    
    N = m_Nb * (m_Nr + 1)
    
    For i = 0 To m_Nk - 1
        j = i * 4
        CipherKey(i) = PackFrom(KEY, j)
    Next
    
    For i = 0 To m_Nk - 1
        m_fkey(i) = CipherKey(i)
    Next
    
    j = m_Nk
    k = 0
    Do While j < N
        m_fkey(j) = m_fkey(j - m_Nk) Xor _
            SubByte(RotateLeft(m_fkey(j - 1), 24)) Xor m_rco(k)
        If m_Nk <= 6 Then
            i = 1
            Do While i < m_Nk And (i + j) < N
                m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
                    m_fkey(i + j - 1)
                i = i + 1
            Loop
        Else
            ' Problem fixed here
            i = 1
            Do While i < 4 And (i + j) < N
                m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
                    m_fkey(i + j - 1)
                i = i + 1
            Loop
            If j + 4 < N Then
                m_fkey(j + 4) = m_fkey(j + 4 - m_Nk) Xor _
                    SubByte(m_fkey(j + 3))
            End If
            i = 5
            Do While i < m_Nk And (i + j) < N
                m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
                    m_fkey(i + j - 1)
                i = i + 1
            Loop
        End If
        
        j = j + m_Nk
        k = k + 1
    Loop
    
    For j = 0 To m_Nb - 1
        m_rkey(j + N - nb) = m_fkey(j)
    Next
    
    i = m_Nb
    Do While i < N - m_Nb
        k = N - m_Nb - i
        For j = 0 To m_Nb - 1
            m_rkey(k + j) = InvMixCol(m_fkey(i + j))
        Next
        i = i + m_Nb
    Loop
    
    j = N - m_Nb
    Do While j < N
        m_rkey(j - N + m_Nb) = m_fkey(j)
        j = j + 1
    Loop
End Sub

'*******************************************************************************
' encrypt (SUB)
'*******************************************************************************
Public Sub Encrypt(buff() As Byte)
    Dim i       As Long
    Dim j       As Long
    Dim k       As Long
    Dim m       As Long
    Dim a(7)    As Long
    Dim b(7)    As Long
    Dim x()     As Long
    Dim y()     As Long
    Dim t()     As Long
    
    For i = 0 To m_Nb - 1
        j = i * 4
        
        a(i) = PackFrom(buff, j)
        a(i) = a(i) Xor m_fkey(i)
    Next
    
    k = m_Nb
    x = a
    y = b
    
    For i = 1 To m_Nr - 1
        For j = 0 To m_Nb - 1
            m = j * 3
            y(j) = m_fkey(k) Xor m_ftable(x(j) And m_lOnBits(7)) Xor _
                RotateLeft(m_ftable(RShift(x(m_fi(m)), 8) And m_lOnBits(7)), 8) Xor _
                RotateLeft(m_ftable(RShift(x(m_fi(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
                RotateLeft(m_ftable(RShift(x(m_fi(m + 2)), 24) And m_lOnBits(7)), 24)
            k = k + 1
        Next
        t = x
        x = y
        y = t
    Next
    
    For j = 0 To m_Nb - 1
        m = j * 3
        y(j) = m_fkey(k) Xor m_fbsub(x(j) And m_lOnBits(7)) Xor _
            RotateLeft(m_fbsub(RShift(x(m_fi(m)), 8) And m_lOnBits(7)), 8) Xor _
            RotateLeft(m_fbsub(RShift(x(m_fi(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
            RotateLeft(m_fbsub(RShift(x(m_fi(m + 2)), 24) And m_lOnBits(7)), 24)
        k = k + 1
    Next
    
    For i = 0 To m_Nb - 1
        j = i * 4
        UnpackFrom y(i), buff, j
        x(i) = 0
        y(i) = 0
    Next
End Sub

'*******************************************************************************
' decrypt (SUB)
'*******************************************************************************
Public Sub Decrypt(buff() As Byte)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim m As Long
    Dim a(7) As Long
    Dim b(7) As Long
    Dim x() As Long
    Dim y() As Long
    Dim t() As Long
    
    For i = 0 To m_Nb - 1
        j = i * 4
        a(i) = PackFrom(buff, j)
        a(i) = a(i) Xor m_rkey(i)
    Next
    
    k = m_Nb
    x = a
    y = b
    
    For i = 1 To m_Nr - 1
        For j = 0 To m_Nb - 1
            m = j * 3
            y(j) = m_rkey(k) Xor m_rtable(x(j) And m_lOnBits(7)) Xor _
                RotateLeft(m_rtable(RShift(x(m_ri(m)), 8) And m_lOnBits(7)), 8) Xor _
                RotateLeft(m_rtable(RShift(x(m_ri(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
                RotateLeft(m_rtable(RShift(x(m_ri(m + 2)), 24) And m_lOnBits(7)), 24)
            k = k + 1
        Next
        t = x
        x = y
        y = t
    Next
    
    For j = 0 To m_Nb - 1
        m = j * 3
        
        y(j) = m_rkey(k) Xor m_rbsub(x(j) And m_lOnBits(7)) Xor _
            RotateLeft(m_rbsub(RShift(x(m_ri(m)), 8) And m_lOnBits(7)), 8) Xor _
            RotateLeft(m_rbsub(RShift(x(m_ri(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
            RotateLeft(m_rbsub(RShift(x(m_ri(m + 2)), 24) And m_lOnBits(7)), 24)
        k = k + 1
    Next
    
    For i = 0 To m_Nb - 1
        j = i * 4
        
        UnpackFrom y(i), buff, j
        x(i) = 0
        y(i) = 0
    Next
End Sub

''*******************************************************************************
'' CopyBytesASP (SUB)
''
'' Slower non-API function you can use to copy array data
''*******************************************************************************
'Private Sub CopyBytesASP(bytDest() As Byte, _
'                         lDestStart As Long, _
'                         bytSource() As Byte, _
'                         lSourceStart As Long, _
'                         lLength As Long)
'    Dim lCount As Long
'
'    lCount = 0
'    Do
'        bytDest(lDestStart + lCount) = bytSource(lSourceStart + lCount)
'        lCount = lCount + 1
'    Loop Until lCount = lLength
'End Sub

'*******************************************************************************
' IsInitialized (FUNCTION)
'*******************************************************************************
Private Function IsInitialized(ByRef vArray As Variant) As Boolean
    On Error Resume Next
    
    IsInitialized = IsNumeric(UBound(vArray))
End Function

'*******************************************************************************
' EncryptData (FUNCTION)
'
' Takes the message, whatever the size, and password in one call and does
' everything for you to return an encoded/encrypted message
'*******************************************************************************
Public Function EncryptData(bytMessage() As Byte, _
                            bytPassword() As Byte) As Byte()
    Dim bytKey(31)      As Byte
    Dim bytIn()         As Byte
    Dim bytOut()        As Byte
    Dim bytTemp(31)     As Byte
    Dim lCount          As Long
    Dim lLength         As Long
    Dim lEncodedLength  As Long
    Dim bytLen(3)       As Byte
    Dim lPosition       As Long
    
    If Not IsInitialized(bytMessage) Then
        Exit Function
    End If
    If Not IsInitialized(bytPassword) Then
        Exit Function
    End If
    
    ' Use first 32 bytes of the password for the key
    For lCount = 0 To UBound(bytPassword)
        bytKey(lCount) = bytPassword(lCount)
        If lCount = 31 Then
            Exit For
        End If
    Next
    
    ' Prepare the key; assume 256 bit block and key size
    gentables
    gkey 8, 8, bytKey
    
    ' We are going to put the message size on the front of the message
    ' in the first 4 bytes. If the length is more than a max int we are
    ' in trouble
    lLength = UBound(bytMessage) + 1
    lEncodedLength = lLength + 4
    
    ' The encoded length includes the 4 bytes stuffed on the front
    ' and is padded out to be modulus 32
    If lEncodedLength Mod 32 <> 0 Then
        lEncodedLength = lEncodedLength + 32 - (lEncodedLength Mod 32)
    End If
    ReDim bytIn(lEncodedLength - 1)
    ReDim bytOut(lEncodedLength - 1)
    
    ' Put the length on the front
    '* Unpack lLength, bytIn
    CopyMemory VarPtr(bytIn(0)), VarPtr(lLength), 4
    ' Put the rest of the message after it
    '* CopyBytesASP bytIn, 4, bytMessage, 0, lLength
    CopyMemory VarPtr(bytIn(4)), VarPtr(bytMessage(0)), lLength

    ' Encrypt a block at a time
    For lCount = 0 To lEncodedLength - 1 Step 32
        '* CopyBytesASP bytTemp, 0, bytIn, lCount, 32
        CopyMemory VarPtr(bytTemp(0)), VarPtr(bytIn(lCount)), 32
        Encrypt bytTemp
        '* CopyBytesASP bytOut, lCount, bytTemp, 0, 32
        CopyMemory VarPtr(bytOut(lCount)), VarPtr(bytTemp(0)), 32
    Next
    
    EncryptData = bytOut
End Function

'*******************************************************************************
' DecryptData (FUNCTION)
'
' Opposite of Encryptdata
'*******************************************************************************
Public Function DecryptData(bytIn() As Byte, _
                            bytPassword() As Byte) As Byte()
    Dim bytMessage()    As Byte
    Dim bytKey(31)      As Byte
    Dim bytOut()        As Byte
    Dim bytTemp(31)     As Byte
    Dim lCount          As Long
    Dim lLength         As Long
    Dim lEncodedLength  As Long
    Dim bytLen(3)       As Byte
    Dim lPosition       As Long
    
    If Not IsInitialized(bytIn) Then
        Exit Function
    End If
    If Not IsInitialized(bytPassword) Then
        Exit Function
    End If
    
    lEncodedLength = UBound(bytIn) + 1
    
    If lEncodedLength Mod 32 <> 0 Then
        Exit Function
    End If
    
    ' Use first 32 bytes of the password for the key
    For lCount = 0 To UBound(bytPassword)
        bytKey(lCount) = bytPassword(lCount)
        If lCount = 31 Then
            Exit For
        End If
    Next
    
    ' Prepare the key; assume 256 bit block and key size
    gentables
    gkey 8, 8, bytKey

    ' The output array needs to be the same size as the input array
    ReDim bytOut(lEncodedLength - 1)
    
    ' Decrypt a block at a time
    For lCount = 0 To lEncodedLength - 1 Step 32
        '* CopyBytesASP bytTemp, 0, bytIn, lCount, 32
        CopyMemory VarPtr(bytTemp(0)), VarPtr(bytIn(lCount)), 32
        Decrypt bytTemp
        '* CopyBytesASP bytOut, lCount, bytTemp, 0, 32
        CopyMemory VarPtr(bytOut(lCount)), VarPtr(bytTemp(0)), 32
    Next

    ' Get the original length of the string from the first 4 bytes
    '* lLength = Pack(bytOut)
    CopyMemory VarPtr(lLength), VarPtr(bytOut(0)), 4
    
    ' Make sure the length is consistent with our data
    If lLength > lEncodedLength - 4 Then
        Exit Function
    End If
    
    ' Prepare the output message byte array
    ReDim bytMessage(lLength - 1)
    '* CopyBytesASP bytMessage, 0, bytOut, 4, lLength
    CopyMemory VarPtr(bytMessage(0)), VarPtr(bytOut(4)), lLength
    
    DecryptData = bytMessage
End Function

'j'ai rajouté cette fonction pour simplifier le cryptage
Public Function JustCrypter(ByVal Texte As String, ByVal Clé As String) As String
    Dim bytIn()         As Byte
    Dim bytOut()        As Byte
    Dim bytPassword()   As Byte
    Dim sTemp           As String
    Dim lCount          As Long
    bytIn = Texte
    bytPassword = Clé
    bytOut = EncryptData(bytIn, bytPassword)
    sTemp = ""
    For lCount = 0 To UBound(bytOut)
        sTemp = sTemp & Right("0" & Hex(bytOut(lCount)), 2)
    Next
    JustCrypter = sTemp
    'le résultat est de type string, mais de l'héxadécimal
End Function

'j'ai rajouté cette fonction pour simplifier le décryptage
Public Function JustDécrypter(ByVal TexteCrypté As String, ByVal Clé As String) As String
    Dim bytOut()        As Byte
    Dim bytPassword()   As Byte
    Dim lCount          As Long
    Dim lLength         As Long
    bytPassword = Clé
        lLength = Len(TexteCrypté)
        ReDim bytOut((lLength \ 2) - 1)
        For lCount = 1 To lLength Step 2
          bytOut(lCount \ 2) = CByte("&H" & Mid(TexteCrypté, lCount, 2))
        Next
    JustDécrypter = DecryptData(bytOut, bytPassword)
End Function

Conclusion :


Voils j'espere que sa servira a quelqun en tout cas a moi sa me sert possédant plusieur ordinateurs se connectants indépendament a Free ce qui rendais l'utilisation d'un compteur classique totalement impossible...

[
Ce code se base en partie sur le mini protocole client HTTP de nix
]

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

OverDarck
Messages postés
116
Date d'inscription
jeudi 12 juillet 2001
Statut
Membre
Dernière intervention
23 juin 2005
-
A Nix ou au Admins :
La compatibilitée du site (voyez cette page qui en est la preuve) c'est pas tout a fais sa.....

C'est pas un critique je sais particulierement combien il est dur de rendre un site surtout quand il est complexe et visuelement evoluée compatible avec tout les navigateurs, néamoins FireFox prenant de plus en plus de part de marché a IE, c'est important de s'assurer de la compatibilitée avec ce navigateur.
Voila bon code a tous @+
matrey
Messages postés
399
Date d'inscription
jeudi 31 janvier 2002
Statut
Membre
Dernière intervention
6 septembre 2004
-
Le principe du compteur est bien, mais le pb c'est que Free mais à jour ses stats de connexion assez sporadiquement... Elles étaient même figées il y a qques mois pendant 1 semaine (en fin de mois en plus, on savait plus où on allait :D)
Wanadoo propose désormais son 50h au même prix que Free avec notamment des stats de connexion en temps réel... Pkoi pas ?
cs_code1
Messages postés
22
Date d'inscription
vendredi 30 juillet 2004
Statut
Membre
Dernière intervention
21 octobre 2004
-
1_il manque le zip
2_expliquer l'interé de ce code 50h=?

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.