Produktaktivierung mit Testzeit-Beschränkung Viele Programme die es im Internet zum herunterladen gibt sind Shareware, das heißt sie haben entweder eine begrenzte Laufzeit und / oder haben nur eingeschränkte Funktionen. Nachdem man eine solche Anwendung installiert hat und sie das erste Mal startet, bekommt man oft einen Dialog auf dem steht, wie lange man noch diese Anwendung benutzen kann, bevor sie aktiviert werden muss.
Autor:  Falk von Broen	Bewertung:     [ Jetzt bewerten ]	Views:  31.235

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 17 Bewertung insgesamt: gut Durchschnittliche Bewertung: 3.5 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Viele Programme die es im Internet zum herunterladen gibt sind Shareware, das heißt sie haben entweder eine begrenzte Laufzeit und / oder haben nur eingeschränkte Funktionen. Nachdem man eine solche Anwendung installiert hat und sie das erste Mal startet, bekommt man oft einen Dialog auf dem steht, wie lange man noch diese Anwendung benutzen kann, bevor sie aktiviert werden muss.

In dem nachfolgenden Workshop möchte ich Ihnen nun zeigen, wie man so etwas in seiner eigenen VB-Anwendung professionell realisieren kann.

Zunächst wollen wir uns Gedanken darüber machen was so eine Shareware-Begrenzung mit Aktivierung alles können muss.

1. Die ganze Produktaktivierung und Testzeitraumbeschränkung sollte möglichst schwer zu umgehen sein. (Ausschließen kann man so was jedoch bei einer Shareware mit Aktivierungsmöglichkeit nicht, denn wer genügend Zeit investiert, kann irgendwann auch den besten Schutz knacken.)
2. Wir wollen dem Benutzer eine Testzeit gewähren, in der er das Programm uneingeschränkt nutzen kann. (Von der Methode, nur eine begrenze Anzahl von Funktionen in der Testzeit freizugeben, halte ich nicht sehr viel, denn oft werden dadurch wichtige Funktionen gesperrt, die der User unbedingt ausprobieren wollte und nach der er auch sein Kaufverhalten richtet.)
3. In dieser Testzeit und auch danach, soll der Anwender die Möglichkeit haben, das Programm kaufen zu können und dann mit Hilfe eines Schlüssels, dem so genannten Activation-Key freizuschalten.
4. Die Anwendung muss eine individuell auf jeden PC und Anwender zugeschnittene Product-ID generieren, die der potentielle Käufer dem Software-Hersteller zuschicken muss, damit dieser nach Zahlungseingang den Activation-Key aus der Product-ID generieren lassen kann und dann dem Käufer zuschicken kann.

Benötigte Module und Klassen

Fangen wir nun an, die benötigten Module anzulegen sowie eine Klasse für die Progressbar auf der ersten Form, die uns die verbleibende Testzeit anzeigen soll.

Folgende Module und Klassen werden benötigt:

• Modul basProductAkt_CryptProgCode
• Modul basProductAkt_FileExists
• Modul basProductAkt_HDDSerial
• Modul basProductAkt_RegistryCrypt
• Modul basProductAkt_SecureHash
• Modul basProductAkt_WinVersion
• Klasse clsXPProgBar

Das erste Modul (basProductAkt_CryptProgCode) enthält die Funktionen, die zur Erstellung der Produkt-ID und auch für den Activation-Key benötigt werden. Hier werden aber nur sozusagen Endergebnisse verarbeitet! In anderen Modulen gibt es noch Hilfsfunktionen für diese Funktionen.

Public Function ProductCode(code As String) As String
  Dim lProductCode As Long, i As Integer
 
  For i = 1 To Len(code) ' Quelle muss bei Auswertung angegeben werden
    lProductCode = lProductCode + Asc(Mid$(code, i, 5))
  Next i
 
  ProductCode = (Hex(lProductCode))
End Function

Public Function ProgCodeProf(ProgCode As String) As String
  ' Erstellt einen Code, bei dem nach jedem 5. Zeichen ein Bindestrich gesetzt wird
  Dim MakeCode As String
 
  For i = 1 To Len(ProgCode)
    If i Mod 5 = 0 Then
      MakeCode = MakeCode & Mid(ProgCode, i, 1) & "-"
    Else
      MakeCode = MakeCode & Mid(ProgCode, i, 1)
    End If
  Next
 
  If Right(MakeCode, 1) = "-" Then
    ' Wenn letztes Zeichen ein Bindestrich ist, dann weglöschen
    MakeCode = Mid(MakeCode, 1, (Len(MakeCode) - 1))
  Else
    ' Letztes Zeichen war kein Bindestrich, also alles beibehalten
    MakeCode = Mid(MakeCode, 1, Len(MakeCode))
  End If
 
  ' Übergibt den fertigen Code an die Funktion
  ProgCodeProf = MakeCode
End Function

Public Function MakeProductID(sUserName As String, sFirma As String, sEmail As String) As String
  Dim PCData
  Dim UserData
 
  ' Generiert die Produkt-ID
  PCData = GetVolSerialNo("C:") & GetWindowsVersion & App.EXEName & App.Minor _ 
    & App.LegalCopyright & App.Major & App.ProductName & App.Revision & App.Path
  UserData = sUserName & sFirma & sEmail
  MakeProductID = ProgCodeProf(SecureHash(PCData & UserData))
End Function

Public Function MakeActivationKey(sProductID As String) As String
  Dim CryptedKey As String
  Dim i As Long
  Dim NewChar As Long
 
  ' Übergibt den Wert einer Variablen
  CryptedKey = sProductID
 
  ' Generiert den Aktivierungsschlüssel
  i = 1
  Do Until i = Len(sProductID) + 1
    NewChar = Asc(Mid(sProductID, i, 1)) + 13
    CryptedKey = CryptedKey + Chr(NewChar)
    i = i + 1
  Loop
 
  MakeActivationKey = ProgCodeProf(SecureHash(CryptedKey))
End Function

Das nächste Modul (basProductAkt_FileExists) enthält die Funktionen, die nötig sind, um aus einer Datei etwas auszulesen bzw. um zu überprüfen, ob die Datei schon existiert.

Option Explicit
 
Public AnwendungsName As String
Public Benutzername As String
Public Firma As String
Public Email As String
Public ProductID As String
Public AktivationKey As String

Public Function FileExists(ByVal sFile As String) As Boolean
  ' Der Parameter sFile enthält den zu prüfenden Dateinamen
  Dim Size As Long
  On Local Error Resume Next
  Size = FileLen(sFile)
  FileExists = (Err = 0)
  On Local Error GoTo 0
End Function

Public Function ExtractData(File)
  On Error Resume Next
  Dim F As Integer
  F = FreeFile
  Open File For Input As #F
  Input #F, AnwendungsName
  Input #F, Benutzername
  Input #F, Firma
  Input #F, Email
  Input #F, ProductID
  Input #F, AktivationKey
  Close #F
End Function

In dem nun folgenden Modul (basProductAkt_HDDSerial) wird die Festplatten-Nummer ausgelesen, die ebenfalls ein fester Bestandteil der Produkt-ID ist.

Option Explicit
 
' Seriennumer des angegebenen Laufwerks ermitteln
Public Function GetVolSerialNo(ByVal sDrive As String) As Long
  Dim sComputer As String
  Dim oWMI As Object
  Dim oDrives As Object
  Dim oDrive As Object
 
  ' Fehlerbehandlung aktivieren
  On Error GoTo ErrHandler
 
  sDrive = UCase$(sDrive)
  If Len(sDrive) > 2 Then sDrive = Left$(sDrive, 2)
  If Right$(sDrive, 1) <> ":" Then sDrive = sDrive & ":"
 
  ' aktuelles System
  sComputer = "."
 
  ' WMI-Objekt erstellen
  Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
    & sComputer & "\root\cimv2")
 
  ' WMI-Abfrage erstellen
  Set oDrives = oWMI.ExecQuery("Select * from Win32_LogicalDisk WHERE DeviceID='" & sDrive & "'")
 
  For Each oDrive In oDrives
    ' SerialNo von HEX-Darstellung nach Long-Wert umwandeln
    GetVolSerialNo = CLng("&H" & oDrive.VolumeSerialNumber)
    Exit For
  Next
  On Error GoTo 0
  Exit Function
 
