BigSoft v2.0.4.*Table des procédures 1 - AssemblyInfo.vb 2 - clsVBLocker.vb 2.1 - Private Function bCoderCleEnPrive 2.2 - Private Function bDecoderCle 2.3 - Private Function bLireNSD 2.4 - Private Function dConvIntEnDate 2.5 - Private Function iCheckSum% 2.6 - Private Function iConvChaineLisibleEnInt32Bits% 2.7 - Private Function iConvDateEnInt% 2.8 - Private Function sConvInt32BitsEnChaineLisible$ 2.9 - Public Function bChargerFichierContrat 2.10 - Public Function bCoderCle 2.11 - Public Function bCreerCleAuthentification 2.12 - Public Function bEcrireChampLicence 2.13 - Public Function bLireChampLicence 2.14 - Public Function bTesterCleActivation 2.15 - Public Function bTesterCleAuthentification 2.16 - Public Function bVerifierEMail 2.17 - Public Function bVersionEnregistree 2.18 - Public Function sCheminFichierLicence$ 2.19 - Public Property bVersionEvaluation 2.20 - Public Property dDateExpiration 2.21 - Public Property iNumeroLicence% 2.22 - Public Property iNumeroSerieDisque% 2.23 - Public Property iOptionsLogiciel% 2.24 - Public Property sCheminLicence$ 2.25 - Public Property sCleActivation$ 2.26 - Public Property sCleAuthentification$ 2.27 - Public Property sClient$ 2.28 - Public Property sEMailClient$ 2.29 - Public Property sEMailVendeur$ 2.30 - Public Property sLogiciel$ 2.31 - Public ReadOnly Property bVersionEvaluation 2.32 - Public ReadOnly Property dDateExpiration 2.33 - Public ReadOnly Property iNumeroLicence% 2.34 - Public ReadOnly Property iOptionsLogiciel% 2.35 - Public ReadOnly Property sCleAuthentification$ 2.36 - Public ReadOnly Property sEMailVendeur$ 2.37 - Public Sub New 3 - frmBigSoft.vb 3.1 - Private Sub CmdVoirLicence_Click 3.2 - Private Sub frmBigSoft_Activated 3.3 - Private Sub frmBigSoft_FormClosed 3.4 - Private Sub VerifierLicence 4 - frmEnreg.vb 4.1 - Private Sub CmdAccepter_Click 4.2 - Private Sub CmdCreerCleAuthentification_Click 4.3 - Private Sub CmdEMail_Click 4.4 - Private Sub CmdRefuser_Click 4.5 - Private Sub CmdValiderCleActivation_Click 4.6 - Private Sub frmEnreg_Load 4.7 - Private Sub LireCleActivation 4.8 - Private Sub TxtEMail_TextChanged 5 - modConstantesBigSoft.vb 6 - modConstantes.vb 7 - modCourriel.vb 7.1 - Public Function bEnvoyerCourriel 8 - modCryptage.vb 8.1 - Function iXORCar% 8.2 - Private Function sCrypterXOR$ 8.3 - Public Function iCoderCar% 8.4 - Public Function sCrypter$ 9 - modIni.vb 9.1 - Public Function bEcrireFichierIni 9.2 - Public Function bLireFichierIni 10 - modUtil.vb 10.1 - Public Function bChoisirFichier 10.2 - Public Function bFichierExiste 10.3 - Public Function iConv% 10.4 - Public Function sLirePressePapier$ 10.5 - Public Sub AfficherMsgErreur 10.6 - Public Sub AfficherMsgErreur2 10.7 - Public Sub CopierPressePapier 10.8 - Public Sub OuvrirAppliAssociee AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- Imports System.Reflection <Assembly: AssemblyTitle("BigSoft")> <Assembly: AssemblyDescription("BigSoft : Test VBLocker")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("BigSoft, VBLocker")> <Assembly: AssemblyCopyright("Copyright © ORS Production 2008")> <Assembly: AssemblyTrademark("BigSoft, VBLocker")> <Assembly: AssemblyCulture("")> <Assembly: AssemblyVersion("2.0.4.*")> clsVBLocker.vb ' clsVBLocker.vb : Classe VBLocker et VBUnLocker ' -------------- ' VBLocker : Protégez votre application commerciale ' ------------------------------------------------- ' http://www.vbfrance.com/code.aspx?ID=3227 ' Documentation : VBLocker.html : ' http://patrice.dargenton.free.fr/CodesSources/VBLocker.html ' http://patrice.dargenton.free.fr/CodesSources/BigSoft.vbproj.html ' http://patrice.dargenton.free.fr/CodesSources/ActivationBigSoft.vbproj.html ' Version 2.04 du 02/01/2008 ' Par Patrice Dargenton : mailto:patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' http://patrice.dargenton.free.fr/CodesSources/index.html ' http://www.vbfrance.com/listeauteur2.aspx?ID=1124 ' Conventions de nommage des variables : ' ------------------------------------ ' b pour Boolean (booléen vrai ou faux) ' i pour Integer : % (en VB .Net, l'entier a la capacité du VB6.Long) ' l pour Long : & ' r pour nombre Réel (Single!, Double# ou Decimal : D) ' s pour String : $ ' c pour Char ou Byte ' d pour Date ' u pour Unsigned (non signé : entier positif) ' a pour Array (tableau) : () ' o pour Object : objet instancié localement ' refX pour reference à un objet X préexistant qui n'est pas sensé être fermé ' m_ pour variable Membre de la classe ou de la feuille (Form) ' (mais pas pour les constantes) ' frm pour Form ' cls pour Classe ' mod pour Module ' ... ' ------------------------------------ ' clsVBLocker ne doit pas contenir les fonctions permettant l'activation, ' car c'est la classe qui reste du coté client ' Pour utiliser la classe en mode UnLocker, on utilise VBUnLocker = -1 dans les arguments ' de compilation conditionnelle (et on ne met rien pour clsVBLocker) Public Class clsVBLocker Private m_sEMailVendeur$ Private m_sCheminLicence$ Private m_Cle As TCleProtection ' Champs de la clé : Position et nombre de car. de chaque champ ' Nombre de car. pour les Checksum (CS) : 2 suffit en base 62, 3 en base 32 ' (26 minuscules + 26 majuscules + 10 chiffres = 62 caractères) Private Const iPosNSD% = 1 ' N° de Série du Disque dur Private Const iLenNSD% = 7 ' Nbre de car. dans la base 32 'Private Const iLenNSD% = 6 ' 6 en base 64, car 7 est alors trop grand pour un Long Private Const iPosDate% = iPosNSD + iLenNSD ' Champ suivant le champ NSD Private Const iLenDate% = 3 Private Const iPosLic% = iPosDate + iLenDate Private Const iLenLic% = 4 ' N° de Licence Private Const iPosOptions% = iPosLic + iLenLic Private Const iLenOptions% = 2 ' Options du logiciel dans la licence Private Const iPosCSClient% = iPosOptions + iLenOptions Private Const iLenCSClient% = 3 Private Const iPosCSEMail% = iPosCSClient + iLenCSClient Private Const iLenCSEMail% = 3 Private Const iPosCSLogiciel% = iPosCSEMail + iLenCSEMail Private Const iLenCSLogiciel% = 3 ' Total des paramètres (sauf le CS final) Private Const iLenTot% = iPosCSLogiciel + iLenCSLogiciel Private Const iPosCS% = iLenTot Private Const iLenCS% = 3 ' Toute la clé avec le CS final Private Const iLenCle% = iPosCS + iLenCS Private Declare Function GetVolumeInformation% Lib "kernel32" Alias _ "GetVolumeInformationA" (ByVal lpRootPathName$, ByVal lpVolumeNameBuffer$, _ ByVal nVolumeNameSize%, ByRef lpVolumeSerialNumber%, _ ByRef lpMaximumComponentLength%, ByRef lpFileSystemFlags%, _ ByVal lpFileSystemNameBuffer$, ByVal nFileSystemNameSize%) Public Property sEMailClient$() Get sEMailClient = m_Cle.sEMail End Get Set(ByVal Value$) m_Cle.sEMail = Value End Set End Property Public Property sCheminLicence$() Get sCheminLicence = m_sCheminLicence End Get Set(ByVal Value$) m_sCheminLicence = Value End Set End Property ' Propriétés en lecture/écriture dans VBLocker, ' mais en lecture seule dans VBUnLocker #If VBUnLocker Then Public Property sEMailVendeur$() Get sEMailVendeur = m_sEMailVendeur End Get Set(ByVal Value$) m_sEMailVendeur = Value End Set End Property Public Property sCleAuthentification$() Get sCleAuthentification = m_Cle.sCleAuthentification End Get Set(ByVal Value$) m_Cle.sCleAuthentification = Value End Set End Property Public Property sCleActivation$() Get sCleActivation = m_Cle.sCleActivation End Get Set(ByVal Value$) m_Cle.sCleActivation = Value End Set End Property Public Property iNumeroLicence%() Get iNumeroLicence = m_Cle.iNumeroLicence End Get Set(ByVal Value%) m_Cle.iNumeroLicence = Value End Set End Property Public Property dDateExpiration() As Date Get dDateExpiration = m_Cle.dDateExpiration End Get Set(ByVal Value As Date) m_Cle.dDateExpiration = Value End Set End Property Public Property iOptionsLogiciel%() Get iOptionsLogiciel = m_Cle.iOptionsLogiciel End Get Set(ByVal iValue%) m_Cle.iOptionsLogiciel = iValue End Set End Property Public Property bVersionEvaluation() As Boolean Get bVersionEvaluation = m_Cle.bVersionEvaluation End Get Set(ByVal Value As Boolean) m_Cle.bVersionEvaluation = Value End Set End Property #Else Public ReadOnly Property sEMailVendeur$() Get sEMailVendeur = m_sEMailVendeur End Get End Property Public ReadOnly Property sCleAuthentification$() Get sCleAuthentification = m_Cle.sCleAuthentification End Get End Property Public ReadOnly Property iNumeroLicence%() Get iNumeroLicence = m_Cle.iNumeroLicence End Get End Property Public ReadOnly Property dDateExpiration() As Date Get dDateExpiration = m_Cle.dDateExpiration End Get End Property Public ReadOnly Property iOptionsLogiciel%() Get iOptionsLogiciel = m_Cle.iOptionsLogiciel End Get End Property Public ReadOnly Property bVersionEvaluation() As Boolean Get bVersionEvaluation = m_Cle.bVersionEvaluation End Get End Property #End If ' La property Get doit être présente pour que ' la property Let fonctionne sous Access ! Public Property iNumeroSerieDisque%() Get iNumeroSerieDisque = m_Cle.iNumeroSerieDisque End Get Set(ByVal Value%) m_Cle.iNumeroSerieDisque = Value End Set End Property Public Property sClient$() Get sClient = m_Cle.sClient End Get Set(ByVal Value$) m_Cle.sClient = Value End Set End Property Public Property sLogiciel$() Get sLogiciel = m_Cle.sLogiciel End Get Set(ByVal Value$) m_Cle.sLogiciel = Value End Set End Property Public Sub New() MyBase.New() m_sEMailVendeur = sEMailVendeurDef m_sCheminLicence = Application.StartupPath & "\" & sFichierLicenceDef End Sub Public Function bVerifierEMail(ByRef sEMail$, ByRef sMsgErr$) As Boolean If sEMail = "" Then sMsgErr = "Veuillez saisir votre EMail" : Exit Function If InStr(sEMail, "@") = 0 Or _ InStr(sEMail, " ") > 0 Or _ Left(sEMail, 1) = "@" Or _ Right(sEMail, 1) = "@" Then _ sMsgErr = "Adresse E-Mail incorrecte" : Exit Function sMsgErr = "" bVerifierEMail = True m_Cle.sEMail = sEMail End Function Public Function bCreerCleAuthentification(ByRef sCleAuthentification$, ByRef sMsgErr$) As Boolean ' Créer la clé d'authentification avec le nom du client et ' le numéro de série du disque dur de l'utilisateur ' (de la partition où est installé le logiciel en fait) If bTrapErr Then On Error GoTo Erreur With m_Cle .sLecteur = Left(Application.StartupPath, 3) If Not bLireNSD(.sLecteur, .iNumeroSerieDisque) Then ' On teste sur C: alors, le cas le plus sûr If Not bLireNSD(sLecteurDefaut, .iNumeroSerieDisque) Then sMsgErr = "Installation impossible sur ce lecteur" Exit Function End If End If End With Dim sCleCryptee$ sCleCryptee = "" ' Coder la clé d'authentification If Not bCoderCleEnPrive(sCleCryptee, sMsgErr, bCleAuthentification:=True) Then Exit Function sCleAuthentification = sCleCryptee m_Cle.sCleAuthentification = sCleAuthentification bCreerCleAuthentification = True Exit Function Erreur: sMsgErr = Err.Description End Function #If VBUnLocker Then Public Function bCoderCle(ByRef sCle$, ByRef sMsgErr$, ByRef bCleAuthentification As Boolean) As Boolean bCoderCle = bCoderCleEnPrive(sCle, sMsgErr, bCleAuthentification) End Function #End If ' Fonction privée : ne change pas grand chose pour Reflector : on voit qd même le src ! Private Function bCoderCleEnPrive(ByRef sCle$, ByRef sMsgErr$, _ ByRef bCleAuthentification As Boolean) As Boolean sCle = New String("0"c, iLenCle - 1) ' 0 : Pour éviter les espaces Dim sCodeCSEMail, sCodeNSD, sCodeCSClient, sCodeLicence As String Dim sCleCryptee$ Dim sCodeCSLogiciel, sCodeOptions, sCodeDate, sCodeCS As String Dim iCodage% With m_Cle ' N° de Série du Disque sMsgErr = "NSD" ' bVerifierLimite:=True : On doit s'assurer que le n° de série ' du disque du client pourra être codé ! sCodeNSD = sConvInt32BitsEnChaineLisible(.iNumeroSerieDisque, iLenNSD, _ sMsgErr, bVerifierLimiteInt32:=True) If sMsgErr <> "" Then Exit Function Mid(sCle, iPosNSD, iLenNSD) = sCodeNSD ' Date d'expiration sMsgErr = "Date" iCodage = iConvDateEnInt(.dDateExpiration) sCodeDate = sConvInt32BitsEnChaineLisible(iCodage, iLenDate, sMsgErr) If sMsgErr <> "" Then Exit Function Mid(sCle, iPosDate, iLenDate) = sCodeDate ' Licence sMsgErr = "Licence" sCodeLicence = sConvInt32BitsEnChaineLisible(.iNumeroLicence, iLenLic, sMsgErr) If sMsgErr <> "" Then Exit Function Mid(sCle, iPosLic, iLenLic) = sCodeLicence ' Options du logiciel iCodage = .iOptionsLogiciel sMsgErr = "Options" sCodeOptions = sConvInt32BitsEnChaineLisible(iCodage, iLenOptions, sMsgErr) If sMsgErr <> "" Then Exit Function Mid(sCle, iPosOptions, iLenOptions) = sCodeOptions ' Checksum du client If .iCSClient = 0 Then .iCSClient = iCheckSum(.sClient) sMsgErr = "CSClient" sCodeCSClient = sConvInt32BitsEnChaineLisible(.iCSClient, iLenCSClient, _ sMsgErr, , bVerifierLimiteInt16:=True) If sMsgErr <> "" Then Exit Function Mid(sCle, iPosCSClient, iLenCSClient) = sCodeCSClient ' Checksum de l'email client If .iCSEMail = 0 Then .iCSEMail = iCheckSum(.sEMail) sMsgErr = "CSEMail" sCodeCSEMail = sConvInt32BitsEnChaineLisible(.iCSEMail, iLenCSEMail, _ sMsgErr, , bVerifierLimiteInt16:=True) If sMsgErr <> "" Then Exit Function Mid(sCle, iPosCSEMail, iLenCSEMail) = sCodeCSEMail ' Checksum du logiciel If .iCSLogiciel = 0 Then .iCSLogiciel = iCheckSum(.sLogiciel) sMsgErr = "CSLogiciel" sCodeCSLogiciel = sConvInt32BitsEnChaineLisible(.iCSLogiciel, iLenCSLogiciel, _ sMsgErr, , bVerifierLimiteInt16:=True) If sMsgErr <> "" Then Exit Function Mid(sCle, iPosCSLogiciel, iLenCSLogiciel) = sCodeCSLogiciel ' Checksum total sCodeCS = Mid(sCle, 1, iLenTot - 1) iCodage = iCheckSum(sCodeCS) ' Crypter le checksum et l'ajouter dans la chaine sMsgErr = "CS" sCodeCS = sConvInt32BitsEnChaineLisible(iCodage, iLenCS, _ sMsgErr, , bVerifierLimiteInt16:=True) If sMsgErr <> "" Then Exit Function Mid(sCle, iPosCS, iLenCS) = sCodeCS bCoderCleEnPrive = True ' Crypter la clé sCleCryptee = sCrypter(bCleAuthentification, sCle) sCle = sCleCryptee End With End Function Private Function bDecoderCle(ByRef sCle$, ByRef sMsgErr$, _ ByRef bCleAuthentification As Boolean) As Boolean If bTrapErr Then On Error GoTo Erreur If Len(sCle) <> iLenCle - 1 Then sMsgErr = "Longueur de clé incorrecte" : Exit Function Dim iCodage, iCS As Integer Dim sCode, sCleDecryptee As String With m_Cle ' Décrypter la chaine sCleDecryptee = sCrypter(bCleAuthentification, sCle) ' Checksum de la chaine sCode = Mid(sCleDecryptee, iPosCS, iLenCS) iCodage = iConvChaineLisibleEnInt32Bits(sCode) ' Vérification du checksum sCode = Mid(sCleDecryptee, 1, iLenTot - 1) iCS = iCheckSum(sCode) If iCodage <> iCS Then sMsgErr = "Clé incorrecte" : Exit Function ' Checksum client sCode = Mid(sCleDecryptee, iPosCSClient, iLenCSClient) .iCSClient = iConvChaineLisibleEnInt32Bits(sCode) iCodage = iCheckSum(.sClient) If iCodage <> .iCSClient Then sMsgErr = "Client incorrect" : Exit Function ' Checksum EMail client sCode = Mid(sCleDecryptee, iPosCSEMail, iLenCSEMail) .iCSEMail = iConvChaineLisibleEnInt32Bits(sCode) iCodage = iCheckSum(.sEMail) If iCodage <> .iCSEMail Then sMsgErr = "EMail incorrect" : Exit Function ' Checksum logiciel sCode = Mid(sCleDecryptee, iPosCSLogiciel, iLenCSLogiciel) .iCSLogiciel = iConvChaineLisibleEnInt32Bits(sCode) iCodage = iCheckSum(.sLogiciel) If iCodage <> .iCSLogiciel Then sMsgErr = "Logiciel incorrect" : Exit Function .iNumeroSerieDisque = iConvChaineLisibleEnInt32Bits( _ Mid(sCleDecryptee, iPosNSD, iLenNSD)) iCodage = iConvChaineLisibleEnInt32Bits(Mid(sCleDecryptee, iPosDate, iLenDate)) .dDateExpiration = dConvIntEnDate(iCodage) .iNumeroLicence = iConvChaineLisibleEnInt32Bits( _ Mid(sCleDecryptee, iPosLic, iLenLic)) ' Options du logiciel iCodage = iConvChaineLisibleEnInt32Bits( _ Mid(sCleDecryptee, iPosOptions, iLenOptions)) ' Vrai si le bit 0 est à 1 .bVersionEvaluation = CBool(iCodage And iMasqueVersionEvaluation) .iOptionsLogiciel = iCodage End With sCle = sCleDecryptee bDecoderCle = True Exit Function Erreur: AfficherMsgErreur(Err, "bDecoderCle") End Function Public Function bVersionEnregistree(ByRef sMsgErr$) As Boolean Dim dDateLimite As Date Dim iNumeroLicence% Dim iOptions% Dim sCleAuthentification, sCleActivation As String Dim bDateExpiree As Boolean bVersionEnregistree = False ' Vérification de la clé d'authentification Dim sClient, sEMailClient As String sClient = "" : sEMailClient = "" If Not bLireChampLicence(sIniClient, sClient, sIniRubriqueInfosClient) Then Exit Function If Not bLireChampLicence(sIniEMail, sEMailClient, sIniRubriqueInfosClient) Then Exit Function m_Cle.sClient = sClient m_Cle.sEMail = sEMailClient sCleAuthentification = "" If Not bLireChampLicence(sIniCleAuthentification, sCleAuthentification, sIniRubriqueCle) Then Exit Function sMsgErr = "" If Not bTesterCleAuthentification(sCleAuthentification, sMsgErr) Then Exit Function ' Vérification de la clé d'activation sCleActivation = "" If Not bLireChampLicence(sIniCleActivation, sCleActivation, sIniRubriqueCle) Then _ Exit Function ' Appeler la procédure générale de test sMsgErr = "" If Not bTesterCleActivation(sCleActivation, sMsgErr, dDateLimite, _ iNumeroLicence, iOptions) Then Exit Function bDateExpiree = True If dDateLimite = dDateIllimitee Or dDateLimite >= Now Then bDateExpiree = False ' Si la procédure d'enregistrement est suivie, seule la date compte bVersionEnregistree = Not bDateExpiree End Function Public Function bTesterCleAuthentification(ByVal sCleAuthentification$, ByRef sMsgErr$) _ As Boolean If Not bDecoderCle(sCleAuthentification, sMsgErr, bCleAuthentification:=True) Then _ Exit Function bTesterCleAuthentification = True End Function Public Function bTesterCleActivation(ByVal sCleActivation$, ByRef sMsgErr$, _ Optional ByRef dDateExpiration As Date = #12:00:00 AM#, _ Optional ByRef iNumeroLicence% = 0, _ Optional ByRef iOptions% = 0) As Boolean ' Procédure de test de la clé ' Retourne en option : Date exp., Numéro de licence, les options de la licence If bTrapErr Then On Error GoTo Erreur ' Lire le nom du client, son EMail et le logiciel Dim sEMail, sClient, sCleDecodee, sLogiciel As String sClient = "" : sEMail = "" : sLogiciel = "" 'Dim oVal As Object = Nothing If Not bLireChampLicence("Client", sClient, sIniRubriqueInfosClient) Then Exit Function 'sClient = CStr(oVal) If Not bLireChampLicence("EMail", sEMail, sIniRubriqueInfosClient) Then Exit Function 'sEMail = CStr(oVal) If Not bLireChampLicence("Logiciel", sLogiciel, sIniRubriqueInfosClient) Then _ Exit Function 'sLogiciel = CStr(oVal) m_Cle.sClient = sClient m_Cle.sCleActivation = sCleActivation m_Cle.sEMail = sEMail ' Décoder la clé sCleDecodee = sCleActivation If Not bDecoderCle(sCleDecodee, sMsgErr, bCleAuthentification:=False) Then Exit Function If sCleDecodee = "" Then Exit Function ' Lire les options de la clé Dim iNSD% With m_Cle ' Tester le numéro du lecteur .sLecteur = Left(Application.StartupPath, 3) If Not bLireNSD(.sLecteur, iNSD) Then If Not bLireNSD(sLecteurDefaut, iNSD) Then sMsgErr = "Installation impossible sur ce lecteur" Exit Function End If End If If .iNumeroSerieDisque <> iNSD Then sMsgErr = "Clé invalide" : Exit Function ' Date limite If .dDateExpiration <> dDateIllimitee Then If .dDateExpiration < Now Then sMsgErr = "Date expirée" : Exit Function End If dDateExpiration = .dDateExpiration iNumeroLicence = .iNumeroLicence iOptions = .iOptionsLogiciel ' 08/09/2007 : Correction d'une faille critique existant depuis le 08/05/2002 ' le n° de licence ne peut être égal à 0, et au moins une option doit être activée If iNumeroLicence = 0 Or iOptions = 0 Then sMsgErr = "Clé invalide" : Exit Function End With bTesterCleActivation = True Exit Function Erreur: AfficherMsgErreur(Err, "bTesterCleActivation") End Function Private Function bLireNSD(ByRef sLecteur$, ByRef iNSD%) As Boolean ' Retourne le numéro de série du lecteur If bTrapErr Then On Error GoTo Erreur ' Autre méthode possible : même résultat ! 'Dim oFSO As Object, vLecteur As Variant 'Set oFSO = CreateObject("Scripting.FileSystemObject") 'Set vLecteur = oFSO.GetDrive(oFSO.GetDriveName( _ 'oFSO.GetAbsolutePathName(sLecteur))) 'iNSD = vLecteur.SerialNumber 'Set vLecteur = Nothing 'Set oFSO = Nothing Dim sLabel, sSysName As String Dim iMaxComp, iSerial, iFlags, iRet As Integer Const iLongCheminMax% = 256 sLabel = New String(Chr(0), iLongCheminMax) sSysName = New String(Chr(0), iLongCheminMax) iRet = GetVolumeInformation(sLecteur, sLabel, 255, iSerial, iMaxComp, _ iFlags, sSysName, 255) ' Unable to retrieve volume information If iRet = 0 Then Exit Function ' The device is not ready If Err.LastDllError = 21 Then Exit Function ' Impossible de déterminer le numéro de série If iSerial = 0 Then Exit Function ' Parfois le n° de série est négatif ! iNSD = System.Math.Abs(iSerial) bLireNSD = True Exit Function Erreur: AfficherMsgErreur(Err, "bLireNSD") End Function Private Function sConvInt32BitsEnChaineLisible$(ByVal lVal%, ByRef iNbCarPrevus%, _ ByRef sMsgErr$, _ Optional ByRef bVerifierLimiteInt32 As Boolean = False, _ Optional ByRef bVerifierLimiteInt16 As Boolean = False) ' Transformer un entier long (4 octets en VB6) en notation base au choix ' et coder la chaine à l'aide des chiffres et des lettres minuscules ' puis majuscules en utilisant juste le nombre de caractères nécessaires ' Fonction inverse : iConvChaineLisibleEnInt32Bits sConvInt32BitsEnChaineLisible = "" ' La base maximale est 64 ' 26 minuscules + 26 majuscules + 10 chiffres = 62 caractères + 2 If iBaseCodage > 64 Or iBaseCodage < 2 Then _ sMsgErr = "Base de codage invalide" : Exit Function Dim iCar, iNbCarMax, i, iCodeCar As Integer 'Short Dim iDiv% Dim sChaine$ If bVerifierLimiteInt16 Then Do Until (iBaseCodage ^ iNbCarMax) >= iMaxInt16 iNbCarMax = iNbCarMax + 1 Loop If iNbCarMax > iNbCarPrevus Then sMsgErr = sMsgErr & " : Dépassement de capacité du codage : " & _ iNbCarMax & " > " & iNbCarPrevus & " car." Exit Function End If End If iNbCarMax = 0 ' Nombre maximum de caractères possibles = 6 pour un long en base 62 Do Until (iBaseCodage ^ iNbCarMax) >= iMaxInt32 iNbCarMax = iNbCarMax + 1 Loop If iNbCarMax > iNbCarPrevus And bVerifierLimiteInt32 Then sMsgErr = sMsgErr & " : Dépassement de capacité du codage : " & _ iNbCarMax & " > " & iNbCarPrevus & " car." Exit Function End If ' Tableau des unités et du reste de la division précédente Const iUnite% = 0 Const iReste% = 1 Dim alDiv%(iNbCarMax, iReste) ' Remplissage du tableau des unités de la base alDiv(iNbCarMax, 1) = lVal For i = (iNbCarMax - 1) To 0 Step -1 iDiv = CInt(iBaseCodage ^ i) alDiv(i, iUnite) = alDiv(i + 1, iReste) \ iDiv ' Unité ' Reste de la division entière alDiv(i, iReste) = alDiv(i + 1, iReste) Mod iDiv Next i alDiv(0, iReste) = alDiv(0, iUnite) ' Création de la chaine sChaine = "" For i = (iNbCarMax - 1) To 0 Step -1 iCar = alDiv(i, iUnite) ' Sauter la valeur Zéro sauf pour la première unité If i < iNbCarPrevus Or iCar > 0 Then iCodeCar = iCoderCar(iCar, bDecoder:=True) sChaine = sChaine & Chr(iCodeCar) End If Next i If Len(sChaine) > iNbCarPrevus Then sMsgErr = sMsgErr & " : Dépassement de capacité du codage : " & _ iNbCarPrevus & " car." Exit Function End If sMsgErr = "" sConvInt32BitsEnChaineLisible = sChaine End Function Private Function iConvChaineLisibleEnInt32Bits%(ByVal sChaine$) ' Transformer une chaine représentant un numérique en notation base au choix ' en valeur numérique décimale (base 10) dans un entier long (signé) ' Fonction inverse : sConvInt32BitsEnChaineLisible ' Exemple base 62: 62 ^ 2 = 3844, 62 ^ 3 = 238328, 62 ^ 4 = 14776336 Dim iCar, i, j, iLenStr As Integer Dim iCarCode, iCodeFinal As Integer If bTrapErr Then On Error GoTo Erreur iLenStr = Len(sChaine) For i = iLenStr To 1 Step -1 iCar = Asc(Mid(sChaine, i, 1)) iCarCode = iCoderCar(iCar) iCodeFinal = CInt(iCodeFinal + iCarCode * iBaseCodage ^ j) j = j + 1 Next i iConvChaineLisibleEnInt32Bits = iCodeFinal Exit Function Erreur: MsgBox("Dépassement de capacité du codage en Long :" & vbCrLf & _ "Changez les paramètres du codage", MsgBoxStyle.Critical) End Function Private Function iConvDateEnInt%(ByRef dDate As Date) Dim iMois, iAn As Integer If dDate = dDateIllimitee Then iConvDateEnInt = 0 : Exit Function iMois = Month(dDate) iAn = Year(dDate) ' Pour booster le marché de l'emploi info. dans un futur lointain, ' on va essayer de faire tenir le codage sur 2 caractères seulement :-) iAn = iAn - 2000 If iAn < 0 Then iConvDateEnInt = 0 dDate = dDateIllimitee Exit Function End If iConvDateEnInt = iMois + CInt(iAn) * 12 ' Codage en mois End Function Private Function dConvIntEnDate(ByRef iCodage%) As Date Dim iMois, iAn As Integer If iCodage = 0 Then dConvIntEnDate = dDateIllimitee : Exit Function iAn = CInt(iCodage / 12) iMois = iCodage - CInt(iAn) * 12 iAn = iAn + 2000 dConvIntEnDate = DateSerial(iAn, iMois, 1) End Function Private Function iCheckSum%(ByVal sChaine$) ' Calculer le Checksum d'un texte : somme de contrôle ' (ce n'est pas un véritable hash unique) Dim sBuffer$ Dim i% Dim rCS As Single ' Mieux vaut laisser Single en cas de gd texte ' Calculer un premier checksum entier rCS = 0 For i = 1 To Len(sChaine) rCS += Asc(Mid(sChaine, i, 1)) Next i ' Calculer le checksum final Do While rCS > iMaxInt16 'sBuffer = VB6.Format(rCS) ' Transformer l'entier en texte sBuffer = rCS.ToString ' Transformer l'entier en texte rCS = 0 For i = 1 To Len(sBuffer) rCS += CSng(Val(Mid(sBuffer, i, 1))) Next i Loop iCheckSum = CInt(rCS) End Function Public Function sCheminFichierLicence$( _ Optional ByVal bVerifierFichierExiste As Boolean = False, _ Optional ByRef bFichierExiste0 As Boolean = False) ' Obtenir le nom du fichier licence .lic If bTrapErr Then On Error GoTo Erreur Dim bOK As Boolean bOK = bFichierExiste(m_sCheminLicence) ' Renvoyer l'existence du fichier en option If bVerifierFichierExiste Then bFichierExiste0 = bOK sCheminFichierLicence = m_sCheminLicence Exit Function Erreur: AfficherMsgErreur(Err, "sCheminFichierLicence") End Function Public Function bLireChampLicence(ByRef sChamp$, ByRef sVal$, ByRef sSection$, _ Optional ByRef sFichier$ = "", _ Optional ByRef bAutoriserChaineVide As Boolean = False) As Boolean ' Lire un champ dans le fichier ini If bTrapErr Then On Error GoTo Erreur Dim bFichierExiste As Boolean If sFichier = "" Then sFichier = sCheminFichierLicence(bVerifierFichierExiste:=True, _ bFichierExiste0:=bFichierExiste) If bFichierExiste = False Then Exit Function End If If bLireFichierIni(sChamp, sSection, sFichier, sVal, "", bNumerique:=False, _ bPromptErr:=False) Then If sVal = "" Then If bAutoriserChaineVide Then bLireChampLicence = True : Exit Function Exit Function End If bLireChampLicence = True End If Exit Function Erreur: AfficherMsgErreur(Err, "bLireChampLicence") End Function Public Function bEcrireChampLicence(ByRef sChamp$, ByVal sVal$, ByRef sSection$) As Boolean ' Ecrire un champ dans le fichier .lic Dim sCheminFichierLic$ = sCheminFichierLicence() bEcrireChampLicence = bEcrireFichierIni(sChamp, sSection, sCheminFichierLic, _ sVal, bPromptErr:=True, bNumerique:=False) End Function Public Function bChargerFichierContrat(ByRef sFichier$, ByRef sContrat$) As Boolean ' Chargement du ficher Contrat.txt If bTrapErr Then On Error GoTo Erreur Dim lNumFichier% If Not bFichierExiste(sFichier) Then sContrat = "Le fichier " & sFichier & " est introuvable" Exit Function End If lNumFichier = FreeFile() FileOpen(lNumFichier, sFichier, OpenMode.Input) Input(lNumFichier, sContrat) FileClose(lNumFichier) bChargerFichierContrat = True Exit Function Erreur: AfficherMsgErreur(Err, "bChargerFichierContrat") End Function End Class frmBigSoft.vb ' frmBigSoft.vb : formulaire de démarrage de BigSoft ' ------------- Friend Class frmBigSoft : Inherits Form Private m_oVBLocker As New ClsVBLocker Private Sub frmBigSoft_Activated(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles MyBase.Activated ' Attention en cas d'erreur ou d'expiration : risque de boucle infinie : ' pour éviter cela, on doit utiliser une variable globale pour pouvoir ' mettre à jour le statut activé de ce frm lorsque l'on active le logiciel dans ' le frm frmEnreg (pas besoin en VB6, car les MsgBox ne génèrent apparemment pas ' d'événement Form_Activate, donc ce pb ne s'était pas présenté auparavant) If glb_bLicenceVerifiee Then Exit Sub glb_bLicenceVerifiee = True VerifierLicence() End Sub Private Sub frmBigSoft_FormClosed(ByVal eventSender As Object, _ ByVal eventArgs As Windows.Forms.FormClosedEventArgs) Handles Me.FormClosed m_oVBLocker = Nothing End Sub Private Sub VerifierLicence() Dim sMsgErr, sClient, sTitreFinal, sChemin As String Me.Text = sLogicielBigSoft & " - Version d'évaluation" sChemin = Application.StartupPath If bTrapErr Then On Error GoTo Erreur With m_oVBLocker .sLogiciel = sLogicielBigSoft .sCheminLicence = sChemin & "\" & sLicenceBigSoft sMsgErr = "" If .bVersionEnregistree(sMsgErr) Then sTitreFinal = .sLogiciel & " - Version enregistrée pour : [" & .sClient & "]" Else sTitreFinal = .sLogiciel & " - Version d'évaluation" If sMsgErr <> "" Then MsgBox(sMsgErr, MsgBoxStyle.Critical, sTitreMsg) End If End With Me.Text = sTitreFinal CmdVoirLicence.Enabled = True Exit Sub Erreur: AfficherMsgErreur(Err, "VerifierLicence") CmdVoirLicence.Enabled = False End Sub Private Sub CmdVoirLicence_Click(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles CmdVoirLicence.Click frmEnreg.Show() End Sub End Class frmEnreg.vb ' frmEnreg.vb : formulaire d'enregistrement de BigSoft ' ----------- Friend Class frmEnreg : Inherits Form Private m_oVBLocker As New clsVBLocker Private Const iPageContrat% = 0 Private Const iPageAuthentification% = 1 ' Enregistrement Private Const iPageActivation% = 2 Private Sub frmEnreg_Load(ByVal eventSender As Object, ByVal eventArgs As EventArgs) _ Handles MyBase.Load Dim sMsgErr, sFichier, sContrat, sChamp, sCleActivation As String Me.CmdAccepter.Enabled = False Me.CtrlOnglet.TabPages.Item(iPageAuthentification).Enabled = False Me.CtrlOnglet.TabPages.Item(iPageActivation).Enabled = False Me.CtrlOnglet.SelectedIndex = iPageContrat With m_oVBLocker .sLogiciel = sLogicielBigSoft .sCheminLicence = Application.StartupPath & "\" & sLicenceBigSoft ' Chargement du ficher Contrat.txt sFichier = Application.StartupPath & "\" & sContratBigSoft sContrat = "" If Not .bChargerFichierContrat(sFichier, sContrat) Then Exit Sub If sContrat <> "" Then Me.CmdAccepter.Enabled = True Me.TxtContrat.Text = sContrat ' Lecture du fichier Licence : .Lic sChamp = "" If .bLireChampLicence(sIniEMail, sChamp, sIniRubriqueInfosClient, , _ bAutoriserChaineVide:=True) Then Me.TxtEMail.Text = sChamp .sEMailClient = sChamp End If If .bLireChampLicence(sIniClient, sChamp, sIniRubriqueInfosClient, , _ bAutoriserChaineVide:=True) Then Me.TxtClient.Text = sChamp .sClient = sChamp End If If .bLireChampLicence(sIniCleAuthentification, sChamp, sIniRubriqueCle, , _ bAutoriserChaineVide:=True) Then Me.TxtCleAuthentification.Text = sChamp ' Pour autoriser à nouveau l'envoi de mail, il faut cliquer sur OK ' afin de générer la clé 'If bDebug Then Me.CmdEMail.Enabled = True End If sMsgErr = "" If Not .bVersionEnregistree(sMsgErr) Then If sMsgErr <> "" Then MsgBox(sMsgErr, MsgBoxStyle.Critical, sTitreMsg) Exit Sub End If ' Afficher qd même la licence mais désactiver les boutons Me.CtrlOnglet.TabPages.Item(iPageActivation).Enabled = True Me.CtrlOnglet.SelectedIndex = iPageActivation ' Lire la clé d'activation = débridage sCleActivation = "" .bLireChampLicence(sIniCleActivation, sCleActivation, sIniRubriqueCle) Me.TxtCleActivation.Text = sCleActivation LireCleActivation() Me.CmdCreerCleAuthentification.Visible = False Me.CmdAccepter.Visible = False Me.CmdRefuser.Visible = False Me.CtrlOnglet.TabPages.Item(iPageAuthentification).Enabled = True Me.TxtClient.Enabled = False Me.TxtEMail.Enabled = False End With End Sub Private Sub CmdAccepter_Click(ByVal eventSender As Object, ByVal eventArgs As EventArgs) _ Handles CmdAccepter.Click Me.CtrlOnglet.TabPages.Item(iPageAuthentification).Enabled = True Me.CtrlOnglet.TabPages.Item(iPageActivation).Enabled = False Me.CtrlOnglet.SelectedIndex = iPageAuthentification Me.CmdAccepter.Visible = False Me.CmdRefuser.Visible = False Dim sCleAuthentification, sMsg As String sCleAuthentification = "" If Not m_oVBLocker.bLireChampLicence(sIniCleAuthentification, sCleAuthentification, _ sIniRubriqueCle) Then Exit Sub sMsg = "Avez-vous reçu votre clé d'activation de la part de " & sEditeurBigSoft & " ?" If MsgBoxResult.No = MsgBox(sMsg, MsgBoxStyle.YesNo Or MsgBoxStyle.Question, _ m_oVBLocker.sLogiciel) Then Exit Sub Me.CtrlOnglet.TabPages.Item(iPageActivation).Enabled = True Me.CtrlOnglet.SelectedIndex = iPageActivation Me.TxtClient.Enabled = False Me.TxtEMail.Enabled = False End Sub Private Sub CmdRefuser_Click(ByVal eventSender As Object, ByVal eventArgs As EventArgs) _ Handles CmdRefuser.Click Me.Close() End Sub Private Sub CmdCreerCleAuthentification_Click(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles CmdCreerCleAuthentification.Click ' Point d'entrée de la demande de licence du client Dim sMsgErr, sCleAuthentification As String With m_oVBLocker sMsgErr = "" If Not .bVerifierEMail((Me.TxtEMail).Text, sMsgErr) Then Me.TxtCleAuthentification.Text = sMsgErr Me.TxtEMail.Focus() Exit Sub End If If Me.TxtClient.Text = "" Then Me.TxtCleAuthentification.Text = "Saisir un nom de client" Me.TxtClient.Focus() Exit Sub End If .sClient = Me.TxtClient.Text ' Créer la clé d'authentification du client sCleAuthentification = "" If Not .bCreerCleAuthentification(sCleAuthentification, sMsgErr) Then Me.TxtCleAuthentification.Text = sMsgErr Exit Sub End If Me.TxtCleAuthentification.Text = sCleAuthentification ' Ecriture des renseignements dans le fichier .bEcrireChampLicence(sIniCleAuthentification, Me.TxtCleAuthentification.Text, _ sIniRubriqueCle) .bEcrireChampLicence(sIniEMail, Me.TxtEMail.Text, sIniRubriqueInfosClient) .bEcrireChampLicence(sIniClient, Me.TxtClient.Text, sIniRubriqueInfosClient) .bEcrireChampLicence(sIniLogiciel, .sLogiciel, sIniRubriqueInfosClient) CmdEMail.Enabled = True End With End Sub Private Sub CmdValiderCleActivation_Click(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles CmdValiderCleActivation.Click If Me.TxtCleActivation.Text = "" Then Exit Sub Dim sMsgErr, sCleActivation As String sCleActivation = Me.TxtCleActivation.Text sMsgErr = "" If Not m_oVBLocker.bTesterCleActivation(sCleActivation, sMsgErr) Then MsgBox("La clé d'activation est incorrecte : " & vbCrLf & _ sMsgErr, MsgBoxStyle.Critical) Me.TxtCleActivation.Focus() Exit Sub End If LireCleActivation() MsgBox("Félicitation : " & m_oVBLocker.sLogiciel & " est activé", _ MsgBoxStyle.Information) m_oVBLocker.bEcrireChampLicence(sIniCleActivation, sCleActivation, sIniRubriqueCle) ' 01/01/2008 Provoquer une revérification de licence dans frmBigSoft ' pour changer le statut dans la barre de titre glb_bLicenceVerifiee = False End Sub Private Sub LireCleActivation() ' Afficher les informations codées dans la clé With m_oVBLocker Me.LblNumeroLicence.Text = "N° de licence : " & .iNumeroLicence If .dDateExpiration = dDateIllimitee Then LblDateExpiration.Text = "Date d'expiration : Pas de limite dans le temps" Else LblDateExpiration.Text = "Date d'expiration : " & _ .dDateExpiration.ToString("dd/MM/yyyy") ' Marche parfois mais pas tjrs, par ex. pas dans la fenêtre d'Exécution : 'LblDateExpiration.Text = "Date d'expiration : " & _ ' VB6.Format(.dDateExpiration, "dd/mm/yyyy") End If Me.chkVersionEvaluation.CheckState = CheckState.Unchecked Me.chkOptionToutes.CheckState = CheckState.Unchecked Me.chkOption1.CheckState = CheckState.Unchecked Me.chkOption2.CheckState = CheckState.Unchecked Me.chkOption3.CheckState = CheckState.Unchecked Me.chkOption4.CheckState = CheckState.Unchecked Me.chkOption5.CheckState = CheckState.Unchecked If .bVersionEvaluation Then _ Me.chkVersionEvaluation.CheckState = CheckState.Checked If CBool(.iOptionsLogiciel And iMasqueToutesOptions) Then _ Me.chkOptionToutes.CheckState = CheckState.Checked If CBool(.iOptionsLogiciel And iMasqueOption1) Then _ Me.chkOption1.CheckState = CheckState.Checked If CBool(.iOptionsLogiciel And iMasqueOption2) Then _ Me.chkOption2.CheckState = CheckState.Checked If CBool(.iOptionsLogiciel And iMasqueOption3) Then _ Me.chkOption3.CheckState = CheckState.Checked If CBool(.iOptionsLogiciel And iMasqueOption4) Then _ Me.chkOption4.CheckState = CheckState.Checked If CBool(.iOptionsLogiciel And iMasqueOption5) Then _ Me.chkOption5.CheckState = CheckState.Checked End With End Sub Private Sub TxtEMail_TextChanged(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles TxtEMail.TextChanged Dim sMsgErr$ = "" If Not m_oVBLocker.bVerifierEMail((Me.TxtEMail).Text, sMsgErr) Then Me.TxtCleAuthentification.Text = sMsgErr Else Me.TxtCleAuthentification.Text = "" End If End Sub Private Sub CmdEMail_Click(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles CmdEMail.Click Dim sSujet$ = "Enregistrement de " & m_oVBLocker.sLogiciel Dim sContenu$ = sChampLogiciel & sSepar & m_oVBLocker.sLogiciel sContenu &= vbCrLf & sChampClient & sSepar & _ sGm & m_oVBLocker.sClient & sGm sContenu &= vbCrLf & sChampCourrielClient & sSepar & _ m_oVBLocker.sEMailClient sContenu &= vbCrLf & sChampCleAuthentification & sSepar & _ m_oVBLocker.sCleAuthentification If Not bEnvoyerCourriel(sVendeurDef, m_oVBLocker.sEMailVendeur, _ sSujet, sContenu) Then Exit Sub MsgBox(sMsgMailEnvoye & vbCrLf & _ "Veuillez fermer le formulaire d'enregistrement en attendant de recevoir votre clé d'activation.", _ MsgBoxStyle.Information, "Enregistrement de " & m_oVBLocker.sLogiciel) End Sub End Class modConstantesBigSoft.vb ' modConstantesBigSoft.vb : Constantes de BigSoft ' ----------------------- Module modConstantesBigSoft Public Const sLogicielBigSoft$ = "BigSoftV1.0" Public Const sLicenceBigSoft$ = "BigSoft.lic" Public Const sContratBigSoft$ = "Contrat.txt" Public Const sEditeurBigSoft$ = "Bigrosoft" ' 01/01/2008 Pour pb boucle infinie si expiration Public glb_bLicenceVerifiee As Boolean = False End Module modConstantes.vb ' modConstantes.vb : Module des constantes des projets liés à VBLocker ' ---------------- Module modConstantes ' Inutile, on peut le definir ici : ' <DefineConstants>Win32 = True, VBUnLocker = True</DefineConstants> '#Const VBUnLocker = True ' Avec VBExpress 2005, pour choisir le mode debug ou pas, il faut ' sélectionner le menu Build : Configuration Manager... Debug ou Release ' ... mais pour voir ce menu, il faut le demander !!! ' menu Tools : Options... : Projets and Solutions : "Show Advanced Build Configuration" ' inutile donc de définir la constante DEBUG directement : '#Const DEBUG = True '#Const DEBUG = False #If DEBUG Then Public Const bDebug As Boolean = True Public Const bRelease As Boolean = False Public Const bTrapErr As Boolean = False #Else Public Const bDebug As Boolean = False Public Const bRelease As Boolean = True Public Const bTrapErr As Boolean = True #End If Public Const sTitreMsg$ = "VBLocker" Public Const sVendeurDef$ = "Bigrosoft-Ventes" Public Const sEMailVendeurDef$ = "ventes@bigrosoft.com" Public Const sFichierLicenceDef$ = "BigSoft.lic" Public Const sMsgMailEnvoye$ = _ "Le courriel a été déposé dans la boite d'envoi :" & vbCrLf & _ "Le cas échéant, n'oubliez pas d'ouvrir votre messagerie pour l'envoi effectif." Public Const sLecteurDefaut$ = "C:\" Public Const iMaxInt16% = Short.MaxValue ' 32767 ' (2 ^ 15) - 1 Public Const iMaxInt32% = Integer.MaxValue ' CInt((2 ^ 31) - 1) ' = 2147483647 Public Const sIniRubriqueInfosClient$ = "Formulaire" Public Const sIniRubriqueCle$ = "Cle" Public Const sIniCleActivation$ = "CleActivation" Public Const sIniCleAuthentification$ = "CleAuthentification" Public Const sIniClient$ = "Client" Public Const sIniLogiciel$ = "Logiciel" Public Const sIniEMail$ = "EMail" ' Via courriel : Public Const sGm$ = """" Public Const sSepar$ = " : " Public Const sChampLogiciel$ = "Logiciel" Public Const sChampClient$ = "Client" Public Const sChampCourrielClient$ = "Courriel client" Public Const sChampCleAuthentification$ = "Cle d'authentification" Public Const sChampCleActivation$ = "Cle d'activation" ' Base du codage sur plusieurs caractères ' d'un entier long (4 octets en VB6) ' Entre 2 et 62 au maximum, ' par exemple, codage en base décimale (10), ' hexadécimale (16), en binaire (2), ... ' on enlève WXYZ afin de faciliter le cryptage avec le XOR ' car le nombre de caractères est une puissance de 2 Public Const iBaseCodage% = 32 ' Chiffres + MAJ - WXYZ ' Si iBaseCodage = 64 : Diminuez iLenNSD à 6 dans ClsVBLocker 'Public Const iBaseCodage% = 64 ' Chiffres + MAJ + min + 2 car. ' Désactiver ou revoir le cryptage si iBaseCodage n'est pas une puissance de 2 ' (sinon des caractères hors base vont apparaître après le cryptage) ' Augmenter la taille des champs (par ex. iLenNSD) si la base diminue 'Public Const iBaseCodage% = 62 ' Chiffres + MAJ + min 'Public Const iBaseCodage% = 36 ' Chiffres + MAJ 'Public Const iBaseCodage% = 10 ' Chiffres 'Public Const iBaseCodage% = 20 ' Chiffres + 10 premières MAJ ' Masques des bits codant les options offertes pour la licence achetée Public Const iMasqueVersionEvaluation% = 1 Public Const iMasqueToutesOptions% = 2 Public Const iMasqueOption1% = 4 Public Const iMasqueOption2% = 8 Public Const iMasqueOption3% = 16 Public Const iMasqueOption4% = 32 Public Const iMasqueOption5% = 64 ' Par convention : Public Const dDateIllimitee As Date = #1/1/2000# ' mm/jj/aaaa ' Champs de la clé de protection Public Structure TCleProtection Dim bVersionEvaluation As Boolean Dim iOptionsLogiciel% Dim iNumeroLicence% Dim dDateExpiration As Date Dim sLecteur$ ' C:\ ou autre Dim iNumeroSerieDisque% Dim sClient$ Dim iCSClient% ' CS pour CheckSum Dim sLogiciel$ Dim iCSLogiciel% Dim sEMail$ Dim iCSEMail% Dim sCleAuthentification$ Dim sCleActivation$ End Structure End Module modCourriel.vb ' modCourriel.vb : Module pour envoyer un courriel via la messagerie par défaut ' -------------- Module modCourriel ' API pour la fonction bEnvoyerCourriel Private Declare Function ShellExecute% Lib "shell32.dll" _ Alias "ShellExecuteA" (ByVal hwnd%, ByVal lpOperation$, _ ByVal lpFile$, ByVal lpParameters$, ByVal lpDirectory$, _ ByVal nShowCmd%) Public Function bEnvoyerCourriel(ByVal sNomDestinataire$, ByVal sCourrielDest$, _ ByVal sSujet$, ByVal sContenu$) As Boolean ' Envoyer un courriel via la messagerie par défaut ' (via un ShellExecute mailto) If bTrapErr Then On Error GoTo Erreur ' Créer la chaîne de commande avec les paramètres fournis Dim sCmd$ = "" If sSujet.Length > 0 Then sCmd = "&Subject=" & sSujet Const sSautLigneMailTo$ = "%0D%0A" ' 14/10/2007 Attention : les guillemets (") ne passent pas avec OutLook, ' il faut donc les enlever (les guillemets ne marchent qu'avec Outlook Express, ' à moins de trouver le bon codage ?) If sContenu.Length > 0 Then sCmd &= "&Body=" & _ sContenu.Replace(vbCrLf, sSautLigneMailTo).Replace("""", "") 'Dim sCC$, sCCC$ 'If Len(sCC) Then sCmd = sCmd & "&CC=" & sCC ' Copie Carbone ' Blind Carbon Coy : Copie Carbone Cachée 'If Len(sCCC) Then sCmd = sCmd & "&BCC=" & sCCC ' La pièce jointe ne fonctionne pas avec Outlook Express ' ce qui est genant car on ne sait pas comment le client va envoyer le message ' (il faut une solution qui fonctionne chez tous les clients, ' quel que soit leur logiciel de messagerie) ' Solution : mettre le contenu dans le corps du message, et faire une ' fonction d'import via le presse papier ' (l'autre solution est de passer par une session MAPI : ' fonctionne en général avec les pièces jointes sous Windows NT et >, ' mais pas toujours sous Windows 9x et Me) 'Const sCheminPJ$ = "C:\Tmp\BigSoft.lic" 'Const sCheminPJ$ = "C:/Tmp/BigSoft.lic" 'If sCheminPJ.Length > 0 Then sCmd &= "&Attach='" & sCheminPJ & "'" 'If sCheminPJ.Length > 0 Then sCmd &= "&attachment='" & sCheminPJ & "'" 'If sCheminPJ.Length > 0 Then sCmd &= "&attachment=" & sCheminPJ 'If sCheminPJ.Length > 0 Then sCmd &= "&attachment=" & """" & sCheminPJ & """" ' Remplacer le premier '&' (s'il existe) par un '?' If Mid(sCmd, 1, 1) = "&" Then Mid(sCmd, 1, 1) = "?" ' Ajouter la commande 'mailto:' et l'adresse Dim sDestinataire$ = sNomDestinataire & "<" & sCourrielDest & ">" sCmd = "mailto:" & sDestinataire & sCmd Const SW_SHOWNORMAL& = 1 ' 0 : Me.hwnd ShellExecute(0, "open", sCmd, vbNullString, vbNullString, SW_SHOWNORMAL) bEnvoyerCourriel = True Exit Function Erreur: AfficherMsgErreur(Err, "bEnvoyerCourriel") End Function End Module modCryptage.vb ' modCryptage.vb : Module de cryptage ' -------------- Module modCryptage #Const CryptagePerso = False Public Function sCrypter$(ByRef bCleAuthentification As Boolean, ByVal sCle$) ' Crypter/Décrypter une clé de façon symétrique donc réversible ' Remplacez ici sCrypterXOR par l'appel vers votre propre fonction ' de cryptage ' Vous pouvez utiliser 2 algo. distincts pour la clé d'authent. ' et la clé d'activation ' Attention ! la difficulté consiste à ne conserver que des ' caractères bien lisibles (compris dans la plage précisée ' par iBaseCodage) soit au maximum 64 caractères : 'Public Const iBaseCodage% = 64 ' Chiffres + MAJ + min + 2 car. ' Pour désactiver le cryptage : 'sCrypter = sCle: Exit Function #If CryptagePerso Then sCrypter = sCrypterPseudoAleatoire(bCleAuthentification, sCle) : Exit Function #Else sCrypter = sCrypterXOR(sCle) : Exit Function 'sCrypter = sCrypterXOR(sCrypter) ' Vérification de la réversibilité 'sCrypter = sCrypterMaFonctionDeCryptage(sCle) #End If End Function Private Function sCrypterXOR$(ByVal sCle$) Dim iCodeCarCrypte, iLen, i, iCodeCar, iCarXOR As Integer Dim iCar, iCarCrypte As Integer Dim sCleCryptee$ sCleCryptee = sCle iLen = Len(sCle) For i = 1 To iLen iCar = Asc(Mid(sCle, i, 1)) iCodeCar = iCoderCar(iCar) ' ------------------------------------- ' Algorythme de cryptage ' Oui c'est bête ! à vous de trouver un ' meilleur cryptage symétrique iCarXOR = i iCodeCarCrypte = iXORCar(iCodeCar, CInt(iCarXOR)) ' ------------------------------------- iCarCrypte = iCoderCar(iCodeCarCrypte, bDecoder:=True) ' Remplacer le caractère original par le caractère crypté Mid(sCleCryptee, i, 1) = Chr(iCarCrypte) CarSuivant: Next i sCrypterXOR = sCleCryptee End Function Function iXORCar%(ByRef iCar%, ByRef iNombre%) ' Appliquer un XOR sur le caractère pour le crypter de façon réversible ' Ne pas modifier les bits au-delà de la base afin d'éviter ' de faire apparaître un caractère hors-base Const iMasque6PremiersBits% = 63 ' Pour iBaseCodage% = 64 Const iMasque5PremiersBits% = 31 ' Pour iBaseCodage% = 32 Const iMasque4PremiersBits% = 15 ' Pour iBaseCodage% = 16 Const iMasque3PremiersBits% = 7 ' Pour iBaseCodage% = 8 Const iMasque2PremiersBits% = 3 ' Pour iBaseCodage% = 4 Select Case iBaseCodage Case 2 To 7 : iXORCar = (iNombre And iMasque2PremiersBits) Xor iCar Case 8 To 15 : iXORCar = (iNombre And iMasque3PremiersBits) Xor iCar Case 16 To 31 : iXORCar = (iNombre And iMasque4PremiersBits) Xor iCar Case 32 To 63 : iXORCar = (iNombre And iMasque5PremiersBits) Xor iCar Case 64 : iXORCar = (iNombre And iMasque6PremiersBits) Xor iCar Case Else : iXORCar = iCar End Select End Function Public Function iCoderCar%(ByRef iCodeCar%, Optional ByRef bDecoder As Boolean = False) ' Coder ou Décoder un caractère à partir de son code ASCII ' vers le numéro du caractère dans le jeu de caractères finaux ' (iBaseCodage = nbre de car. retenus pour le codage) ' Codage sur des caractères bien lisibles Const iCode0% = 48 Const iCode9% = iCode0 + 10 - 1 ' 57 Const iCodeA% = 65 Const iCodeZ% = iCodeA + 26 - 1 ' 90 Const iCode_a% = 97 Const iCode_z% = iCode_a + 26 - 1 ' 122 Const iCodeDiese% = 35 Const iCodeEtoile% = 42 ' Si iBaseCodage > 32 ' l'Amplitude de codage max. est = 26*2+10 = 62 ' 2^6 = 64, il faut donc ajouter 2 caractères en plus ' pour pouvoir faire un XOR, on choisit les ' caractères # et * car ils sont bien lisibles ' cf. iMasque7PremiersBits = 63 dans la fonction sCrypterXOR If bDecoder Then GoTo DecoderCar ' Modifier seulement les caractères bien lisibles ' 48 -> 57 : 0123... -> 9 Select Case iCodeCar ' 48 -> 57 : 0123... -> 9 Case iCode0 To iCode9 iCoderCar = iCodeCar - iCode0 ' 65 -> 90 : ABC... -> Z Case iCodeA To iCodeZ iCoderCar = iCodeCar - (iCodeA - 10) ' 55 ' 97 -> 122 : abc... -> z Case iCode_a To iCode_z iCoderCar = iCodeCar - (iCode_a - 26 - 10) ' 61 Case iCodeDiese : iCoderCar = 62 Case iCodeEtoile : iCoderCar = 63 Case Else iCoderCar = iCodeCar MsgBox("Caractère non autorisé !") : Exit Function End Select Exit Function DecoderCar: ' Remettre le caractère dans la plage lisible Dim iCodeCarBaseCodage, iCarDecode As Integer iCodeCarBaseCodage = iCodeCar 'Case 0: iCoderCar = 0 ' Pas de cryptage ' 0123... -> 9 : 48 -> 57 Select Case iCodeCarBaseCodage 'Case 0: iCoderCar = 0 ' Pas de cryptage ' 0123... -> 9 : 48 -> 57 Case 0 To 10 - 1 iCarDecode = iCodeCarBaseCodage + iCode0 ' ABC... -> Z : 65 -> 90 Case 10 To 26 + 10 - 1 ' 37 iCarDecode = iCodeCarBaseCodage + iCodeA - 10 ' 55 ' abc... -> z : 97 -> 122 Case 26 + 10 To 62 - 1 ' 36 à 61 iCarDecode = iCodeCarBaseCodage + iCode_a - 26 - 10 ' 61 Case 62 : iCarDecode = iCodeDiese Case 63 : iCarDecode = iCodeEtoile Case Else iCarDecode = iCodeCarBaseCodage MsgBox("Caractère non autorisé !") : Exit Function End Select iCoderCar = iCarDecode End Function End Module modIni.vb ' modIni.vb : Module de gestion des fichiers ini ' --------- Module modIni Private Declare Function WritePrivateProfileString% Lib "kernel32" Alias _ "WritePrivateProfileStringA" (ByVal lpApplicationName$, ByVal lpKeyName$, _ ByVal lpString$, ByVal lpFileName$) Private Declare Function GetPrivateProfileString% Lib "kernel32" Alias _ "GetPrivateProfileStringA" (ByVal lpApplicationName$, ByVal lpKeyName$, _ ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%, ByVal lpFileName$) Public Function bLireFichierIni(ByRef sCle$, ByRef sSection$, _ ByRef sFichier$, ByRef sValeur$, ByRef sDefaut$, _ Optional ByRef bNumerique As Boolean = True, _ Optional ByRef bBooleen As Boolean = False, _ Optional ByRef bPromptErr As Boolean = False) As Boolean ' Lire la valeur d'un champ dans un fichier ini If bTrapErr Then On Error GoTo Erreur Dim sContenu$ Dim iRet% sContenu = New String(Chr(0), 255) iRet = GetPrivateProfileString(sSection, sCle, "", sContenu, Len(sContenu), sFichier) If iRet > 0 Then sValeur = Left(sContenu, iRet) Else sValeur = sDefaut End If If bNumerique And Not bBooleen Then sValeur = CStr(Val(sValeur)) If bBooleen Then If CInt(sValeur) <> 0 Then sValeur = CStr(True) End If If bPromptErr And iRet <= 0 Then GoTo Erreur bLireFichierIni = True Exit Function Erreur: Dim sMsg$ sMsg = "Fonction: bLireFichierIni" & vbCrLf sMsg = sMsg & "Impossible de lire la rubrique [" & sCle & "]" sMsg = sMsg & vbCrLf & "dans la section [" & sSection & "]" sMsg = sMsg & vbCrLf & "dans le fichier [" & sFichier & "]" 'If Not IsDBNull(vDefaut) And CStr(vDefaut) <> "" Then If CStr(sDefaut) <> "" Then sMsg = sMsg & vbCrLf & "Défaut : [" & sDefaut & "]" End If AfficherMsgErreur(Err, "bLireFichierIni", sMsg) sValeur = sDefaut Exit Function End Function Public Function bEcrireFichierIni(ByRef sCle$, ByRef sSection$, _ ByRef sFichier$, ByRef sValeur$, _ Optional ByRef bNumerique As Boolean = False, _ Optional ByRef bBooleen As Boolean = False, _ Optional ByRef bPromptErr As Boolean = True) As Boolean ' Ecrire la valeur d'un champ dans un fichier ini If bTrapErr Then On Error GoTo Erreur ' Attention, si la rubrique ou le fichier n'existe pas, cette fct la crée ' L'erreur ne peut se produire qu'en cas d'échec d'accès (ou création) fichier Dim sContenu$ Dim iRet% 'If IsNumeric(vValeur) Then : attention !!! si n° de téléphone : 0 tronqué !!! If bBooleen Then 'sContenu = Str$(Val(vValeur)) : ne marche pas If CBool(sValeur) = True Then sContenu = "-1" Else sContenu = "0" End If ElseIf bNumerique Then sContenu = Str(sValeur) ' Pour conserver le pt décimal Else sContenu = sValeur ' Perte du pt décimal : ne pas utiliser si décimal End If iRet = WritePrivateProfileString(sSection, sCle, sContenu, sFichier) If bPromptErr And iRet <= 0 Then GoTo Erreur bEcrireFichierIni = True Exit Function Erreur: Dim sMsg$ sMsg = "Fonction: bEcrireFichierIni" & vbCrLf sMsg = sMsg & "Impossible d'écrire la rubrique [" & sCle & "]" sMsg = sMsg & vbCrLf & "dans la section [" & sSection & "]" sMsg = sMsg & vbCrLf & "dans le fichier [" & sFichier & "]" sMsg = sMsg & vbCrLf & _ "Cause possible : fichier protégé ou échec de l'écriture sur le lecteur" AfficherMsgErreur(Err, "bEcrireFichierIni", sMsg) End Function End Module modUtil.vb ' modUtil.vb : Module contenant quelques fonctions utilitaires ' ---------- Module modUtil Public Function iConv%(ByVal sTexte$, Optional ByVal iValDef% = 0) ' Traiter les erreurs de conversion d'un texte en Int32 If sTexte.Length = 0 Then iConv = iValDef : Exit Function If IsNumeric(sTexte) Then Try ' On peut encore dépasser la valeur max. Dim dVal# = CDbl(sTexte) If dVal > Integer.MaxValue Then iConv = iValDef Else iConv = CInt(sTexte) End If Catch iConv = iValDef End Try Else iConv = iValDef End If End Function Public Function bFichierExiste(ByVal sCheminFichier$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si un fichier correspondant est trouvé ' Ne fonctionne pas avec un filtre, par ex. du type C:\*.txt bFichierExiste = IO.File.Exists(sCheminFichier) If Not bFichierExiste And bPrompt Then _ MsgBox("Impossible de trouver le fichier :" & vbLf & sCheminFichier, _ MsgBoxStyle.Critical, sTitreMsg & " - Fichier introuvable") End Function Public Function bChoisirFichier(ByRef sCheminFichier$, ByVal sFiltre$, ByVal sExtDef$, _ ByVal sTitre$, Optional ByVal sInitDir$ = "") As Boolean ' Afficher une boite de dialogue pour choisir un fichier ' Exemple de filtre : "|Fichiers texte (*.txt)|*.txt|Tout les fichiers (*.*)|*.*" ' On peut indiquer le dossier initial via InitDir, ou bien via le chemin du fichier Static bInit As Boolean = False Dim ofd As New OpenFileDialog With ofd If Not bInit Then bInit = True If sInitDir.Length = 0 Then If sCheminFichier.Length = 0 Then .InitialDirectory = Application.StartupPath Else .InitialDirectory = IO.Path.GetDirectoryName(sCheminFichier) End If Else .InitialDirectory = sInitDir End If End If .CheckFileExists = True .DefaultExt = sExtDef .Filter = sFiltre .Multiselect = False .Title = sTitre .ShowDialog() If .FileName <> "" Then bChoisirFichier = True : sCheminFichier = .FileName End With End Function Public Sub OuvrirAppliAssociee(ByVal sCheminFichier$, _ Optional ByVal bMax As Boolean = False, _ Optional ByVal bVerifierFichier As Boolean = True) If bVerifierFichier Then ' Ne pas vérifier le fichier si c'est une URL à lancer If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Sub End If Dim p As New Process p.StartInfo = New ProcessStartInfo(sCheminFichier) If bMax Then p.StartInfo.WindowStyle = ProcessWindowStyle.Maximized p.Start() End Sub Public Sub AfficherMsgErreur(ByRef Erreur As Microsoft.VisualBasic.ErrObject, _ Optional ByVal sTitreFct$ = "", Optional ByVal sInfo$ = "", _ Optional ByVal sDetailMsgErr$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If Erreur.Number > 0 Then sMsg &= vbCrLf & "Err n°" & Erreur.Number.ToString & " :" sMsg &= vbCrLf & Erreur.Description End If If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr MsgBox(sMsg, MsgBoxStyle.Critical, sTitreMsg) End Sub Public Sub AfficherMsgErreur2(ByRef Ex As Exception, _ Optional ByVal sTitreFct$ = "", Optional ByVal sInfo$ = "", _ Optional ByVal sDetailMsgErr$ = "", _ Optional ByVal bCopierMsgPressePapier As Boolean = True, _ Optional ByRef sMsgErrFinal$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr If Ex.Message <> "" Then sMsg &= vbCrLf & Ex.Message.Trim If Not IsNothing(Ex.InnerException) Then _ sMsg &= vbCrLf & Ex.InnerException.Message End If If bCopierMsgPressePapier Then CopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Sub CopierPressePapier(ByVal sInfo$) ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur2(ex, "CopierPressePapier", _ bCopierMsgPressePapier:=False) End Try End Sub Public Function sLirePressePapier$() ' Lire les informations du presse-papier de Windows Try If Clipboard.ContainsText Then sLirePressePapier = Clipboard.GetText() Else sLirePressePapier = "" End If Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur2(ex, "sLirePressePapier", _ bCopierMsgPressePapier:=False) sLirePressePapier = "" End Try End Function End Module