Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/SWTOOLS.ZIP/SWDEMO.PAS

Pascal/Delphi Source File | 1993-03-09 | 10.9 KB | 324 lines

program SWToolsDemo;

{ShareWare Tools  (c) 1992 Scott Gifford.  All Rights Reserved.}


{This program was written in Turbo Pascal for Windows V1.5.  I have tried
 my best, however, to make it understandable for programmers in all languages
 with my comments.  If you still don't understand something, or if you have
 any type of question about this program, please contact me at one of the
 addresses listed under Questions, Problems, and Comments in the SWTools.HLP
 file.}

                 {Thank you for trying SWTools!}

                                                {---Scott.}


  {The following command causes a resource file to be included.}
{$r swdemo}

  {These units are included in most Windows applications}
uses WObjects,WinTypes,WinProcs,Strings,WinCRT;

const
  pw:array[0..8] of char='password';                 {program password}
  TrialPeriod=30;                                    {Length of trial period}
  RegPath:packed array[0..15] of char='swdemo.reg';  {Registration file}
  DGBPath:packed array[0..15] of char='swdemo.dgb';  {DateStamp file}

  id_register=110;                                   {A button in the DBs}
  id_proceed=111;                                    {Another button}
  id_quit=112;                                       {Yet another button}
  id_DaysLeft=121;                                   {A static from a DB}
  id_name=101;                                       {Edit control ID}
  id_reg=102;                                        {  "     "     "}
  id_quest=103;                                      {  "     "     "}
  id_FavColor=104;                                   {  "     "     "}

  id_scram=120;                         {Scramble button}
  id_date=121;                                       {MakeDate button}
  id_help=122;                                       {help button}
  id_QuestBtn=123;                                   {quest button}
  id_FavColorBtn=124;                                {favorite coloe button}

type
  Str10=array[0..10] of char;     {TPW treats these arrays as pointers to
                                    null-terminated strings}

var {global}
  Registered:integer;             {1 if registered}
  Name,                           {Registration name}
  Quest,                          {Reg. quest}
  FavColor:Str10;                 {Reg. Favorite color}



{Importing the DLL.  If you don't speak TPW fluently, note that PChar
 refers to a null-terminated string and PDosStream to a pointer to
 a DOS stream.  If your language doesn't support either of these, just
 use a plain old pointer.}

procedure scramble(what,password,result:PChar;v:integer);
  far; external 'SWTOOLS1' index 1;
function CreateDateFile(FileName,password:PChar;v:integer):integer;
  far; external 'SWTOOLS1' index 2;
function CreateNewDate(FileName,pw:PChar; v:integer):integer;
  far; external 'SWTOOLS1' index 3;
function DaysGoneBy(FileName,password:PChar;v:integer):integer;
  far; external 'SWTOOLS1' index 4;
function CheckRegistration(RegFile,Name,PassWord:PChar; more:integer;
 var MoreToFollow:PDosStream;v:integer):integer;
  far; external 'SWTOOLS1' index 5;
procedure GetRegInfo(MoreFollowing:PDosStream; var ExtraInfo:Str10;v:integer);
  far; external 'SWTOOLS1' index 7;
procedure DoneWithInfo(MoreFollowing:PDosStream;v:integer);
  far; external 'SWTOOLS1' index 9;
procedure CreateRegistration(RegFile,name,PassWord:PChar; more:integer;
 var MoreToFollow:PDosStream;v:integer);
  far; external 'SWTOOLS1' index 6;
procedure WriteRegInfo(MoreFollowing:PDosStream; ExtraInfo:PChar;v:integer);
  far; external 'SWTOOLS1' index 8;


 {The definition for the registration DB}
type
  PRegister=^TRegister;
  TRegister=object(TDialog)
   {The following two methods respond to an id_register and id_quit message
    from Windows, sent when the Register and Quit buttons in this DB are
    pressed.  For the actual values of these, see const section above.}

    procedure IDRegister(var msg:TMessage);
      virtual id_first + id_register;
    procedure IDQuit(var msg:TMessage);
      virtual id_first + id_quit;
  end;

procedure TRegister.IDRegister(var msg:TMessage);
 {Reaction to the Register button being pressed}
 {To generate a registration number for yourself, use the Scrambler tool.
  For more information, read the help file.}

  var
    name,                {Name from the edit}
    ReadReg,             {Reg    "   "    " }
    RealReg,             {Reg the program figured out}
    temp:Str10;          {The approximate temperature in Geneva, Switzerland}
                           {also used as a temporary variable}
    RegFile:PDosStream;  {For disk I/O}

  begin

    {Retrieve the name and reg number}
    GetDlgItemText(HWindow,id_name,name,11);
    GetDlgItemText(HWindow,id_reg,ReadReg,11);

    {Figure out what the Reg # SHOULD have been}
    Scramble(name,pw,RealReg,1);

    {Compare it to the one read in}
    if StrIComp(ReadReg,RealReg)<>0
      then begin
       {If they are different,send a message and return to the DB}
        MessageBox(HWindow,'That is not the correct registration code',
          'Bad Reg #',mb_OK);
        exit;
      end;

    {Otherwise, create a registration file}
    CreateRegistration(RegPath,name,pw,1,RegFile,1);

    {In addition to the name and reg #, send the quest and favorite color}
    GetDlgItemText(HWindow,id_quest,temp,11);
    WriteRegInfo(RegFile,temp,1);
    GetDlgItemText(HWindow,id_FavColor,temp,11);
    WriteRegInfo(RegFile,temp,1);
    {ALWAYS REMEMBER TO CALL THIS WHEN DONE WITH THE REG FILE!}
    DoneWithInfo(RegFile,1);

    {Exit the dialog and return 1}
    EndDlg(1);
  end;

procedure TRegister.IDQuit(var msg:TMessage);
 {Respond to the Quit button by ending the dialog and returning 0}
  begin
    EndDlg(0);
  end;



{The definition for the TimesUp DB, and for the PleaseReg DB}
{The two DBs are so similar, they only need one definition.}

type
  PTimesUp=^TTimesUp;
  TTimesUp=object(TDialog)
    procedure SetUpWindow;
      virtual;
    procedure IDRegister(var msg:TMessage);
      virtual id_first + id_register;
    procedure IDQuit(var msg:TMessage);
      virtual id_first + id_quit;
  end;

procedure TTimesUp.SetUpWindow;
 {Changes the static with ID id_DaysLeft to the actual number of days left.}
  var
    DaysLeft:array[0..2] of char;
  begin
    Str(DaysGoneBy(DGBPath,pw,1):2,DaysLeft);
    Str(TrialPeriod-DaysGoneBy(DGBPath,pw,1):2,DaysLeft);
    SetDlgItemText(HWindow,id_daysleft,DaysLeft);
  end;

procedure TTimesUp.IDRegister(var msg:TMessage);
 {Reacts to the Register button by creating the Register DB.
  If it returns 1 (i.e. if they registered), returns a 1 and allows
  them to go on with the program.  Otherwise, leaves them with
  this DB again.}
  begin
    if Application^.ExecDialog(new(PRegister,init(@self,'REGISTER')))=1 then EndDlg(1);
  end;

procedure TTimesUp.IDQuit(var msg:TMessage);
 {Reacts to the Quit button by closing the DB and returning a 0}
  begin
    EndDlg(0);
  end;


 {Definition for the main window}
type
  PDemoWin=^TDemoWin;
  TDemoWin=object(TWindow)

    constructor init(AParent:PWindowsObject; AName:PChar);

    procedure SetUpWindow;
      virtual;

    procedure IDScram(var msg:TMessage);
      virtual id_first + id_scram;
    procedure IDDate(var msg:TMessage);
      virtual id_first + id_date;
    procedure IDQuestBtn(var msg:TMessage);
      virtual id_first + id_questBtn;
    procedure IDFavColorBtn(var msg:TMessage);
      virtual id_first + id_FavColorBtn;
    procedure IDHelp(var msg:TMessage);
      virtual id_first + id_help;
  end;

constructor TDemoWin.init(AParent:PWindowsObject; AName:PChar);
 {Creates the window and its buttons}
  var
    Button:PButton;
  begin
    TWindow.init(AParent,AName);
    {Each of the following commands causes a button to be created.
    The parameters are as follows: (parent,ID,title,x,y,width,height,default)}
    Button:=new(PButton,init(@self,id_scram,'Scrambler',25,25,100,100,false));
    Button:=new(PButton,init(@self,id_date,'MakeDate',125,125,100,100,false));
    Button:=new(PButton,init(@self,id_help,'Help',225,225,100,100,false));
    Button:=new(PButton,init(@self,id_QuestBtn,'Quest',335,125,100,100,false));
    Button:=new(PButton,init(@self,id_FavColorBtn,'Color',435,25,100,100,false));
  end;

procedure TDemoWin.SetUpWindow;
 {This is the part that most uses the SWTools.  Watch closely...}
  var
    RegFile:PDosStream;
    i:integer;
  begin
    TWindow.SetUpWindow;

    {Assume they are not registered}
    registered:=0;
    {Check registration file, and pass 1 as the More parameter to ask for
     more info.}
    if CheckRegistration(RegPath,name,pw,1,RegFile,1)=1 then
      begin
       {If CheckRegistration returns 1, they are registered.}
        registered:=1;

        {Get more info AND CLOSE REGFILE.}
    GetRegInfo(RegFile,quest,1);
    GetRegInfo(RegFile,FavColor,1);
        DoneWithInfo(RegFile,1);
      end

      {If they are not registered...}
      else if DaysGoneBy(DGBPath,pw,1)>TrialPeriod
        {And the trial period is over, execute the TimesUp DB.  It will return
         1 if they register.}
        then if Application^.ExecDialog(new(PTimesUp,init(@self,'TIMESUP')))<>1
          then begin
           {If they don't register, close the window and exit.}
            PostMessage(HWindow,wm_close,0,0);
            exit;
          end
          else registered:=1  {If they do.}
        {If they are NOT registered, and the time limit is NOT up.}
        else if Application^.ExecDialog(new(PTimesUp,init(@self,'PLEASEREG')))=1
          then registered:=1;

        {Note that if they register now, their quest and favorite color
         won't be recognized until they quit and load it again.  To
         fix this in your own programs, have the DB notiy you when someone
         registered, or something like that.}

  end;


{The rest of the program just defines the buttons and sets up the app;
 it's pretty self-explanatory, and has very little to do with SWTools.}

procedure TDemoWin.IDScram;
  begin
    WinExec('scramble.exe',sw_normal);
  end;

procedure TDemoWin.IDDate;
  begin
    WinExec('makedate.exe',sw_normal);
  end;

procedure TDemoWin.IDHelp;
  begin
    WinHelp(HWindow,'swdemo.hlp',help_index,0);
  end;

procedure TDemoWin.IDQuestBtn;
  begin
    MessageBox(HWindow,quest,name,mb_OK);
  end;

procedure TDemoWin.IDFavColorBtn;
  begin
    MessageBox(HWindow,FavColor,name,mb_OK);
  end;

type TDemoApp=object(TApplication)
  procedure InitMainWindow;
    virtual;
end;

procedure TDemoApp.InitMainWindow;
  begin
    MainWindow:=new(PDemoWin,init(nil,'ShareWare Tools V1.0 Demo'));
  end;

var {global}
  DemoApp:TDemoApp;

begin {main}
  with DemoApp do begin
    init('SWTOOLSDEMO');
    run;
    done;
  end;
end.

                     {Thank you for trying SWTools!}