Free 50h - compteur internet multi-postes
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.
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
]
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
- Free 50h - compteur internet multi-postes
- Modele site internet - Conseils pratiques -PHP
- Compteur de lettres ✓ - Forum Delphi / Pascal
- Compteur de lettre - Forum C / C++ / C++.NET
- Tabchamp multi - Forum Java
- Compteur de caractères ✓ - Forum Visual Basic
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.