ErrHandler:
  ' Fehler!
  ' Entweder kein WMI installiert oder ungültige Laufwerksangabe
  On Error GoTo 0
End Function

Das Modul (basProductAkt_RegistryCrypt) enthält alle Funktionen, die notwendig sind, um auf die Registry zuzugreifen und Einträge zu erstellen. Hier wird auch die Testzeit berechnet und ein Eintrag erstellt, der das letzte Nutzungsdatum enthält, damit nicht manipuliert werden kann. Des Weiteren sind in dem Modul noch Funktionen enthalten, die dazu dienen, die Datumswerte in der Registry zu verschlüsseln, damit sie nicht aufgespürt werden können. Im Modul ganz oben befinden sich zwei Registry-Schlüssel, diese sollten geändert werden, damit niemand anderes die Testzeit-Daten aufspüren kann. Was sich natürlich von selber versteht, ich erwähne es aber trotzdem noch mal: Das Erst-Nutzungsdatum, das beinhaltet, wann die Anwendung das erste mal gestartet wurde, sollte unter einem anderen Registry-Schlüssel liegen, als der Wert, wann die Anwendung das letzte mal aufgerufen worden ist.

Option Explicit
 
' Konstanten für den Registrypfad, in dem die Testzeiten gespeichert werden
Public Const RegDateAblauf = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\" & _
  "SystemCertificates\TrustedPublisher\CTLsTRE\CTL01"
Public Const RegDateLastUse = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\" & _
  "SystemCertificates\TrustedPublisher\CTLsRTE\CTL02"

Funktionen um Zugriff auf die Registry zu haben

' Gibt den Wert des Schlüssels aus "Path" zurück
Public Function RegRead(Path As String) As String
  Dim ws As Object
 
  On Error GoTo ErrHandler
  Set ws = CreateObject("WScript.Shell")
  RegRead = ws.RegRead(Path)
  Exit Function
 
ErrHandler:
  RegRead = ""
End Function

' Schreibt den Wert aus "Value" als den Typ aus "Typ"
' in den in "Path" angegebenen Schlüssel
Public Function RegWrite(ByVal Path As String, _
  ByVal Value As String, _
  Optional ByVal Typ As String = "REG_SZ") As Boolean
 
  Dim ws As Object
 
  On Error GoTo ErrHandler
  Set ws = CreateObject("WScript.Shell")
  ws.RegWrite Path, Value, Typ
  RegWrite = True
  Exit Function
 
ErrHandler:
  RegWrite = False
End Function

' Löscht den Schlüssel aus "Path"
Public Function RegDelete(Path As String) As Boolean
  Dim ws As Object
 
  On Error GoTo ErrHandler
  Set ws = CreateObject("WScript.Shell")
  ws.RegDelete Path
  RegDelete = True
  Exit Function
 
ErrHandler:
  RegDelete = False
End Function

Public Function IsTrialVersion(sPfadAblauf As String, sPfadLastUse As String) As Boolean
  Dim Ablaufdatum As Date
  Dim LetzteBenutzung As Date
 
  ' Registrywerte laden
  If IsDate(RegistryDecrypt(RegRead(sPfadAblauf))) = True Then
    ' Liest aus Registry und entschlüsselt gleich
    Ablaufdatum = RegistryDecrypt(RegRead(sPfadAblauf))  
  Else
    IsTrialVersion = False
    Exit Function
  End If
 
  If IsDate(RegistryDecrypt(RegRead(sPfadLastUse))) = True Then
    ' Liest aus Registry und entschlüsselt gleich
    LetzteBenutzung = RegistryDecrypt(RegRead(sPfadLastUse))
  Else
    IsTrialVersion = False
    Exit Function
  End If
 
  If Ablaufdatum > Now Then
    ' Prüft ob das Datum nicht zurückgestellt wurde
    If LetzteBenutzung > Now Then
      IsTrialVersion = False
    Else
      IsTrialVersion = True
    End If
 
  Else
    ' Wenn die Testzeit abgelaufen ist, soll IsTrialVersion auf False gestellt werden
    IsTrialVersion = False
  End If
 
End Function

Public Function GetRestTestZeit(sPfadAblauf As String) As Integer
  Dim Ablaufdatum As Date
  Dim RestTestZeit As Integer
 
  ' Registrywerte laden
  Ablaufdatum = RegistryDecrypt(RegRead(sPfadAblauf)) ' Liest aus Registry und entschlüsselt gleich
 
  ' Übergibt die Resttage an die Funktion
  GetRestTestZeit = Ablaufdatum - Now
End Function

' ===============================================================================
' Diese Verschlüsselungsfunktion dient zur Datumsverschlüsselung, 
' um die Einträge in der Registry unauffindbar zu machen.
Public Function RegistryEncrypt(Message As String) As String
  Randomize
  On Error GoTo errorcheck
  Dim tempmessage As String
  Dim basea As Integer
  Dim tempbasea As String
  Message = Reverse_String(Message)
  tempmessage = CStr(Message)
  basea = Int(Rnd * 73) + 37
 
  If basea < 0 Then
    tempbasea = CStr(basea)
    tempbasea = Right(tempbasea, Len(tempbasea) - 1)
    basea = CInt(tempbasea)
  End If
 
  basea = basea / 2
  RegistryEncrypt = CStr(basea) + ";"
 
  For x = 1 To Len(tempmessage)
    RegistryEncrypt = RegistryEncrypt + CStr(Asc(Left(tempmessage, x)) - basea) + ";"
    basea = basea + 1
    tempmessage = Right(tempmessage, Len(tempmessage) - 1)
  Next x
 
errorcheck:
End Function

' Diese Funktion entschlüsselt wieder die Datumswerte
Public Function RegistryDecrypt(code As String) As String
  On Error GoTo errorcheck
  Dim basea As Integer
  Dim tempcode As String
 
  Do Until Left(code, 1) = ";"
    tempcode = tempcode + Left(code, 1)
    code = Right(code, Len(code) - 1)
  Loop
 
  basea = CInt(tempcode)
  tempcode = ""
  code = Right(code, Len(code) - 1)
 
  Do Until code = ""
 
    Do Until Left(code, 1) = ";"
      tempcode = tempcode + Left(code, 1)
      code = Right(code, Len(code) - 1)
    Loop
 
    RegistryDecrypt = RegistryDecrypt + Chr(CLng(tempcode) + basea)
      code = Right(code, Len(code) - 1)
      tempcode = ""
      basea = basea + 1
    Loop
 
    RegistryDecrypt = Reverse_String(RegistryDecrypt)
errorcheck:
End Function

Public Function Reverse_String(Message As String) As String
  ' Hilfsfunktion, die zum verschlüsseln dient
  For x = 1 To Len(Message)
    Reverse_String = Reverse_String + Left(Right(Message, x), 1)
  Next x
 
End Function

Als nächstes kommen wir zum Herzstück unserer Produktaktivierung. In diesem Modul (basProductAkt_SecureHash) wird die 20-zeichenlange Produkt-ID generiert und daraus auch der Aktivation-Key. Was ich zu diesem Code noch dazu sagen muss: Er ist nicht von mir gecodet, sondern ich habe ihn irgendwo mal im Internet gefunden. Er erzeugt eine 160 bit-Verschlüsselung und man kann aus diesem Code unmöglich die ursprüngliche Message wieder zurückgenerieren.

