VB 5/6-Tipp 0734: Eine Lizenz für das eigene Projekt realisieren
von Henrik Ilgen
Beschreibung
Dieser Tipp zeigt, wie man eine Lizenz in Form einer Klasse in das eigene Projekt einbauen kann.
Schwierigkeitsgrad: | Verwendete API-Aufrufe: keine | Download: |
'Dieser Quellcode stammt von http://www.activevb.de 'und kann frei verwendet werden. Für eventuelle Schäden 'wird nicht gehaftet. 'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum. 'Ansonsten viel Spaß und Erfolg mit diesem Source! '------------ Anfang Projektdatei Licensing.vbp ------------ '-------- Anfang Klasse "License" alias License.cls -------- Option Explicit 'Member-Variablen - Müssen über Eigenschaften (Properties) ausgelesen und/oder geschrieben werden Private m_LastDate As Date Private m_Checksum As Long ' Öffentliche Variablen - Können frei ausgelesen und geschrieben werden Public StartDate As Date Public EndDate As Date Public OneSystemOnly As Boolean Public Enum LicenseInfo LicenseOkay = 0 ' Alles in Ordnung FileManipulated = 1 ' Die Datei wurde verändert DateManipulated = 2 ' Die Windows-Uhr wurde verstellt LicenseExpired = 3 ' Die Lizenz ist ausgelaufen LicenseNotBegun = 4 ' Die Lizenz hat noch nicht angefangen WrongApplication = 5 ' Die Lizenz gilt für eine andere Anwendung (falsches Passwort) FileNotExisting = 6 ' Die Lizenz-Datei konnte nicht gefunden werden End Enum ' kleiner Trick, damit die Namen der Konstanten im Enum ihre Schreibweise beibehalten #If False Then Dim LicenseOkay, FileManipulated, DateManipulated, LicenseExpired, LicenseNotBegun Dim FunctionManipulated, WrongApplication #End If ' Das letzte Datum darf nicht verändert werden! Property Get LastDate() As Date LastDate = m_LastDate End Property ' Das Passwort muss nur festgelegt, nicht aber ausgelesen werden Property Let PassWord(RHS As String) m_Checksum = CheckSum(StrConv(RHS, vbFromUnicode)) End Property ' Schreibt eine Lizenz in eine Datei Public Sub WriteTo(FileName As String, Optional CPUID As String) Dim PropBag As New PropertyBag, FF As Byte, BA() As Byte 'Alle relevanten Daten in die PropertyBag schreiben Call PropBag.WriteProperty("Start", StartDate) Call PropBag.WriteProperty("End", EndDate) Call PropBag.WriteProperty("Last", Date) 'den Inhalt zwischenspeichern BA = NSGEncode(PropBag.Contents) Set PropBag = New PropertyBag 'Wieder in die PropertyBag schreiben Call PropBag.WriteProperty("Contents", BA) Call PropBag.WriteProperty("Decode", m_Checksum) Call PropBag.WriteProperty("Check", CheckSum(BA)) 'finales Zwischenspeichern BA = PropBag.Contents 'Datei vorsichtshalber löschen... On Error Resume Next Call Kill(FileName) On Error Goto 0 'Dateizugriffsnummer holen FF = FreeFile 'Und speichern Open FileName For Binary As #FF Put #FF, , BA Close #FF End Sub ' Liest eine Lizenz aus einer Datei Public Function ReadFrom(FileName As String) As LicenseInfo Dim PropBag As New PropertyBag, FF As Byte Dim BA() As Byte ' Muss leider sein 'Testen, ob die Datei existiert If Dir(FileName) = "" Then ReadFrom = FileNotExisting Exit Function End If 'Dateizugriffsnummer holen FF = FreeFile 'und die Datei auslesen Open FileName For Binary As #FF ReDim BA(LOF(FF)) Get #FF, , BA Close #FF 'Die Zuweisung ergibt einen Fehler, wenn die Datei manipuliert wurde On Error Goto Err_FileInvalid PropBag.Contents = BA On Error Goto 0 'gespeicherte Prüfsumme mit der tatsächlichen vergleichen If PropBag.ReadProperty("Check") <> CheckSum(PropBag.ReadProperty("Contents")) Then ReadFrom = FileManipulated Exit Function End If 'Wenn Prüfsumme des aktuellen Passwortes nicht mit der der Lizenz übereinstimmt, 'gilt die Lizenz nicht für die aktuelle Anwendung If Not m_Checksum = PropBag.ReadProperty("Decode") Then ReadFrom = WrongApplication Exit Function End If BA = NSGDecode(PropBag.ReadProperty("Contents")) 'Die Zuweisung ergibt einen Fehler, wenn die Datei manipuliert wurde On Error Goto Err_FileInvalid PropBag.Contents = BA On Error Goto 0 'Alle relevanten Daten auslesen m_LastDate = PropBag.ReadProperty("Last") StartDate = PropBag.ReadProperty("Start") EndDate = PropBag.ReadProperty("End") 'Wenn die Differenz zwischen aktuellem Datum und dem Datum 'des letzten Verwendens negativ ist, wurde an der Uhr gedreht If DateDiff("d", m_LastDate, Date) < 0 Then ReadFrom = DateManipulated Exit Function End If 'Wenn die Differenz zwischen aktuellem Datum und Startdatum der 'Lizenz negativ ist, hat die Lizenz noch nicht begonnen If DateDiff("d", StartDate, Date) < 0 Then ReadFrom = LicenseNotBegun Exit Function End If 'Wenn die Differenz zwischen aktuellem Datum und Enddatum der 'Lizenz positiv ist, ist die Lizenz abgelaufen If DateDiff("d", EndDate, Date) > 0 Then ReadFrom = LicenseExpired Exit Function End If 'Wenn bis hierher ausgeführt wurde, ist die Lizenz in Ordnung '(Oder die Funktion manipuliert ;-) ) ReadFrom = LicenseOkay 'Funktion verlassen Exit Function 'Wenn Ein Fehler aufgetreten ist: Err_FileInvalid: ReadFrom = FileManipulated End Function ' Entschlüsselung Private Function NSGDecode(Expression() As Byte) As Byte() Dim n As Long, Temp As Long, BA() As Byte Call Rnd(-1) Call Randomize(m_Checksum) ReDim BA(UBound(Expression)) For n = 0 To UBound(Expression) Temp = Expression(n) - Int(Rnd() * 256) If Temp < 0 Then Temp = Temp + 256 BA(n) = Temp Next n NSGDecode = BA End Function ' Verschlüsselung Private Function NSGEncode(Expression() As Byte) As Byte() Dim n As Long, BA() As Byte Call Rnd(-1) Call Randomize(m_Checksum) ReDim BA(UBound(Expression)) For n = 0 To UBound(Expression) BA(n) = (Expression(n) + Int(Rnd() * 256)) And &HFF Next n NSGEncode = BA End Function ' Berechnen einer Prüfsumme (eigener Algorithmus, kann angepasst werden) Private Function CheckSum(FromText() As Byte) As Long Dim n As Long For n = 0 To UBound(FromText) CheckSum = (CheckSum + FromText(n) * (2 - Cos(n) * _ FromText(n) ^ (1 / (n + 1)))) And &HFFFFFFFF Next n End Function '--------- Ende Klasse "License" alias License.cls --------- '--------- Anfang Formular "Form1" alias Form1.frm --------- ' Steuerelement: Rahmensteuerelement "Frame2" ' Steuerelement: Schaltfläche "Command2" auf Frame2 ' Steuerelement: Textfeld "Text4" auf Frame2 ' Steuerelement: Beschriftungsfeld "Label4" auf Frame2 ' Steuerelement: Rahmensteuerelement "Frame1" ' Steuerelement: Textfeld "Text3" auf Frame1 ' Steuerelement: Schaltfläche "Command1" auf Frame1 ' Steuerelement: Textfeld "Text2" auf Frame1 ' Steuerelement: Textfeld "Text1" auf Frame1 ' Steuerelement: Beschriftungsfeld "Label3" auf Frame1 ' Steuerelement: Beschriftungsfeld "Label2" auf Frame1 ' Steuerelement: Beschriftungsfeld "Label1" auf Frame1 ' Steuerelement: Beschriftungsfeld "Label5" Option Explicit Private MyLicense As New License Private Sub Command1_Click() MyLicense.StartDate = CDate(Text1.Text) MyLicense.EndDate = CDate(Text2.Text) MyLicense.PassWord = Text3.Text Call MyLicense.WriteTo(MakePath(App.Path) & "License.lic") Call MsgBox("Die Lizenz wurde in " & MakePath(App.Path) & "License.lic gespeichert.") End Sub Private Sub Command2_Click() MyLicense.PassWord = Text4.Text Select Case MyLicense.ReadFrom(MakePath(App.Path) & "License.lic") Case LicenseInfo.FileManipulated Call MsgBox("Die Lizenzdatei wurde verändert.") Case LicenseInfo.DateManipulated Call MsgBox("Die Windows-Uhr wurde verstellt.") ' Wenn an der Uhr gedreht wurde, darf die Lizenz nicht neu gespeichert werden, ' ansonsten würde die geänderte Zeit als letzte Zeit gespeichert - und das ' Rückdrehen der Uhr legitim. Mit einem zweifachen Start des Programms ließe ' sich somit die Lizenz aushebeln. Deswegen: Prozedur verlassen (Alternativ: ' Setzen eines Flags, das beim Speichern der Lizenz bewertet wird) Exit Sub Case LicenseInfo.LicenseExpired Call MsgBox("Die Lizenz ist nicht mehr gültig." & vbCr & _ "Sie endete am " & CStr(MyLicense.EndDate) & ".") Case LicenseInfo.LicenseNotBegun Call MsgBox("Die Lizenz ist noch nicht gültig." & vbCr & _ "Sie beginnt erst am " & CStr(MyLicense.StartDate) & ".") Case LicenseInfo.WrongApplication Call MsgBox("Die Lizenz ist nicht mit dieser Anwendung kompatibel (falsches Passwort)") Case LicenseInfo.FileNotExisting Call MsgBox("Die Lizenzdatei konnte nicht gefunden werden.") Case LicenseInfo.LicenseOkay Call MsgBox("Die Lizenz ist gültig.") End Select ' Die Lizenz-Datei erneut speichern, damit LastDate aktualisiert wird... Call MyLicense.WriteTo(MakePath(App.Path) & "License.lic") End Sub Private Sub Form_Load() ' Standardwerte festlegen Text1.Text = Date Text2.Text = DateAdd("d", 30, Date) End Sub Private Function MakePath(ParamArray Parts() As Variant) As String Dim n As Long For n = 0 To UBound(Parts) MakePath = Parts(n) & IIf(Right(Parts(n), 1) = "\", "", "\") Next n End Function '---------- Ende Formular "Form1" alias Form1.frm ---------- '------------- Ende Projektdatei Licensing.vbp -------------
Tipp-Kompatibilität:
Windows/VB-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
VB4 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
VB5 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
VB6 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
Ihre Meinung
Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.