Soyez le premier à donner votre avis sur cette source.
Vue 29 299 fois - Téléchargée 1 671 fois
'***************************************************** ' Générateur et vérificateur de serial ' par Tioneb ' ' Certaines fonctions ont été récupérées sur vbfrance '***************************************************** Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" ( _ ByVal lpRootPathName As String, _ ByVal lpVolumeNameBuffer As String, _ ByVal nVolumeNameSize As Long, _ lpVolumeSerialNumber As Long, _ lpMaximumComponentLength As Long, _ lpFileSystemFlags As Long, _ ByVal lpFileSystemNameBuffer As String, _ ByVal nFileSystemNameSize As Long) As Long 'Fin des Déclarations Public Function SerialHDD(SHDDLequel As String) As String Dim r&, PathName$, DrvVolumeName$, DrvSerialNo$ 'Disque à checker PathName$ = "c:\" PathName$ = SHDDLequel rgbGetVolumeInformationRDI PathName$, DrvVolumeName$, DrvSerialNo$ 'Afficher le résultat dans des msgbox 'MsgBox (" Lecteur " & ": " & UCase$(PathName$)) 'MsgBox (" Le Label du disk " & ": " & DrvVolumeName$) 'MsgBox (" Le Numéro de série du disque " & ": " & DrvSerialNo$) SerialHDD = DrvSerialNo$ End Function Private Sub rgbGetVolumeInformationRDI(PathName$, DrvVolumeName$, DrvSerialNo$) Dim r As Long Dim pos As Integer Dim HiWord As Long Dim HiHexStr As String Dim LoWord As Long Dim LoHexStr As String Dim VolumeSN As Long Dim MaxFNLen As Long Dim UnusedStr As String Dim UnusedVal1 As Long Dim UnusedVal2 As Long DrvVolumeName$ = Space$(14) UnusedStr$ = Space$(32) r& = GetVolumeInformation(PathName$, _ DrvVolumeName$, Len(DrvVolumeName$), VolumeSN&, _ UnusedVal1&, UnusedVal2&, UnusedStr$, Len(UnusedStr$)) If r& = 0 Then Exit Sub 'determine le label pos% = InStr(DrvVolumeName$, Chr$(0)) If pos% Then DrvVolumeName$ = Left$(DrvVolumeName$, pos% - 1) If Len(Trim$(DrvVolumeName$)) = 0 Then DrvVolumeName$ = "(pas de label)" 'determine l'id du disque HiWord& = GetHiWord(VolumeSN&) And &HFFFF& LoWord& = GetLoWord(VolumeSN&) And &HFFFF& HiHexStr$ = Format$(Hex(HiWord&), "0000") LoHexStr$ = Format$(Hex(LoWord&), "0000") DrvSerialNo$ = HiHexStr$ & "-" & LoHexStr$ End Sub Function GetHiWord(dw As Long) As Integer If dw& And &H80000000 Then GetHiWord% = (dw& \ 65535) - 1 Else: GetHiWord% = dw& \ 65535 End If End Function Function GetLoWord(dw As Long) As Integer If dw& And &H8000& Then GetLoWord% = &H8000 Or (dw& And &H7FFF&) Else: GetLoWord% = dw& And &HFFFF& End If End Function Public Function Aleatoire(AMini As Long, AMaxi As Long) As Long 'fonction pour générer un numéro aléatoire compris entre les 2 bornes Randomize Aleatoire = Int((AMaxi - AMini + 1) * Rnd + AMini) End Function Public Function Crypter(ByRef str As String) As String 'permet de crypter mais aussi de décrypter avec la même fonction 'inconvéniant: n'a pas de clé de cryptage!!! 'c'est pas du cryptage, c'est une fonction xor Dim Cr As String Dim Ci As Integer Dim carac As String Cr = "" For Ci = 1 To Len(str) carac = Chr(Asc(Mid(str, Ci, 1)) Xor (Len(str) - Ci)) Cr = Cr + carac Next Ci Crypter = Cr End Function Public Function GenererSerial3(GS3Nom As String, GS3IDProg As String) As String Dim LgNom As Integer, i As Integer, CRCNom As Long, CRCHDD As Long, XORGS3Nom As String Dim CRC As Long, CRCIDProg As Long 'on converti le nom en majuscules GS3Nom = UCase(GS3Nom) CRCHDD = 0 'on fait un pseudo CRC sur le numéro de série de la partition For i = 1 To Len(SerialHDD("C:\")) CRCHDD = CRCHDD + Asc(Mid(SerialHDD("C:\"), i, 1)) Next i 'on xor tout ça XORGS3Nom = Crypter(GS3Nom) LgNom = Len(GS3Nom) CRCNom = 0 'on CRC le nom "XORé"! For i = 1 To LgNom CRCNom = CRCNom + Asc(Mid(XORGS3Nom, i, 1)) Next i CRCIDProg = 0 'pareil avec l'ID du prog For i = 1 To Len(GS3IDProg) CRCIDProg = CRCIDProg + Asc(Mid(GS3IDProg, i, 1)) Next i 'on mélange bien.... CRC = (CRCHDD + CRCNom + CRCIDProg) Mod 100 '****************************************************** Dim Caractere As String, Resultat As String, Iteration As Long Iteration = 0 Caractere = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" Dim a1 As Long, b1 As Long, c1 As Long, d1 As Long, e1 As Long Dim a2 As Long, b2 As Long, c2 As Long, d2 As Long, e2 As Long Dim a3 As Long, b3 As Long, c3 As Long, d3 As Long, e3 As Long Dim a4 As Long, b4 As Long, c4 As Long, d4 As Long, e4 As Long Dim a5 As Long, b5 As Long, c5 As Long, d5 As Long, e5 As Long 'et zioup, on chercher un serial compatible BoucleGS3: Iteration = Iteration + 1 a1 = Aleatoire(1, 36) b1 = Aleatoire(1, 36) c1 = Aleatoire(1, 36) d1 = Aleatoire(1, 36) e1 = Aleatoire(1, 36) a2 = Aleatoire(1, 36) b2 = Aleatoire(1, 36) c2 = Aleatoire(1, 36) d2 = Aleatoire(1, 36) e2 = Aleatoire(1, 36) a3 = Aleatoire(1, 36) b3 = Aleatoire(1, 36) c3 = Aleatoire(1, 36) d3 = Aleatoire(1, 36) e3 = Aleatoire(1, 36) a4 = Aleatoire(1, 36) b4 = Aleatoire(1, 36) c4 = Aleatoire(1, 36) d4 = Aleatoire(1, 36) e4 = Aleatoire(1, 36) a5 = Aleatoire(1, 36) b5 = Aleatoire(1, 36) c5 = Aleatoire(1, 36) d5 = Aleatoire(1, 36) e5 = Aleatoire(1, 36) Resultat = "" If ((a1 + e5) + (d2 - b1) * 2 - (2 * e4 + (d3 - c1))) + ((a4 + e1) * 2 + (d1 - b2) - (2 * e2 + (d4 - c2))) - ((a2 + e3) + (d5 - b4) - (2 * b3 + (d2 - c1))) Mod 100 = CRC Then 's'il est bon, on converti tout ça pour le renvoyer avec des lettres et des chiffres Resultat = Mid(Caractere, a1, 1) & Mid(Caractere, a2, 1) & Mid(Caractere, a3, 1) & Mid(Caractere, a4, 1) & Mid(Caractere, a5, 1) & "-" Resultat = Resultat & Mid(Caractere, b1, 1) & Mid(Caractere, b2, 1) & Mid(Caractere, b3, 1) & Mid(Caractere, b4, 1) & Mid(Caractere, b5, 1) & "-" Resultat = Resultat & Mid(Caractere, c1, 1) & Mid(Caractere, c2, 1) & Mid(Caractere, c3, 1) & Mid(Caractere, c4, 1) & Mid(Caractere, c5, 1) & "-" Resultat = Resultat & Mid(Caractere, d1, 1) & Mid(Caractere, d2, 1) & Mid(Caractere, d3, 1) & Mid(Caractere, d4, 1) & Mid(Caractere, d5, 1) & "-" Resultat = Resultat & Mid(Caractere, e1, 1) & Mid(Caractere, e2, 1) & Mid(Caractere, e3, 1) & Mid(Caractere, e4, 1) & Mid(Caractere, e5, 1) Else 's'il est bidon, on recommence DoEvents GoTo BoucleGS3 End If GenererSerial3 = Resultat End Function Public Function VerifierSerial3(VS3Serial As String, VS3Nom As String, VS3IDProg As String) As Boolean Dim LgNom As Integer, i As Integer, CRCNom As Long, CRCHDD As Long, XORVS3Nom As String Dim CRC As Long, CRCIDProg As Long If Len(VS3Serial) <> 29 Then VerifierSerial3 = False Exit Function End If VS3Nom = UCase(VS3Nom) CRCHDD = 0 For i = 1 To Len(SerialHDD("C:\")) CRCHDD = CRCHDD + Asc(Mid(SerialHDD("C:\"), i, 1)) Next i XORVS3Nom = Crypter(VS3Nom) LgNom = Len(VS3Nom) CRCNom = 0 For i = 1 To LgNom CRCNom = CRCNom + Asc(Mid(XORVS3Nom, i, 1)) Next i CRCIDProg = 0 For i = 1 To Len(VS3IDProg) CRCIDProg = CRCIDProg + Asc(Mid(VS3IDProg, i, 1)) Next i CRC = (CRCHDD + CRCNom + CRCIDProg) Mod 100 'GenererSerial3 = CRC '****************************************************** Dim Caractere As String, Resultat As String, Iteration As Long Iteration = 0 Caractere = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" Dim a1 As Long, b1 As Long, c1 As Long, d1 As Long, e1 As Long Dim a2 As Long, b2 As Long, c2 As Long, d2 As Long, e2 As Long Dim a3 As Long, b3 As Long, c3 As Long, d3 As Long, e3 As Long Dim a4 As Long, b4 As Long, c4 As Long, d4 As Long, e4 As Long Dim a5 As Long, b5 As Long, c5 As Long, d5 As Long, e5 As Long Iteration = Iteration + 1 a1 = InStr(Caractere, Mid(VS3Serial, 1, 1)) a2 = InStr(Caractere, Mid(VS3Serial, 2, 1)) a3 = InStr(Caractere, Mid(VS3Serial, 3, 1)) a4 = InStr(Caractere, Mid(VS3Serial, 4, 1)) a5 = InStr(Caractere, Mid(VS3Serial, 5, 1)) b1 = InStr(Caractere, Mid(VS3Serial, 7, 1)) b2 = InStr(Caractere, Mid(VS3Serial, 8, 1)) b3 = InStr(Caractere, Mid(VS3Serial, 9, 1)) b4 = InStr(Caractere, Mid(VS3Serial, 10, 1)) b5 = InStr(Caractere, Mid(VS3Serial, 11, 1)) c1 = InStr(Caractere, Mid(VS3Serial, 13, 1)) c2 = InStr(Caractere, Mid(VS3Serial, 14, 1)) c3 = InStr(Caractere, Mid(VS3Serial, 15, 1)) c4 = InStr(Caractere, Mid(VS3Serial, 16, 1)) c5 = InStr(Caractere, Mid(VS3Serial, 17, 1)) d1 = InStr(Caractere, Mid(VS3Serial, 19, 1)) d2 = InStr(Caractere, Mid(VS3Serial, 20, 1)) d3 = InStr(Caractere, Mid(VS3Serial, 21, 1)) d4 = InStr(Caractere, Mid(VS3Serial, 22, 1)) d5 = InStr(Caractere, Mid(VS3Serial, 23, 1)) e1 = InStr(Caractere, Mid(VS3Serial, 25, 1)) e2 = InStr(Caractere, Mid(VS3Serial, 26, 1)) e3 = InStr(Caractere, Mid(VS3Serial, 27, 1)) e4 = InStr(Caractere, Mid(VS3Serial, 28, 1)) e5 = InStr(Caractere, Mid(VS3Serial, 29, 1)) Resultat = "" If ((a1 + e5) + (d2 - b1) * 2 - (2 * e4 + (d3 - c1))) + ((a4 + e1) * 2 + (d1 - b2) - (2 * e2 + (d4 - c2))) - ((a2 + e3) + (d5 - b4) - (2 * b3 + (d2 - c1))) Mod 100 = CRC Then VerifierSerial3 = True Else VerifierSerial3 = False End If End Function
7 déc. 2009 à 13:52
Pour RENFIELD: Non, le numéro de la partition sur chaque machine ne sera pas identique. Sur la machine qui est destinée à recevoir l'application, on s'arrange pour afficher dans des textboxs le SerialHDD et le nom d'utilisateur. Le client recueille ces informations et me les communique car il n'a pas le bout de code qui permet de générer un Serial (C'est fait exprès!). Il n'a que le code qui permet de vérifier le Serial que moi je vais lui fournir sur la base des renseignements qu'il m'a communiqués par phone ou mail.
7 déc. 2009 à 09:31
Si tu as des soucis de compréhension du langage, il vaudrait mieux poser une question claire et détaillée sur le forum en précisant bien dans quel environnement tu te trouves
Les commentaires de sources ne sont pas fait pour débuguer les adaptations du code présenté.
7 déc. 2009 à 09:28
Bah
maTextBox.Text = GenererSerial3(Param1, Param2, Param3)
(je ne vois pas trop d'où vient ce DoCmd ... Tu programmes dans quoi ? VBA, VB6 ?)
Si l'erreur persiste, il faut lancer le programme avec F8 pour exécuter pas à pas le programme et voir en détail quelle instruction provoque cette erreur + vérifier le contenu de chaque variable impliquée.
7 déc. 2009 à 09:27
7 déc. 2009 à 08:23
Comment donc l'afficher dans le champ "SerialGénéré" par clic sur un bouton de commande? Telle demeure ma préoccupation.
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.