331 lines
9.4 KiB
ObjectPascal
331 lines
9.4 KiB
ObjectPascal
{*********************************************************}
|
|
{* ONGUARD: EXSELEC1.PAS *}
|
|
{* Copyright (c) TurboPower Software Co 1998 *}
|
|
{* All rights reserved. *}
|
|
{*********************************************************}
|
|
|
|
{ This example uses the TOgUsageCode and the TOgSpecialCode
|
|
components to implement a limited use "demo" application
|
|
which allows only the required features. The program can
|
|
be run 3 times and then a special code must be obtained
|
|
to register the program and to enable various features.
|
|
A machine modifier is used to prevent the application from
|
|
being copied and run on another machine. To obtain the
|
|
release code you need to run the companion example EXSLCODE.
|
|
The release codes will be stored in a data file called
|
|
EXSELECT.DAT}
|
|
|
|
unit Exselec1;
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
SysUtils, Classes, Controls, Forms, Dialogs,
|
|
StdCtrls, OnGuard, OgUtil, Menus,Buttons,LResources;
|
|
|
|
type
|
|
|
|
{ TForm1 }
|
|
|
|
TForm1 = class(TForm)
|
|
ModifyBtn: TButton;
|
|
Memo1: TMemo;
|
|
MainMenu1: TMainMenu;
|
|
FeaturesMenu: TMenuItem;
|
|
FeaturesRequired: TMenuItem;
|
|
FeaturesHelp: TMenuItem;
|
|
FeaturesExamples: TMenuItem;
|
|
FeaturesDatabase: TMenuItem;
|
|
FeaturesFax: TMenuItem;
|
|
FeaturesGoodies: TMenuItem;
|
|
OgUsageCode1: TOgUsageCode;
|
|
OgSpecialCode1: TOgSpecialCode;
|
|
function DecodeSpecialCode : Longint;
|
|
procedure ModifyBtnClick(Sender: TObject);
|
|
procedure EnableFeatures(Features : Longint);
|
|
procedure OgUsageCode1GetKey(Sender: TObject; var Key: TKey);
|
|
procedure OgUsageCode1GetCode(Sender: TObject; var Code: TCode);
|
|
procedure OgUsageCode1Checked(Sender: TObject; Status: TCodeStatus);
|
|
procedure OgSpecialCode1GetKey(Sender: TObject; var Key: TKey);
|
|
procedure OgSpecialCode1GetCode(Sender: TObject; var Code: TCode);
|
|
procedure OgSpecialCode1GetModifier(Sender: TObject;
|
|
var Value: Longint);
|
|
procedure OgSpecialCode1Checked(Sender: TObject; Status: TCodeStatus);
|
|
procedure FormCreate(Sender: TObject);
|
|
function FileGetCode(Index : Longint; var Code : TCode) : Boolean;
|
|
procedure FilePutCode(Index : Longint; Code : TCode);
|
|
procedure OgUsageCode1ChangeCode(Sender: TObject; Code: TCode);
|
|
end;
|
|
|
|
var
|
|
Form1: TForm1;
|
|
|
|
{----------------------------------------------------------------------}
|
|
|
|
implementation
|
|
|
|
|
|
|
|
const
|
|
{ The key was created by a separate program (CODEGEN) and is generic
|
|
the examples, EXSELECT, EXSELAPI, and EXSLCODE }
|
|
TheKey: TKey = ($F1,$46,$8D,$E4,$70,$AE,$92,$DC,
|
|
$13,$1A,$03,$C4,$44,$25,$72,$F5);
|
|
|
|
{ Initial code has 3 uses embedded }
|
|
InitCode : string = '13B1A08BD78AFCD3';
|
|
CodeFile : string = 'ExSelect.Dat';
|
|
DemoCaption : string = 'ExSelect: Demo runs left = ';
|
|
RegisteredCap : string = 'ExSelect: Registered';
|
|
NotRegisteredCap : string = 'ExSelect: Not Registered';
|
|
ModifyStr : string = 'Modify Registration to enable this feature';
|
|
|
|
{ Feature masks }
|
|
RequiredMask = $00000001;
|
|
HelpMask = $00000002;
|
|
ExamplesMask = $00000004;
|
|
DBMask = $00000008;
|
|
FaxMask = $00000010;
|
|
GoodiesMask = $00000020;
|
|
|
|
var
|
|
UsageCode : TCode; {Index = 0}
|
|
SpecialCode : TCode; {Index = 1}
|
|
|
|
|
|
{=========== Initialization and File I/O ===============}
|
|
|
|
function TForm1.FileGetCode(Index : Longint; var Code : TCode) : Boolean;
|
|
var
|
|
Dir, Path : string;
|
|
FileHandle : Integer;
|
|
begin
|
|
Dir := '';
|
|
GetDir(0, Dir);
|
|
Path := Dir + DirectorySeparator + CodeFile;
|
|
FillChar(Code, SizeOf(TCode), 0);
|
|
if FileExists(Path) then begin
|
|
FileHandle := FileOpen(Path, fmOpenRead);
|
|
FileSeek(FileHandle, Index * SizeOf(Code), 0);
|
|
FileRead(FileHandle, Code, SizeOf(Code));
|
|
FileClose(FileHandle);
|
|
Result := True;
|
|
end else
|
|
Result := False;
|
|
end;
|
|
|
|
{-------------------------------------------------------}
|
|
|
|
procedure TForm1.FilePutCode(Index : Longint; Code : TCode);
|
|
var
|
|
Dir, Path : string;
|
|
FileHandle : Integer;
|
|
begin
|
|
Dir := '';
|
|
GetDir(0, Dir);
|
|
Path := Dir + DirectorySeparator + CodeFile;
|
|
if not FileExists(Path) then
|
|
FileHandle := FileCreate(Path)
|
|
else
|
|
FileHandle := FileOpen(Path, fmOpenWrite);
|
|
FileSeek(FileHandle, Index * SizeOf(Code), 0);
|
|
FileWrite(FileHandle, Code, SizeOf(Code));
|
|
FileClose(FileHandle);
|
|
end;
|
|
|
|
{-------------------------------------------------------}
|
|
|
|
procedure TForm1.FormCreate(Sender: TObject);
|
|
begin
|
|
FillChar(SpecialCode, SizeOf(SpecialCode), 0);
|
|
if not FileGetCode(0, UsageCode) then
|
|
HexToBuffer(InitCode, UsageCode, SizeOf(UsageCode));
|
|
OgUsageCode1.CheckCode(True);
|
|
end;
|
|
|
|
|
|
{=================== Usage Code Stuff ==================}
|
|
|
|
procedure TForm1.OgUsageCode1GetKey(Sender: TObject; var Key: TKey);
|
|
begin
|
|
Key := TheKey;
|
|
end;
|
|
|
|
{-------------------------------------------------------}
|
|
|
|
procedure TForm1.OgUsageCode1GetCode(Sender: TObject; var Code: TCode);
|
|
begin
|
|
Code := UsageCode;
|
|
end;
|
|
|
|
{-------------------------------------------------------}
|
|
|
|
procedure TForm1.OgUsageCode1Checked(Sender: TObject; Status: TCodeStatus);
|
|
begin
|
|
{ If usage code is valid, app is still in demo period so enable only
|
|
default features }
|
|
if (Status = ogValidCode) then begin
|
|
OgUsageCode1.Decrease;
|
|
EnableFeatures(RequiredMask);
|
|
end else begin { Usage count has expired, go on to special code stuff }
|
|
FileGetCode(1, SpecialCode);
|
|
ModifyBtn.Enabled := True;
|
|
OgSpecialCode1.CheckCode(True);
|
|
end;
|
|
end;
|
|
|
|
{-------------------------------------------------------}
|
|
|
|
procedure TForm1.OgUsageCode1ChangeCode(Sender: TObject; Code: TCode);
|
|
var
|
|
FreebiesLeft : Longint;
|
|
begin
|
|
FreebiesLeft := OgUsageCode1.GetValue - 1;
|
|
UsageCode := Code;
|
|
FilePutCode(0, UsageCode);
|
|
Caption := DemoCaption + IntToStr(FreebiesLeft);
|
|
end;
|
|
|
|
|
|
{================== Special Code Stuff =================}
|
|
|
|
procedure TForm1.OgSpecialCode1GetKey(Sender: TObject; var Key: TKey);
|
|
begin
|
|
Key := TheKey;
|
|
end;
|
|
|
|
{-------------------------------------------------------}
|
|
|
|
procedure TForm1.OgSpecialCode1GetCode(Sender: TObject; var Code: TCode);
|
|
begin
|
|
Code := SpecialCode;
|
|
end;
|
|
|
|
{-------------------------------------------------------}
|
|
|
|
procedure TForm1.OgSpecialCode1GetModifier(Sender: TObject;
|
|
var Value: Longint);
|
|
begin
|
|
Value := GenerateMachineModifierPrim;
|
|
end;
|
|
|
|
{-------------------------------------------------------}
|
|
|
|
procedure TForm1.OgSpecialCode1Checked(Sender: TObject;
|
|
Status: TCodeStatus);
|
|
var
|
|
Features : Longint;
|
|
begin
|
|
{ If special code is valid, then app is registered so enable features }
|
|
if (Status = ogValidCode) then begin
|
|
FilePutCode(1, SpecialCode);
|
|
Features := OgSpecialCode1.GetValue;
|
|
EnableFeatures(Features);
|
|
Caption := RegisteredCap;
|
|
Exit;
|
|
end;
|
|
{ Otherwise prompt for release code}
|
|
Features := DecodeSpecialCode;
|
|
if (Features <> 0) then begin
|
|
FilePutCode(1, SpecialCode);
|
|
EnableFeatures(Features);
|
|
Caption := RegisteredCap;
|
|
end else begin
|
|
EnableFeatures(0);
|
|
Caption := NotRegisteredCap;
|
|
end;
|
|
end;
|
|
|
|
|
|
{================== Registration Dialog ================}
|
|
|
|
function TForm1.DecodeSpecialCode : Longint;
|
|
var
|
|
CodeStr : string;
|
|
ModKey : TKey;
|
|
MachineID : string;
|
|
Modifier : longint;
|
|
begin
|
|
Result := 0;
|
|
MachineID := '';
|
|
Modifier := GenerateMachineModifierPrim;
|
|
MachineID := BufferToHex(Modifier, SizeOf(Modifier));
|
|
ModKey := TheKey;
|
|
ApplyModifierToKeyPrim(Modifier, ModKey, SizeOf(ModKey));
|
|
CodeStr := '';
|
|
if InputQuery('Machine ID: '+ MachineID ,
|
|
'Run EXSLCODE To Obtain Release Code', CodeStr) then begin
|
|
HexToBuffer(CodeStr, SpecialCode, SizeOf(SpecialCode));
|
|
if OgSpecialCode1.IsCodeValid then
|
|
Result := OgSpecialCode1.GetValue;
|
|
end;
|
|
end;
|
|
|
|
|
|
{================== The Rest of it ================}
|
|
|
|
procedure TForm1.EnableFeatures(Features : Longint);
|
|
begin
|
|
FeaturesRequired.Enabled := False;
|
|
FeaturesRequired.Checked := False;
|
|
FeaturesHelp.Enabled := False;
|
|
FeaturesHelp.Checked := False;
|
|
FeaturesExamples.Enabled := False;
|
|
FeaturesExamples.Checked := False;
|
|
FeaturesDatabase.Enabled := False;
|
|
FeaturesDatabase.Checked := False;
|
|
FeaturesFax.Enabled := False;
|
|
FeaturesFax.Checked := False;
|
|
FeaturesGoodies.Enabled := False;
|
|
FeaturesGoodies.Checked := False;
|
|
if (Features and RequiredMask) <> 0 then begin
|
|
FeaturesRequired.Enabled := True;
|
|
FeaturesRequired.Checked := True;
|
|
end;
|
|
if (Features and HelpMask) <> 0 then begin
|
|
FeaturesHelp.Enabled := True;
|
|
FeaturesHelp.Checked := True;
|
|
end;
|
|
if (Features and ExamplesMask) <> 0 then begin
|
|
FeaturesExamples.Enabled := True;
|
|
FeaturesExamples.Checked := True;
|
|
end;
|
|
if (Features and DBMask) <> 0 then begin
|
|
FeaturesDatabase.Enabled := True;
|
|
FeaturesDatabase.Checked := True;
|
|
end;
|
|
if (Features and FaxMask) <> 0 then begin
|
|
FeaturesFax.Enabled := True;
|
|
FeaturesFax.Checked := True;
|
|
end;
|
|
if (Features and GoodiesMask) <> 0 then begin
|
|
FeaturesGoodies.Enabled := True;
|
|
FeaturesGoodies.Checked := True;
|
|
end;
|
|
if (Features = 0) then
|
|
FeaturesMenu.Caption := 'No Features Enabled'
|
|
else
|
|
FeaturesMenu.Caption := '&Features';
|
|
end;
|
|
|
|
{-------------------------------------------------------}
|
|
|
|
procedure TForm1.ModifyBtnClick(Sender: TObject);
|
|
var
|
|
Features : Longint;
|
|
begin
|
|
FillChar(SpecialCode, SizeOf(SpecialCode), 0);
|
|
Features := DecodeSpecialCode;
|
|
if (Features <> 0) then begin
|
|
FilePutCode(1, SpecialCode);
|
|
EnableFeatures(Features);
|
|
Caption := RegisteredCap;
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
{$i exselec1.lrs}
|
|
|
|
end.
|