'  modSecureHash   A VB Implementation of the Secure Hash Algorithm SHA-1
'
'  The function SecureHash generates a 160-bit (20-hex-digit) message digest
'  for a given message (String) of any length.  The digest is unique to the
'  message.  It is not possible to recover the message from the digest.  The
'  only way to find the source message for a digest is by the brute force
'  hashing of all possible messages and comparison of their digests.  For a
'  complete description see FIPS Publication 180-1:
'
'     http://www.itl.nist.gov/fipspubs/fip180-1.htm  (HTML version)
'     http://csrc.nist.gov/fips/fip180-1.txt         (plain text version)
'
'  The SecureHash function successfully hashes the three sample messages given
'  in the appendices to this publication.
'
'  Note: this is non-conforming implementation of SHA-1.  A conforming
'  implementation must handle messages up to 2^64 bytes; this one
'  theoretically handles only up to 2^32 bytes.  However, processing time will
'  effectively limit its use to messages of less than one megabyte.  For large
'  messages, use the Internet Explorer implementation of SHA-1 (advapi32.dll,
'  CryptCreateHash and CryptHashData using ALG_SID_SHA).
'
'------------------------------------------------------------------------------
Option Explicit
 
' -- type for handling unsigned 32-bit words
Public Type Word
  B0 As Byte
  B1 As Byte
  B2 As Byte
  B3 As Byte
End Type

' =====  Bitwise Operators on Words  =====
Public Function AndW(w1 As Word, w2 As Word) As Word
  Dim w As Word
 
  w.B0 = w1.B0 And w2.B0
  w.B1 = w1.B1 And w2.B1
  w.B2 = w1.B2 And w2.B2
  w.B3 = w1.B3 And w2.B3
 
  AndW = w
End Function

Public Function OrW(w1 As Word, w2 As Word) As Word
  Dim w As Word
 
  w.B0 = w1.B0 Or w2.B0
  w.B1 = w1.B1 Or w2.B1
  w.B2 = w1.B2 Or w2.B2
  w.B3 = w1.B3 Or w2.B3
 
  OrW = w
End Function

Public Function XorW(w1 As Word, w2 As Word) As Word
  Dim w As Word
 
  w.B0 = w1.B0 Xor w2.B0
  w.B1 = w1.B1 Xor w2.B1
  w.B2 = w1.B2 Xor w2.B2
  w.B3 = w1.B3 Xor w2.B3
 
  XorW = w
End Function

Public Function NotW(w As Word) As Word
  Dim w0 As Word
 
  w0.B0 = Not w.B0
  w0.B1 = Not w.B1
  w0.B2 = Not w.B2
  w0.B3 = Not w.B3
 
  NotW = w0
End Function

Public Function AddW(w1 As Word, w2 As Word) As Word
  Dim i As Integer, w As Word
 
  i = CInt(w1.B3) + w2.B3
  w.B3 = i Mod 256
  i = CInt(w1.B2) + w2.B2 + (i \ 256)
  w.B2 = i Mod 256
  i = CInt(w1.B1) + w2.B1 + (i \ 256)
  w.B1 = i Mod 256
  i = CInt(w1.B0) + w2.B0 + (i \ 256)
  w.B0 = i Mod 256
 
  AddW = w
End Function

Public Function CircShiftLeftW(w As Word, n As Integer) As Word
  Dim d1 As Double, d2 As Double
 
  d1 = WordToDouble(w)
  d2 = d1
 
  d1 = d1 * (2 ^ n)
  d2 = d2 / (2 ^ (32 - n))
 
  CircShiftLeftW = OrW(DoubleToWord(d1), DoubleToWord(d2))
End Function

' =====  Word Conversion Functions  =====
Public Function WordToHex(w As Word) As String
  WordToHex = Right("0" & Hex(w.B0), 2) & Right("0" & Hex(w.B1), 2) & _
              Right("0" & Hex(w.B2), 2) & Right("0" & Hex(w.B3), 2)
End Function

Public Function HexToWord(h As String) As Word
  HexToWord = DoubleToWord(Val("&H" & h & "#"))
End Function

Public Function DoubleToWord(n As Double) As Word
  Dim w As Word
 
  w.B0 = Int(DMod(n, 2 ^ 32) / (2 ^ 24))
  w.B1 = Int(DMod(n, 2 ^ 24) / (2 ^ 16))
  w.B2 = Int(DMod(n, 2 ^ 16) / (2 ^ 8))
  w.B3 = Int(DMod(n, 2 ^ 8))
 
  DoubleToWord = w
End Function

Public Function WordToDouble(w As Word) As Double
  WordToDouble = (w.B0 * (2 ^ 24)) + (w.B1 * (2 ^ 16)) + (w.B2 * (2 ^ 8)) + w.B3
End Function

' =====  Real modulus  =====
Public Function DMod(Value As Double, divisor As Double) As Double
  Dim n As Double
 
  n = Value - (Int(Value / divisor) * divisor)
  If (n < 0) Then
    n = n + divisor
  End If
 
  DMod = n
End Function

' =====  SHA-1 Functions  =====
Public Function F(t As Integer, B As Word, c As Word, D As Word) As Word
  Select Case t
    Case Is <= 19
      F = OrW(AndW(B, c), AndW((NotW(B)), D))
    Case Is <= 39
      F = XorW(XorW(B, c), D)
    Case Is <= 59
      F = OrW(OrW(AndW(B, c), AndW(B, D)), AndW(c, D))
    Case Else
      F = XorW(XorW(B, c), D)
  End Select
End Function

Public Function SecureHash(inMessage As String) As String
  Dim inLen As Long, inLenW As Word, padMessage As String
  Dim numBlocks As Long, w(0 To 79) As Word
  Dim blockText As String, wordText As String
  Dim i As Long, t As Integer, temp As Word
 
  Dim K(0 To 3) As Word
  Dim H0 As Word, H1 As Word, H2 As Word, H3 As Word, H4 As Word
  Dim A As Word, B As Word, c As Word, D As Word, E As Word
 
  ' -- pad the message  
  inLen = Len(inMessage)
  inLenW = DoubleToWord(CDbl(inLen) * 8)
  padMessage = inMessage & Chr(128) & String((128 - (inLen Mod 64) - 9) Mod 64, Chr(0)) & _
      String(4, Chr(0)) & Chr(inLenW.B0) & Chr(inLenW.B1) & Chr(inLenW.B2) & Chr(inLenW.B3)
  numBlocks = Len(padMessage) / 64
 
  ' -- initialize the buffers  
  K(0) = HexToWord("5A827999")
  K(1) = HexToWord("6ED9EBA1")
  K(2) = HexToWord("8F1BBCDC")
  K(3) = HexToWord("CA62C1D6")
 
  H0 = HexToWord("67452301")
  H1 = HexToWord("EFCDAB89")
  H2 = HexToWord("98BADCFE")
  H3 = HexToWord("10325476")
  H4 = HexToWord("C3D2E1F0")
 
  ' -- hash the message  
  For i = 0 To numBlocks - 1
    blockText = Mid(padMessage, (i * 64) + 1, 64)
    For t = 0 To 15
      wordText = Mid(blockText, (t * 4) + 1, 4)
      w(t).B0 = Asc(Mid(wordText, 1, 1))
      w(t).B1 = Asc(Mid(wordText, 2, 1))
      w(t).B2 = Asc(Mid(wordText, 3, 1))
      w(t).B3 = Asc(Mid(wordText, 4, 1))
    Next t
 
    For t = 16 To 79
      w(t) = CircShiftLeftW(XorW(XorW(XorW(w(t - 3), w(t - 8)), w(t - 14)), w(t - 16)), 1)
    Next t
 
    A = H0
    B = H1
    c = H2
    D = H3
    E = H4
 
    For t = 0 To 79
      temp = AddW(AddW(AddW(AddW(CircShiftLeftW(A, 5), F(t, B, c, D)), E), w(t)), K(t \ 20))
      E = D
      D = c
      c = CircShiftLeftW(B, 30)
      B = A
      A = temp
    Next t
 
    H0 = AddW(H0, A)
    H1 = AddW(H1, B)
    H2 = AddW(H2, c)
    H3 = AddW(H3, D)
    H4 = AddW(H4, E)
  Next i
 
  SecureHash = WordToHex(H0) & WordToHex(H1) & WordToHex(H2) & WordToHex(H3) & WordToHex(H4)
