Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0734: Eine Lizenz für das eigene Projekt realisieren

VB 5/6-Tipp 0734: Eine Lizenz für das eigene Projekt realisieren

 von Henrik Ilgen

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [5,25 KB]

'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  -------------