fpc/fv/timeddlg.pas

{

   Timed dialogs for Free Vision

   Copyright (c) 2004 by Free Pascal core team

   This library is free software; you can redistribute it and/or
   modify it under the terms of the GNU Library General Public
   License as published by the Free Software Foundation; either
   version 2 of the License, or (at your option) any later version.

   This library is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   Library General Public License for more details.

   You should have received a copy of the GNU Library General Public
   License along with this library; if not, write to the Free
   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****************************************************************************}
UNIT timeddlg;

{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
                                  INTERFACE
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}

{====Include file to sort compiler platform out =====================}
{$I Platform.inc}
{====================================================================}

{==== Compiler directives ===========================================}

{$IFNDEF PPC_FPC}{ FPC doesn't support these switches }
  {$F-} { Near calls are okay }
  {$A+} { Word Align Data }
  {$B-} { Allow short circuit boolean evaluations }
  {$O+} { This unit may be overlaid }
  {$G+} { 286 Code optimization - if you're on an 8088 get a real computer }
  {$P-} { Normal string variables }
  {$N-} { No 80x87 code generation }
  {$E+} { Emulation is on }
{$ENDIF}

{$X+} { Extended syntax is ok }
{$R-} { Disable range checking }
{$S-} { Disable Stack Checking }
{$I-} { Disable IO Checking }
{$Q-} { Disable Overflow Checking }
{$V-} { Turn off strict VAR strings }
{====================================================================}

USES objects, dialogs, fvconsts, drivers, views; { Standard GFV unit }

type
  TTimedDialog = object (TDialog)
    Secs: longint;
    constructor Init (var Bounds: TRect; ATitle: TTitleStr; ASecs: word);
    constructor Load (var S: TStream);
    procedure   GetEvent (var Event: TEvent); virtual;
    procedure   Store (var S: TStream); virtual;
  private
    Secs0: longint;
    Secs2: longint;
    DayWrap: boolean;
  end;
  PTimedDialog = ^TTimedDialog;

(* Must be always included in TTimeDialog! *)
  TTimedDialogText = object (TStaticText)
    constructor Init (var Bounds: TRect);
    procedure   GetText (var S: string); virtual;
  end;
  PTimedDialogText = ^TTimedDialogText;

const
  RTimedDialog: TStreamRec = (
    ObjType: idTimedDialog;
{$IFDEF BP_VMTLink}                              { BP style VMT link }
    VmtLink: Ofs (TypeOf (TTimedDialog)^);
{$ELSE}                                          { Alt style VMT link }
    VmtLink: TypeOf (TTimedDialog);
{$ENDIF BP_VMTLink}
    Load:    @TTimedDialog.Load;
    Store:   @TTimedDialog.Store
  );

  RTimedDialogText: TStreamRec = (
    ObjType: idTimedDialogText;
{$IFDEF BP_VMTLink}                              { BP style VMT link }
    VmtLink: Ofs (TypeOf (TTimedDialogText)^);
{$ELSE}                                          { Alt style VMT link }
    VmtLink: TypeOf (TTimedDialogText);
{$ENDIF BP_VMTLink}
    Load:    @TTimedDialogText.Load;
    Store:   @TTimedDialogText.Store
  );

procedure RegisterTimedDialog;

FUNCTION TimedMessageBox (Const Msg: String; Params: Pointer;
  AOptions: Word; ASecs: Word): Word;

{-TimedMessageBoxRect------------------------------------------------
TimedMessageBoxRect allows the specification of a TRect for the message box
to occupy.
---------------------------------------------------------------------}
FUNCTION TimedMessageBoxRect (Var R: TRect; Const Msg: String; Params: Pointer;
  AOptions: Word; ASecs: Word): Word;


{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
                                IMPLEMENTATION
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}

USES
  dos,
  app, resource, msgbox;   { Standard GFV units }


{***************************************************************************}
{                            INTERFACE ROUTINES                             }
{***************************************************************************}

constructor TTimedDialogText.Init (var Bounds: TRect);
begin
  inherited Init (Bounds, '');
end;


procedure TTimedDialogText.GetText (var S: string);
begin
  if Owner <> nil
(* and (TypeOf (Owner^) = TypeOf (TTimedDialog)) *)
                  then
   begin
    Str (PTimedDialog (Owner)^.Secs, S);
    S := #3 + S;
   end
  else
   S := '';
end;



constructor TTimedDialog.Init (var Bounds: TRect; ATitle: TTitleStr;
  ASecs: word);
var
  H, M, S, S100: word;
begin
  inherited Init (Bounds, ATitle);
  GetTime (H, M, S, S100);
  Secs0 := H * 3600 + M * 60 + S;
  Secs2 := Secs0 + ASecs;
  Secs := ASecs;
  DayWrap := Secs2 > 24 * 3600;
end;


procedure TTimedDialog.GetEvent (var Event: TEvent);
var
  H, M, S, S100: word;
  Secs1: longint;
begin
  inherited GetEvent (Event);
  GetTime (H, M, S, S100);
  Secs1 := H * 3600 + M * 60 + S;
  if DayWrap then Inc (Secs1, 24 * 3600);
  if Secs2 - Secs1 <> Secs then
   begin
    Secs := Secs2 - Secs1;
    if Secs < 0 then
     Secs := 0;
(* If remaining seconds are displayed in one of included views, update them. *)
    Redraw;
   end;
  with Event do
   if (Secs = 0) and (What = evNothing) then
    begin
     What := evCommand;
     Command := cmCancel;
    end;
end;


constructor TTimedDialog.Load (var S: TStream);
begin
  inherited Load (S);
  S.Read (Secs, SizeOf (Secs));
  S.Read (Secs0, SizeOf (Secs0));
  S.Read (Secs2, SizeOf (Secs2));
  S.Read (DayWrap, SizeOf (DayWrap));
end;


procedure TTimedDialog.Store (var S: TStream);
begin
  inherited Store (S);
  S.Write (Secs, SizeOf (Secs));
  S.Write (Secs0, SizeOf (Secs0));
  S.Write (Secs2, SizeOf (Secs2));
  S.Write (DayWrap, SizeOf (DayWrap));
end;



function TimedMessageBox (const Msg: string; Params: pointer;
  AOptions: word; ASecs: word): word;
var
  R: TRect;
begin
  R.Assign(0, 0, 40, 10);                            { Assign area }
  if (AOptions AND mfInsertInApp = 0) then           { Non app insert }
   R.Move((Desktop^.Size.X - R.B.X) div 2,
      (Desktop^.Size.Y - R.B.Y) div 2)               { Calculate position }
  else
   R.Move((Application^.Size.X - R.B.X) div 2,
      (Application^.Size.Y - R.B.Y) div 2);          { Calculate position }
  TimedMessageBox := TimedMessageBoxRect (R, Msg, Params,
    AOptions, ASecs);                                { Create message box }
end;


function TimedMessageBoxRect (var R: TRect; const Msg: string; Params: pointer;
  AOptions: word; ASecs: word): word;
var
  Dlg: PTimedDialog;
  TimedText: PTimedDialogText;
begin
  Dlg := New (PTimedDialog, Init (R, MsgBoxTitles [AOptions
    and $3], ASecs));                                { Create dialog }
  with Dlg^ do
   begin
    R.Assign (3, Size.Y - 5, Size.X - 2, Size.Y - 4);
    New (TimedText, Init (R));
    Insert (TimedText);
    R.Assign (3, 2, Size.X - 2, Size.Y - 5);         { Assign area for text }
   end;
  TimedMessageBoxRect := MessageBoxRectDlg (Dlg, R, Msg, Params, AOptions);
  Dispose (Dlg, Done);                               { Dispose of dialog }
end;



procedure RegisterTimedDialog;
begin
  RegisterType (RTimedDialog);
  RegisterType (RTimedDialogText);
end;


begin
  RegisterTimedDialog;
end.