End Function

Das letzte Modul (basProductAkt_WinVersion) ist ebenfalls noch mal ein fester Bestandteil der Produkt-ID, denn hier wird die installierte Windowsversion ermittelt.

Option Explicit
 
' Zunächst die benötigten API-DeklarationenPrivate Const VER_PLATFORM_WIN32s As Long = 0
Private Const VER_PLATFORM_WIN32_WINDOWS As Long = 1
Private Const VER_PLATFORM_WIN32_NT As Long = 2
Private Const VER_NT_SERVER As Long = &H3
Private Const VER_NT_WORKSTATION As Long = &H1
Private Const VER_SUITE_PERSONAL As Long = &H200
Private Const VER_SUITE_DATACENTER As Long = &H80
Private Const VER_SUITE_ENTERPRISE As Long = &H2
 
' der alte Standard
Private Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformId As Long
  szCSDVersion As String * 128
End Type
 
' gibt's ab NT 4.0 mit SP6 (vgl. MSDN-Library)
Private Type OSVERSIONINFOEX
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformId As Long
  szCSDVersion As String * 128
  wServicePackMajor As Integer
  wServicePackMinor As Integer
  wSuiteMask As Integer
  wProductType As Byte
  wReserved As Byte
End Type
 
' nicht Standard-Deklaration, sondern
' "lpVersionInformation As OSVERSIONINFOEX"!
Private Declare Function GetVersionEx Lib "kernel32" Alias _
  "GetVersionExA" ( _
 lpVersionInformation As OSVERSIONINFOEX) As Long

' Windows-Version bestimmen
 Public Function GetWindowsVersion() As String
  Dim lRet As Long
  Dim VerInfo1 As OSVERSIONINFOEX  ' neuer Datentyp
  Dim VerInfo2 As OSVERSIONINFO    ' alter Datentyp
 
  On Error Resume Next
 
  ' hier wird die Größe des Datentyps festgelegt
  VerInfo1.dwOSVersionInfoSize = Len(VerInfo1)
 
  lRet = GetVersionEx(VerInfo1)
  If lRet = 0 Then
    ' wenn der erste Aufruf von GetVersionEx fehlgeschlagen
    ' hat, dann einfach die Größe des übergebenen
    ' Datentyps auf die des alten Typs ändern
    VerInfo1.dwOSVersionInfoSize = Len(VerInfo2)
 
    ' Versionsabfrage erneut aufrufen; wenn das auch
    ' schiefgeht, dann Funktion verlassen
    If GetVersionEx(VerInfo1) = 0 Then Exit Function
  End If
 
  ' jetzt kommt ein Wust von Prüfungen; vgl. dazu auch wieder
  ' den entsprechenden Eintrag für OSVERSIONINFOEX in der
  ' MSDN-Library
  With VerInfo1
    Select Case .dwPlatformId
      Case VER_PLATFORM_WIN32s
        GetWindowsVersion = "Win32s für Windows 3.x"
 
      Case VER_PLATFORM_WIN32_WINDOWS
        Select Case .dwMinorVersion
          Case 0
            Select Case UCase(Trim(.szCSDVersion))
              Case "A"
                GetWindowsVersion = "Windows 95 A"
              Case "B", "C"
                GetWindowsVersion = "Windows 95 OSR2"
              Case Else
                GetWindowsVersion = "Windows 95"
            End Select
 
          Case 10
            Select Case UCase(Trim(.szCSDVersion))
              Case "A"
                GetWindowsVersion = "Windows 98 SE"
              Case Else
                GetWindowsVersion = "Windows 98"
            End Select
 
        Case 90
          GetWindowsVersion = "Windows ME"
        End Select
 
      Case VER_PLATFORM_WIN32_NT
        Select Case .dwMajorVersion
          Case 3
            GetWindowsVersion = "Windows NT 3." & CStr(.dwMinorVersion)
 
          Case 4
            If CInt(Right$(Trim(.szCSDVersion), 1)) >= 6 Then
              ' mindestens Service-Pack 6 installiert
              ' OSVERSIONINFOEX-Struktur kann komplett
              ' ausgewertet werden
              If .wProductType = VER_NT_WORKSTATION Then
                GetWindowsVersion = "Windows NT 4.0 Workstation"
              Else
                GetWindowsVersion = "Windows NT 4.0 Server"
              End If
            Else
              GetWindowsVersion = "Windows NT 4.0"
            End If
 
          Case 5
            Select Case .dwMinorVersion
              Case 0
                If .wProductType = VER_NT_WORKSTATION Then
                  GetWindowsVersion = "Windows 2000 Professional"
                Else
                  If (.wSuiteMask And VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE Then
                    GetWindowsVersion = "Windows 2000 Advanced Server"
                  ElseIf (.wSuiteMask And VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER Then
                    GetWindowsVersion = "Windows 2000 Datacenter Server"
                  Else
                    GetWindowsVersion = "Windows 2000 Server"
                  End If
                End If
 
              Case 1
                If .wProductType = VER_NT_WORKSTATION Then
                  If (.wSuiteMask And VER_SUITE_PERSONAL) = VER_SUITE_PERSONAL Then
                    GetWindowsVersion = "Windows XP Home Edition"
                  Else
                    GetWindowsVersion = "Windows XP Professional"
                  End If
                Else
                  GetWindowsVersion = "Neue, unbekannte Windows-Version"
                End If
              Case Else
                GetWindowsVersion = "Neue, unbekannte Windows-Version"
            End Select
 
          Case Else
            GetWindowsVersion = "Unbekannte Version"
        End Select
      Case Else
        GetWindowsVersion = "Unbekannte Version"
    End Select
  End With
End Function

Private Function Trim(ByVal InString As String) As String
  Trim = LTrim(RTrim(InString))
End Function

Public Function LTrim(ByVal InString As String) As String
  While InStr(Chr$(0) + Chr$(9) + Chr$(32), Left$(InString, 1)) > 0
    InString = Mid$(InString, 2)
  Wend
  LTrim = InString
End Function

Public Function RTrim(ByVal InString As String) As String
  While InStr(Chr$(0) + Chr$(9) + Chr$(32), Right$(InString, 1)) > 0
    InString = Left$(InString, Len(InString) - 1)
  Wend
  RTrim = InString
End Function

Nun brauchen wir noch ein Klassenmodul (clsXPProgBar). Sie dient dazu, damit uns unsere Produktaktivierung eine schöne Progressbar im XP-Style anzeigt, von der wir die restliche Testzeit ablesen können. Auch dieser Code stammt nicht von mir, sondern ich habe ihn mir damals vom VB@rchiv heruntergeladen.

' **********************************************************************
' *
' *   XP Style ProgressBar Marke Eigenbau (VB6 Klasse)
' *
' *   Das nachfolgende Klassenmodul generiert aus einem übergebenen
' *   Shape eine XP-Progressbar. Es werden vier Color-Styles
' *   in den XP-Farben Grün, Blau, Olive und Silber zur Verfügung
' *   gestellt. Optional kann eine prozentuale Fortschrittsanzeige
' *   eingeblendet werden. Weiterhin kann die Anzeige als Block oder
' *   Smooth erfolgen. Der Event "Progress" feuert den prozentualen
' *   Fortschritt in die aufrufende Form zurück.
' *
' *   September 2005 - VB-Power.net       www.vb-power.net
' *
' **********************************************************************
Option Explicit
 
Public Enum XPColorStyle
   XPGreen = &H79E671
   XPBlue = &HE1A780
   XPOlive = &H8CC0B1
   XPSilver = &HB19395
End Enum
 
Public Enum XPBarStyle
   Smooth = 1
   Block = 3
End Enum
 
Public Enum XPBackStyle
   Transparent = 0
   Undurchsichtig = 1
End Enum
 
Public Event Progress(lProzent As Long)
 
Private cBackColor As OLE_COLOR
Private cBackStyle As XPBackStyle
Private cBarStyle As XPBarStyle
Private cBorderColor As OLE_COLOR
Private cColorStyle As OLE_COLOR
Private cShape As VB.Shape
Private tShape As VB.Shape
Private cLabel As VB.Label
Private cShowProzent As Boolean
Private cMax As Long
Private cValue As Long

' =========================================
' Hauptroutine zum Erzeugen der ProgressBar
' =========================================
Public Sub InitBar(oForm As Form, oShape As Shape)
  If oForm Is Nothing Then Exit Sub
  If oShape Is Nothing Then Exit Sub
  Set cShape = oShape
 
  ' Dynamisches (zweites) Shape erzeugen
  Set tShape = oForm.Controls.Add("VB.Shape", "tmpShape" & Format(Int(1000000 * Rnd) + 1))
  With tShape
    Set .Container = oShape.Container
    .BackColor = cColorStyle
    .BackStyle = 1
    .BorderStyle = 0
    .FillColor = cBackColor
    .FillStyle = cBarStyle
    .Shape = 0
    .Move cShape.Left + (3 * Screen.TwipsPerPixelX), _
      cShape.Top + (3 * Screen.TwipsPerPixelY), _
      0, _
      cShape.Height - (5 * Screen.TwipsPerPixelY)
    .ZOrder
    .Visible = True
  End With
 
  ' Dynamisches Label für die prozentuale Anzeige erzeugen
  Set cLabel = oForm.Controls.Add("VB.Label", "tmpLabel" & Format(Int(1000000 * Rnd) + 1))
  With cLabel
    Set .Container = oShape.Container
    .Alignment = 2
    .AutoSize = True
    .BackStyle = 0
    .BorderStyle = 0
    .Caption = "0 %"
    .FontName = "Verdana"
    .FontSize = 8
    .Move cShape.Left + (cShape.Width / 2), _
       cShape.Top + (cShape.Height / 2) - _
       (.Height / 2)
 
    .ZOrder
    .Visible = True
  End With
 
  With cShape
    .BackColor = cBackColor
    .BorderColor = cBorderColor
    .BackStyle = cBackStyle
    .Shape = 4
  End With
End Sub

' =========================================
' Hauptroutine zum Zeichnen der ProgressBar
' =========================================
Private Sub DrawBar()
  Dim x As Long
  Dim p As Long
 
  On Error Resume Next
  x = ((cShape.Width - (6 * Screen.TwipsPerPixelX)) / cMax) * cValue
  If x > cShape.Width - (6 * Screen.TwipsPerPixelX) Then
    x = cShape.Width - (6 * Screen.TwipsPerPixelX)
  End If
  tShape.Width = x
 
  ' Progress berechnen und Event feuern
  p = Int(cValue / cMax * 100 + 0.5)
  If (p < 0) Then p = 0
  If (p > 100) Then p = 100
  RaiseEvent Progress(p)
 
  If cShowProzent Then
    cLabel.Caption = Format(p) & " %"
  End If
End Sub

' =====================' Klasse initialisieren
' =====================
Private Sub Class_Initialize()
  cBackColor = vbWhite
  cBackStyle = Undurchsichtig
  cBarStyle = Block
  cBorderColor = &H808080
  cColorStyle = XPGreen
  cMax = 100
  cShowProzent = True
  cValue = 0
  Randomize Timer
End Sub

' ========================
' Eigenschaften der Klasse
' ========================
Public Property Let BackColor(ByVal vData As OLE_COLOR)
  cBackColor = vData
  cShape.BackColor = cBackColor
  tShape.FillColor = cBackColor
End Property
 
Public Property Get BackColor() As OLE_COLOR
  BackColor = cBackColor
End Property

Public Property Let BackStyle(ByVal vData As XPBackStyle)
  cBackStyle = vData
  cShape.BackStyle = cBackStyle
End Property
 
Public Property Get BackStyle() As XPBackStyle
  BackStyle = cBackStyle
End Property

Public Property Let BarStyle(ByVal vData As XPBarStyle)
  cBarStyle = vData
  tShape.FillStyle = cBarStyle
End Property
 
Public Property Get BarStyle() As XPBarStyle
  BarStyle = cBarStyle
End Property

Public Property Let BorderColor(ByVal vData As OLE_COLOR)
  cBorderColor = vData
  cShape.BorderColor = cBorderColor
End Property
 
Public Property Get BorderColor() As OLE_COLOR
  BorderColor = cBorderColor
End Property

Public Property Let ColorStyle(ByVal vData As XPColorStyle)
  cColorStyle = vData
  tShape.BackColor = cColorStyle
End Property
 
Public Property Get ColorStyle() As XPColorStyle
  ColorStyle = cColorStyle
End Property

Public Property Let Max(ByVal vData As Long)
  cMax = vData
End Property
 
Public Property Get Max() As Long
  Max = cMax
End Property

Public Property Let ShowProzent(ByVal vData As Boolean)
  cShowProzent = vData
  cLabel.Visible = cShowProzent
End Property
 
Public Property Get ShowProzent() As Boolean
  ShowProzent = cShowProzent
End Property

Public Property Let Value(ByVal vData As Long)
  cValue = vData
  DrawBar
End Property
 
Public Property Get Value() As Long
  Value = cValue
End Property

Benötigte Formen und Controls

Als nächstes werden wir die Oberflächen der Testzeit-Erinnerung und der Produktaktivierung gestalten.
Fangen wir nun zuerst mit der Testzeitbeschränkung an. Dazu wird folgendes benötigt:

Folgende Controls sind nur zum Testen und sollten deshalb auf Visible = False gesetzt werden.

Nachdem wir die Controls und Eigenschaften gesetzt haben, sollte die Form Testzeit-Erinnerung ungefähr so ausschauen:

...zur Laufzeit schaut das Ganze dann so aus:

Nun wenden wir uns dem Produkt-Aktivierungsdialog zu. Hier wird es etwas komplizierter zu erklären, denn es wird mit Steuerelement-Feldern gearbeitet. Es wird folgendes benötigt:

Form / Control	Eigenschaften
1 Form (frmProductActivation)	BorderStyle	1- Fest Einfach
	Caption	Produkt Aktivierung
	ShowInTaskbar	True
	StartUpPosition	1 - Fenstermitte
1 Linie (Line1)	-	-
1 CommandButton (cmdZurück)	Caption	<< Zurück
1 CommandButton (cmdWeiter)	Caption	Weiter >>
1 CommandButton (cmdCancel)	Caption	Abbrechen
1 Image (imgHand)	Picture	( Symbol hier downloaden)
	Visible	False

Darüber platzieren wir 4 Pictureboxen (picProductAktivierung) denen wir die Steuerelement-Eigenschaft zuweisen. (Die einzelnen Pictureboxen können zur Bearbeitung mit dem ShortKey "STRG" + "J" in den Vordergrund geholt werden.)

Auf die erste PictureBox platzieren wir nun folgendes:

Das Ganze sollte nun ungefähr so ausschauen:

...zur Laufzeit schaut das Ganze dann so aus:

Machen wir nun mit dem zweiten PictureBox-Steuerelement weiter. Darauf wird folgendes platziert:

Wenn man die Controls richtig platziert hat, sollte das Ganze so aussehen:

...zur Laufzeit schaut das Ganze dann so aus:

Beginnen wir nun mit dem dritten PictureBox-Steuerelement. Darauf wird folgendes platziert:

Das Ganze müsste dann ungefähr so ausschauen:

...zur Laufzeit schaut das Ganze dann so aus:

Auf unser letztes Picture-Steuerelement setzen wir nun noch folgendes:

Das Ganze müsste dann so aussehen:

...zur Laufzeit schaut das Ganze dann so aus:

Die Formen mit Code befüllen

Nachdem wir die Oberflächen beider Formen angelegt haben, können wir es nun wieder etwas gemütlicher angehen lassen. Anfangen werde ich wieder mit der Form Testzeit-Erinnerung. Im Wesentlichen beschränkt sich der Code darauf, bereits beim Start zu überprüfen, ob die Anwendung schon aktiviert worden ist, ob sie das erste Mal gestartet wurde oder ob sie noch in der Testversion läuft. Weiter möchte ich jedoch jetzt nicht auf die Form eingehen, denn alles Weitere kann direkt im Code nachgelesen werden, da ich mich bemüht habe, alles so gut wie möglich zu kommentieren. Fügen Sie also nachfolgenden Code in die Form frmStartUpTrial ein:

Option Explicit
 
Private WithEvents RestZeitBar As clsXPProgBar 'Für Progessbar "Marke Eigenbau"
 
' ===================================================================
' Diese Buttons sind nur zum Austesten gedacht und sollten später
' gelöscht werden.
Private Sub cmdActivationDateChanger_Click()
  RegWrite RegDateAblauf, RegistryEncrypt(txtDate.Text)
End Sub
 
Private Sub cmdGetDate_Click()
  txtDate.Text = RegistryDecrypt(RegRead(RegDateAblauf))
End Sub
 
Private Sub cmdKillDate_Click()
  RegDelete RegDateAblauf
  RegDelete RegDateLastUse
End Sub
 
' ===================================================================

Private Sub cmdGoOnTrial_Click()
  If IsTrialVersion(RegDateAblauf, RegDateLastUse) = True Then
    ' Hier wird die Hauptform aufgerufen, nachdem überprüft wurde, 
    ' ob noch eine Testzeit vorhanden ist    
    ' frmMain.show
    Unload Me
  Else
    ' Wenn Testzeit abgelaufen ist nur beenden
    Unload Me
    End
  End If
End Sub

Private Sub cmdBuy_Click()
  ' Ruft das Bestell- und Aktivierungsfenster auf
  frmProductActivation.Show vbModal
End Sub

Private Sub Form_Load()
  ' ============================================================
  ' Löscht alle Daten in der Registry (NUR ZUM AUSTESTEN)
  ' RegDelete (RegDateAblauf)
  ' RegDelete (RegDateLastUse)
  ' ============================================================
  ' Initialisieren der Progressbar
  Set RestZeitBar = New clsXPProgBar
  With RestZeitBar
    .InitBar Me, pgbRestZeit ' Hier wird Progressbar ehemals Shape inizialisiert
    .BarStyle = Block
    .ShowProzent = False
    .ColorStyle = XPGreen
    .Max = 30
  End With
 
  ' Prüft, ob schon Einträge in der Registry vorhanden sind, 
  ' ansonsten werden neue geschrieben
  If RegRead(RegDateAblauf) = "" Then RegWrite RegDateAblauf, RegistryEncrypt(Now + 30)
  If RegRead(RegDateLastUse) = "" Then RegWrite RegDateLastUse, RegistryEncrypt(Now)
 
  ' Ab hier dient der Code, um zu überprüfen ob die Anwendung schon aktiviert wurde
  If FileExists(App.Path & "\" & "ProductLicenseFile.plf") = True Then
    ExtractData (App.Path & "\" & "ProductLicenseFile.plf")
 
    ' Überprüft die ProduktID, damit da nicht manipuliert wurde
    If MakeProductID(Benutzername, Firma, Email) = ProductID Then
 
      If AktivationKey = MakeActivationKey(ProductID) Then
        ' Weil Programm schon aktiviert, soll nun alles weitere übersprungen werden
        ' und diese Form entladen werden, damit das Hauptprogramm starten kann
        Unload Me
        ' frmMain.Show
        Exit Sub
      End If
 
    Else
      ' MsgBox "Es wurde versucht, dass Programm zu manipulieren!", vbCritical
      ' Hier könnte noch irgend eine Aktion eingebaut werden, wie z.B. dass das 
      ' Programm gar nicht mehr getestet werden kann, oder dass man sich erst mit 
      ' dem Softwarehersteller in Verbindung setzen muss
    End If
 
  Else
 
  End If
 
  ' Wenn es noch eine Testzeit gibt...
  If IsTrialVersion(RegDateAblauf, RegDateLastUse) = True Then
 
    ' Schreibt letzte Nutzung des Programms in die Registry
    RegWrite RegDateLastUse, RegistryEncrypt(Now)
 
    ' Setzt Value an der Progressbar
    RestZeitBar.Value = GetRestTestZeit(RegDateAblauf)
    lblRestTestZeit.Caption = GetRestTestZeit(RegDateAblauf) & _
      " von 30 Tagen verbleibend"
    lblAblaufdatum.Caption = "Ablauf der Testversion: " & _
      RegistryDecrypt(RegRead(RegDateAblauf))
    lblTrialInfo.Caption = "Dies ist eine zeitlich begrenzte Testversion von " & _
      App.Title & _
      " Sie können den vollen Funktionsumfang der Software 30 Tage lang " & _
      "unverbindlich testen." & vbCrLf & _
      "Wenn Ihnen die Software gefällt und Sie diese über den Testzeitraum " & _
      "hinaus nutzen möchen, klicken Sie einfach auf die Schaltfläche ''Bestellen " & _
      "und Aktivieren''."
  Else
    ' Schreibt letzte Nutzung des Programms in die Registry
    RegWrite RegDateLastUse, RegistryEncrypt(Now)
 
    ' Hier können die Texte gesetzt werden, die bei Ablauf
    ' der Aktivierung angezeigt werden sollen.
    MsgBox "Die Testversion von " & App.Title & " ist am " & _
      RegistryDecrypt(RegRead(RegDateAblauf)) & _
      " abgelaufen!" & vbCrLf & vbCrLf & _
      "Um das Programm weiter uneingeschränkt nutzen zu können, " & _
      "aktivieren Sie es bitte.", vbCritical
 
    ' Setzt Value an der Progressbar
    RestZeitBar.Value = 0
    lblRestTestZeit.Caption = "0 von 30 Tagen verbleibend"
    lblAblaufdatum.Caption = "Ablauf der Testversion: " & _
      RegistryDecrypt(RegRead(RegDateAblauf))
    lblTrialInfo.Caption = "Diese Testversion von " & App.Title & _
      " ist leider abgelaufen. Sie konnten " & _
      "30 Tage lang den vollen Funktionsumfang der Software testen." & vbCrLf & _
      "Wenn Ihnen die Software gefallen hat und Sie diese über den Testzeitraum " & _
      "hinaus nutzen möchten, klicken Sie einfach auf die Schaltfläche ''Bestellen " & _
      "und Aktivieren''."
 
    ' Den Weiterbutton in einen Beenden-Button umformen
    cmdGoOnTrial.Caption = "Beenden"
  End If
 
End Sub

Jetzt fehlt nur noch als einzige und letzte Form der Produkt-Aktivierungsassistent. Auch hier möchte ich nicht weiter auf den Code eingehen, denn ich habe ihn ebenfalls gut kommentiert. Die einzigen Hinweise die ich noch geben möchte sind, dass hier die Überprüfung und Aktivierung nur über einen Button erfolgt - dem Weiter-Button. Aus diesem Grunde empfehle ich jedem, bevor er an diesem Code etwas ändert, sicherst mal richtig einzulesen, denn in diesem einen Sub wimmelt es gerade nur so von If-Bedingungen.

Es besteht die Möglichkeit diese Form später auch einmal aus der Hauptform heraus aufzurufen, denn wenn ein Anwender das Programm bestellen möchte, entscheidet er sich oft während er es nutzt. Man kann dann die Produkt-Aktivierung ganz einfach wie folgt aufrufen:

frmProductActivation.Show vbModal

So, nun fügen Sie noch folgenden Code in die Form frmProductActivation ein:

' Dient dazu, dem FormUnload-Ereigniss mitzuteilen, dass das Programm neu gestartet 
' werden muss, um die Produktaktivierung abzuschließen
Dim ActivationSuccess As Boolean 
 
' Prüft welches Kontainer-Picture gerade "On Top" ist
Dim WhoIsVisible As Long 	  
 
' Öffnet Standard-Email-Programm
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 Function OpenEmail(ByVal sAddress As String) As Boolean
  OpenEmail = ShellExecute(0, "open", "mailto:" & sAddress, "", "", 1) > 32
End Function

Private Sub cmdCancel_Click()
  Unload Me ' Entlädt die Form
  ' ...die Abfrage, ob wirklich beendet werden soll, enthält das Form_Unload-Ereignis
End Sub

Private Sub cmdWeiter_Click()
 
  WhoIsVisible = WhoIsVisible + 1
 
  ' Wenn die Aktivierungs-Informationsdatei schon existiert, soll er gleich 
  ' zum Aktivieren springen
  ' ...und damit er nicht hängen bleibt, muss auch überprüft werden, von wo 
  ' aus der Button Weiter geklickt wurde
  If WhoIsVisible = 1 And FileExists(App.Path & "\" & _
    "ProductLicenseFile.plf") = True Then WhoIsVisible = 2
 
  If WhoIsVisible = 2 Then
    ' Wenn Aktivierungs-Informationsdatei existiert, dann sofort 
    ' Datein in Textboxen schreiben
    If FileExists(App.Path & "\" & "ProductLicenseFile.plf") = True Then
      ExtractData (App.Path & "\" & "ProductLicenseFile.plf")
 
        If txtUserName.Text = "" And txtFirma.Text = "" And txtEmail.Text = "" Then
          txtUserName.Text = Benutzername
          txtFirma.Text = Firma
          txtEmail.Text = Email
        End If
    End If
 
    ' Fehlerbehandlung bei Falscheingabe des Benutzernamens
    If txtUserName.Text = "" Or Len(txtUserName.Text) < 3 Then
      MsgBox "Bitte einen Benutzernamen angeben (mind. 3 Zeichen)!", vbExclamation
      WhoIsVisible = WhoIsVisible - 1
 
      If FileExists(App.Path & "\" & "ProductLicenseFile.plf") = False Then
        txtUserName.SetFocus
        Exit Sub
      Else
        GoTo 10
      End If
    End If
 
    ' Fehlerbehandlung bei Falscheingabe der Firma
    If txtFirma.Text = "" Or Len(txtFirma.Text) < 3 Then
      MsgBox "Bitte einen Firmennamen angeben (mind. 3 Zeichen)! " & _
      "(Bei Privatleuten ''keine'' eingeben.)", vbExclamation
      WhoIsVisible = WhoIsVisible - 1
 
      If FileExists(App.Path & "\" & "ProductLicenseFile.plf") = False Then
        txtFirma.SetFocus
        Exit Sub
      Else
        GoTo 10
      End If
    End If
 
    ' Fehlerbehandlung bei Falscheingabe der Email-Adresse
    If txtEmail.Text = "" Or Len(txtEmail.Text) < 3 Then
      MsgBox "Bitte eine Email-Adresse angeben (mind. 3 Zeichen)!", vbExclamation
      WhoIsVisible = WhoIsVisible - 1
 
      If FileExists(App.Path & "\" & "ProductLicenseFile.plf") = False Then
        txtEmail.SetFocus
        Exit Sub
      Else
        GoTo 10
      End If
    End If
 
    ' Generiert die Produkt-ID
    ProductID = MakeProductID(txtUserName.Text, txtFirma.Text, txtEmail.Text)
    txtProductCode.Text = ProductID
 
    ' Wenn die Aktivierungs-Informationsdatei noch nicht existiert, soll er die 
    ' jetzt anlegen
    ' ...und wenn sie existiert, dann soll er sie trotzdem überschreiben, da 
    ' die Benutzerinformationen sich vielleicht verändert haben könnten.
    ' Das ganze in eine Datei speichern
    Dim F As Integer
    F = FreeFile
 
    Open App.Path & "\" & "ProductLicenseFile.plf" For Output As F
    Print #F, App.Title
    Print #F, txtUserName.Text
    Print #F, txtFirma.Text
    Print #F, txtEmail.Text
    Print #F, txtProductCode.Text
    Close F
  End If
 
  If WhoIsVisible = 3 Then
 
    ' Generiert ActivationKey
    ActivationKey = MakeActivationKey(ProductID)
 
    ' Überprüft, ob der eingegebene Aktivierungsschlüssel stimmt
    If ActivationKey = txtActivationKey.Text Then
 
      ' Aktivierungsschlüssel mit in die Datei schreiben
      Dim A As Integer
      A = FreeFile
 
      Open App.Path & "\" & "ProductLicenseFile.plf" For Output As A
      Print #A, App.Title
      Print #A, txtUserName.Text
      Print #A, txtFirma.Text
      Print #A, txtEmail.Text
      Print #A, txtProductCode.Text
      Print #A, txtActivationKey.Text
      Close A
 
      ' Wenn Produktaktivierung abgeschlossen wurde, 
      ' dann nur noch fertig stellen möglich
      ActivationSuccess = True
      cmdCancel.Caption = "Fertig stellen"
      cmdWeiter.Visible = False
      cmdZurück.Visible = False
      cmdCancel.SetFocus
    Else
      ' Wenn ein falscher Aktivierungscode eingegeben wurde
      WhoIsVisible = WhoIsVisible - 1
      MsgBox "Fehler bei der Aktivierung!" & vbCrLf & vbCrLf & _
        "Bitte überprüfen Sie den Aktivierungsschlüssel! " & _
        "Beachten Sie bei der Eingabe, dass Sie alle " & _
        "Zeichen inklusive ''-'' eingeben und auf Groß- bzw. " & _
        "Kleinschreibung achten!", vbExclamation
 
      txtActivationKey.SetFocus ' Setzt Fokus auf Aktivierungsfeld
    End If
  End If
 
  If WhoIsVisible = 0 Then ' Wenn erste PictureBox gewählt, wird Button abgeschaltet
    cmdZurück.Enabled = False
    Exit Sub ' Überspringt den Rest
  Else
    cmdZurück.Enabled = True
  End If
 
  ' Die ContainerPictureBoxen ändern
  Dim i As Integer
 
  For i = 0 To picProductAktivierung.UBound
    picProductAktivierung(i).Visible = (i = WhoIsVisible)
  Next i
 
  picProductAktivierung(WhoIsVisible).ZOrder 0
  DoEvents
 
  ' Setzt den Fokus, nachdem die Konainerbox(PictureElement) 
  ' gewechselt wurde, da sonst auf Fehler läuft
  If WhoIsVisible = 1 Then txtUserName.SetFocus
  If WhoIsVisible = 2 Then txtActivationKey.SetFocus
  If WhoIsVisible = 3 Then cmdCancel.SetFocus
End Sub

Private Sub cmdZurück_Click()
  WhoIsVisible = WhoIsVisible - 1
 
  ' PictureBox ein/ausblenden
  Dim i As Integer
 
  For i = 0 To picProductAktivierung.UBound
    picProductAktivierung(i).Visible = (i = WhoIsVisible)
  Next i
 
  picProductAktivierung(WhoIsVisible).ZOrder 0
  DoEvents
 
  If WhoIsVisible = 0 Then ' Wenn erste PictureBox gewählt, wird Button abgeschaltet
    cmdZurück.Enabled = False
    Exit Sub 	' Überspringt den Rest
  Else
    cmdZurück.Enabled = True
  End If
End Sub

Private Sub Form_Load()
  ' Texte schreiben
  txtUserName.Text = ""
  txtFirma.Text = ""
  txtEmail.Text = ""
 
  lblAllgemeinTitel.Caption = "Willkommen zur Produktaktivierung" & vbCrLf & _
    "von " & App.Title
  lblGetUserDataTitel.Caption = "Benutzerinformationen sammeln..." & vbCrLf & _
    "(Schritt 1 von 3)"
  lblActivationTitel.Caption = "Produkt aktivieren..." & vbCrLf & _
    "(Schritt 2 von 3)"
  lblReadyToRunTitel.Caption = "Aktivierung fertigstellen..." & vbCrLf & _
    "(Schritt 3 von 3)"
  lblReadyToRunInfo.Caption = App.Title & " wurde erfolgreich aktiviert. " & _
    "Bitte bewahren Sie den " & _
    "Aktivierungsschlüssel sorgfältig auf, um die Anwendung bei Bedarf " & _
    "neu installieren zu können."
  lblAssistentInfo.Caption = "Dieser Assistent wird sie durch die " & _
    "Produktaktivierung von " & App.Title & " führen."
  lblActivationInfo.Caption = "Es wurde eine Produkt-ID für " & App.Title & _
    " generiert." & vbCrLf & _
    "Um die Software nun zu aktivieren, bestellen Sie bitte den " & _
    "Aktivierungsschlüssel entweder über Telefon, oder Email. Vergessen " & _
    "Sie dabei nicht, die Produkt-ID mit anzugeben!"
  lblUserInfo.Caption = "Um " & App.Title & " zu personalisieren, sodass " & _
    "es nur auf Ihrem Computer verwendet " & _
    "werden kann, benötigen wir einige Angaben." & vbCrLf & vbCrLf & _
    "Alle Angaben, die Sie hier machen, werden nur verschlüsselt auf Ihrem " & _
    "Computer gespeichert und nicht an uns oder Dritte weitergegeben!"
  lblAllgemeinInfo1.Caption = "Zur der Zeit der digitalen Medien und des " & _
    "Internets, nimmt die elektronische Produkt-Priaterie immer mehr zu. " & _
    "Um dem vorzubeugen, haben wir eine Produktaktivierung für unsere Software " & _
    "entwickelt, die einen Schlüssel generiert, der speziell auf Ihren " & _
    "Computer abgestimmt ist."
  lblAllgemeinInfo2.Caption = "Der Aktivierungsschlüssel unterscheidet sich " & _
    "zum Freischaltcode darin, da der Code schon zur Entwicklungszeit " & _
    "festgelegt ist, oder unabhängig von Hardware und Software " & _
    "arbeitet. Der Aktivierungsschlüssel ist sozusagen eine Weiterentwicklung, " & _
    "denn er ist abhängig von Hard- bzw. Software."
 
  ' Mauszeiger auf lblEmailAdresse festlegen
  lblEmailAdresse.MouseIcon = imgHand.Picture
  lblEmailAdresse.MousePointer = 99
 
  ' Aktivierungserfolg auf False setzten (dient dazu, um dem Abbrechen-Buton 
  ' wissen zu lassen, was er unternehmen soll)
  ActivationSuccess = False
 
  ' ==================================================================
  WhoIsVisible = 0 ' Erste PictureBox wird gewählt
  If WhoIsVisible = 0 Then ' Wenn erste PictureBox gewählt, wird Button abgeschaltet
    cmdZurück.Enabled = False
    ' Exit Sub ' Überspringt den Rest
  Else
    cmdZurück.Enabled = True
  End If
 
  ' PictureBox ein/ausblenden
  Dim i As Integer
 
  For i = 0 To picProductAktivierung.UBound
    picProductAktivierung(i).Visible = (i = WhoIsVisible)
  Next i
 
  picProductAktivierung(WhoIsVisible).ZOrder 0
  DoEvents
End Sub

Private Sub Form_Unload(cancel As Integer)
  If ActivationSuccess = False Then
    If MsgBox("Soll die Produktaktivierung von " & App.Title & _
      " wirklich abgebrochen werden?", _
      vbQuestion + vbYesNo) = vbYes Then
      Unload Me
    Else
      cancel = True
      Exit Sub
    End If
 
  Else
    ' Wenn Aktivierung erfolgreich war und auf Fertigstellen gedrückt wurde
    MsgBox "Um Die Produktaktivierung von " & App.Title & _
      " fertig zu stellen, muss die Anwendung jetzt beendet werden!", vbInformation
    Unload Me
  End If
End Sub

Private Sub lblEmailAdresse_Click()
  OpenEmail ("fbroen@skenet.de")
End Sub

Wie erstelle ich nun als Hersteller den Aktivierungs-Key?

Sicherlich werden sich einige im Laufe der Beschreibung gefragt haben, wie man jetzt als Hersteller oder Entwickler dem Käufer den Aktivierungsschlüssel generiert. Das ist ganz einfach zu erklären: Die Produkt-ID beinhaltet alles nötige, um daraus den Aktivierungs-Key zu erstellen. Damit sich jetzt keiner die Mühe zu machen braucht, sich so einen Key-Generator selber zu basteln, habe ich ihn hier zum downloaden bereit gestellt. Am Ende des Workshops ist der Link dazu.

Schlussbemerkung

Dieser Code ist sehr umfangreich und ist vielleicht aus diesem Grund nicht immer für jede Anwendung geeignet. Wer jedoch sein Programm richtig schützen möchte und es so programmieren möchte, dass man es später einmal freischalten lassen kann, dem empfehle ich, diese Produktaktivierung zumindest als Anregung oder "Code-Lager" zu benutzen, um sich vielleicht eine noch bessere Aktivierung zu bauen.

Wer jetzt z. B. in seine Anwendung auch noch eine Funktionsbegrenzung in der Testversion einbauen möchte, diese aber nach Aktivierung aufheben möchte, der kann den nachfolgenden Code in seine Hauptform einfügen und dann z.B. einige Button deaktivieren lassen, oder irgendwo ein Label aufleuchten lassen, in dem dann irgend etwas von einer Testzeit oder etwas anderem steht. Hier nun der Code:

' Prüft ob Trialversion oder Vollversion
If FileExists(App.Path & "\" & "ProductLicenseFile.plf") = True Then
  ExtractData (App.Path & "\" & "ProductLicenseFile.plf")
 
  If Not AktivationKey = Empty Then
    ' Wenn Anwendung schon aktiviert ist, dann soll folgendes passieren...
  Else
    ' Wenn Anwendung noch nicht aktiviert ist, dann soll folgendes passieren...
  End If
 
Else
  ' Wenn die Datei ProductLicenseFile.plf noch nicht existiert, also die 
  ' Anwendung auch noch nicht aktiviert sein kann, dann soll folgendes passieren...
End If

Kompletten Workshop downloaden

 Produktaktivierung downloaden

 Key-Generator downloaden

Wenn Sie Fragen zu der Produktaktivierung haben sollten dann schreiben Sie mir doch einfach eine Email (fbroen@skenet.de), oder schauen Sie auf meiner Homepage ( www.falk-broen.de.vu) vorbei. Ich würde mich natürlich auch über ein Feedback freuen, wie jemandem mein Projekt gefallen hat.