unit S_Appl;

{ Secrets of Delphi 2, by Ray Lischner. (1996, Waite Group Press).
  Chapter 16: Application Secrets
  Copyright © 1996 The Waite Group, Inc. }

{ Application wrapper component, which makes it easier
  to work with the TApplication object at design time. }
  
interface

uses WinTypes, WinProcs, Messages, Classes, SysUtils, Graphics, Forms;

type
  TS_FileDropEvent = procedure(Sender: TObject; Files: TStrings) of object;
  TS_ApplicationWrapper = class(TComponent)
  private
    { At design time, create a special TApplication object, just to
      store property values. At run time, fApplication is the real
      Application object. }
    fApplication: TApplication;
    { The following fields are not part of the Application object,
      but are added to this class for convenience. }
    fOnPaintIcon: TNotifyEvent;
    fOnFileDrop: TS_FileDropEvent;
    fDropPoint: TPoint;
    fCanvas: TCanvas;
  {$ifdef VER80}
    fUpdateFormatSettings: Boolean;
  {$endif}

    { Read and Write methods for the properties }
    function GetHintColor: TColor;
    procedure SetHintColor(Value: TColor);
    function GetHintPause: Integer;
    procedure SetHintPause(Value: Integer);
    function GetShowHint: Boolean;
    procedure SetShowHint(Value: Boolean);
    function GetOnActivate: TNotifyEvent;
    procedure SetOnActivate(Value: TNotifyEvent);
    function GetOnDeactivate: TNotifyEvent;
    procedure SetOnDeactivate(Value: TNotifyEvent);
    function GetOnException: TExceptionEvent;
    procedure SetOnException(Value: TExceptionEvent);
    function GetOnHelp: THelpEvent;
    procedure SetOnHelp(Value: THelpEvent);
    function GetOnHint: TNotifyEvent;
    procedure SetOnHint(Value: TNotifyEvent);
    function GetOnIdle: TIdleEvent;
    procedure SetOnIdle(Value: TIdleEvent);
    function GetOnMessage: TMessageEvent;
    procedure SetOnMessage(Value: TMessageEvent);
    function GetOnMinimize: TNotifyEvent;
    procedure SetOnMinimize(Value: TNotifyEvent);
    function GetOnRestore: TNotifyEvent;
    procedure SetOnRestore(Value: TNotifyEvent);
    function GetUpdateFormatSettings: Boolean;
    procedure SetUpdateFormatSettings(Value: Boolean);
    procedure SetOnFileDrop(Value: TS_FileDropEvent);

    { Get a TCanvas for painting the icon. }
    function GetCanvas: TCanvas;
  protected
    property Application: TApplication read fApplication;
    procedure PaintIcon; virtual;
    procedure DropFiles(Handle: THandle); virtual;
    function MsgHook(var Msg: TMessage): Boolean; virtual;
  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;
    property Canvas: TCanvas read GetCanvas;
    property DropPoint: TPoint read fDropPoint;
  published
    property HintColor: TColor read GetHintColor write SetHintColor;
    property HintPause: Integer read GetHintPause write SetHintPause;
    property ShowHint: Boolean read GetShowHint write SetShowHint
        default True;
    property UpdateFormatSettings: Boolean read GetUpdateFormatSettings
        write SetUpdateFormatSettings default True;
    property OnActivate: TNotifyEvent read GetOnActivate write SetOnActivate;
    property OnDeactivate: TNotifyEvent read GetOnDeactivate
        write SetOnDeactivate;
    property OnException: TExceptionEvent read GetOnException
        write SetOnException;
    property OnFileDrop: TS_FileDropEvent read fOnFileDrop
        write SetOnFileDrop;
    property OnHelp: THelpEvent read GetOnHelp write SetOnHelp;
    property OnHint: TNotifyEvent read GetOnHint write SetOnHint;
    property OnIdle: TIdleEvent read GetOnIdle write SetOnIdle;
    property OnMessage: TMessageEvent read GetOnMessage write SetOnMessage;
    property OnMinimize: TNotifyEvent read GetOnMinimize write SetOnMinimize;
    property OnPaintIcon: TNotifyEvent read fOnPaintIcon write fOnPaintIcon;
    property OnRestore: TNotifyEvent read GetOnRestore write SetOnRestore;
  end;

implementation

uses ShellApi;

{ When creating an application wrapper at design time, also create
  a design time Application object. This design application stores
  the property values at design time. At run time, fApplication
  refers to the real Application object. }
constructor TS_ApplicationWrapper.Create(Owner: TComponent);
begin
  inherited Create(Owner);
  if (Owner <> nil) and (csDesigning in Owner.ComponentState) then
  begin
    { Create a fake Application, just to hold property values. }
    fApplication := TApplication.Create(nil);
    { Force the ShowHint property to its true default, which is
      different from what TApplication.Create sets it to. }
    ShowHint := True;
  end
  else
  begin
    { Get the real Application object, and set a message hook. }
    fApplication := Forms.Application;
    fApplication.HookMainWindow(MsgHook);
  end;
{$ifdef VER80}
  { Initialize the UpdateFormatSettings property for Delphi 1.0. }
  fUpdateFormatSettings := True;
{$endif}
end;

destructor TS_ApplicationWrapper.Destroy;
begin
  if csDesigning in ComponentState then
    Application.Free
  else
    Application.UnhookMainWindow(MsgHook);
  inherited Destroy;
end;

{ Get the time to wait before displaying a hint window, in mililseconds. }
function TS_ApplicationWrapper.GetHintPause: Integer;
begin
  Result := Application.HintPause
end;

{ Set the interval to wait before displaying a hint window, in milliseconds. }
procedure TS_ApplicationWrapper.SetHintPause(Value: Integer);
begin
  Application.HintPause := Value
end;

function TS_ApplicationWrapper.GetHintColor: TColor;
begin
  Result := Application.HintColor;
end;

procedure TS_ApplicationWrapper.SetHintColor(Value: TColor);
begin
  Application.HintColor := Value
end;

function TS_ApplicationWrapper.GetShowHint: Boolean;
begin
  Result := Application.ShowHint;
end;

procedure TS_ApplicationWrapper.SetShowHint(Value: Boolean);
begin
  Application.ShowHint := Value
end;

function TS_ApplicationWrapper.GetOnActivate: TNotifyEvent;
begin
  Result := Application.OnActivate
end;

procedure TS_ApplicationWrapper.SetOnActivate(Value: TNotifyEvent);
begin
  Application.OnActivate := Value
end;

function TS_ApplicationWrapper.GetOnDeactivate: TNotifyEvent;
begin
  Result := Application.OnDeactivate
end;

procedure TS_ApplicationWrapper.SetOnDeactivate(Value: TNotifyEvent);
begin
  Application.OnDeactivate := Value
end;

function TS_ApplicationWrapper.GetOnException: TExceptionEvent;
begin
  Result := Application.OnException
end;

procedure TS_ApplicationWrapper.SetOnException(Value: TExceptionEvent);
begin
  Application.OnException := Value
end;

function TS_ApplicationWrapper.GetOnHelp: THelpEvent;
begin
  Result := Application.OnHelp
end;

procedure TS_ApplicationWrapper.SetOnHelp(Value: THelpEvent);
begin
  Application.OnHelp := Value
end;

function TS_ApplicationWrapper.GetOnHint: TNotifyEvent;
begin
  Result := Application.OnHint
end;

procedure TS_ApplicationWrapper.SetOnHint(Value: TNotifyEvent);
begin
  Application.OnHint := Value
end;

function TS_ApplicationWrapper.GetOnIdle: TIdleEvent;
begin
  Result := Application.OnIdle
end;

procedure TS_ApplicationWrapper.SetOnIdle(Value: TIdleEvent);
begin
  Application.OnIdle := Value
end;

function TS_ApplicationWrapper.GetOnMessage: TMessageEvent;
begin
  Result := Application.OnMessage
end;

procedure TS_ApplicationWrapper.SetOnMessage(Value: TMessageEvent);
begin
  Application.OnMessage := Value
end;

function TS_ApplicationWrapper.GetOnMinimize: TNotifyEvent;
begin
  Result := Application.OnMinimize
end;

procedure TS_ApplicationWrapper.SetOnMinimize(Value: TNotifyEvent);
begin
  Application.OnMinimize := Value
end;

function TS_ApplicationWrapper.GetOnRestore: TNotifyEvent;
begin
  Result := Application.OnRestore
end;

procedure TS_ApplicationWrapper.SetOnRestore(Value: TNotifyEvent);
begin
  Application.OnRestore := Value
end;


{ Get a TCanvas for painting the icon. }
function TS_ApplicationWrapper.GetCanvas: TCanvas;
begin
  if fCanvas = nil then
    fCanvas := TCanvas.Create;
  Result := fCanvas;
end;

{ Paint the application's icon. }
procedure TS_ApplicationWrapper.PaintIcon;
var
  PaintStruct: TPaintStruct;
begin
  BeginPaint(Application.Handle, PaintStruct);
  try
    { If there is a Canvas, get rid of it. }
    if fCanvas <> nil then
    begin
      fCanvas.Free;
      fCanvas := nil;
    end;
    { Create a fresh canvas, just for painting the icon. }
    fCanvas := TCanvas.Create;
    try
      Canvas.Handle := PaintStruct.hdc;
      Canvas.Brush.Color := clBackground;
      { Erase the background, if necessary. }
      if PaintStruct.fErase then
        Canvas.FillRect(PaintStruct.rcPaint);

      { Call the event handler to paint the icon window. }
      if Assigned(fOnPaintIcon) then
        fOnPaintIcon(Self);
    finally
      fCanvas.Free;
      fCanvas := nil;
    end;
  finally
    EndPaint(Application.Handle, PaintStruct);
  end;
end;

{ Hook the application's messages to intercept some of them. }
function TS_ApplicationWrapper.MsgHook(var Msg: TMessage): Boolean;
begin
  Result := False;

  case Msg.Msg of
  Wm_Paint:
    { If there is an OnPaintIcon handler, then steal the Wm_Paint messages
      for the application's icon. }
    if Assigned(fOnPaintIcon) and IsIconic(Application.Handle) then
    begin
      Result := True;
      PaintIcon;
    end;
  Wm_DropFiles:
    { If there is an OnFileDrop handler, then steal the Wm_DropFiles
      messages. }
    if Assigned(fOnFileDrop) then
    begin
      Result := True;
      DropFiles(TWmDropFiles(Msg).Drop);
    end;
  {$ifdef VER80}
  Wm_WinIniChange:
    { Do not steal the Wm_WinIniChange message because the application might
      need it for other purposes, but peek at it, and possibly update the
      date and time format settings. When the Section is INTL, then the
      International settings have changed, and need to be updated. If
      Section is nil, then multiple sections have changed, and one must
      assume the worst. }
    with TWmWinIniChange(Msg) do
      if UpdateFormatSettings and
         ((Section = nil) or (StrIComp('INTL', Section) = 0))
    then
      GetFormatSettings;
  {$endif}
  { else do not intercept the message }
  end;
end;

function TS_ApplicationWrapper.GetUpdateFormatSettings: Boolean;
begin
{$ifdef VER80}
  Result := fUpdateFormatSettings
{$else}
  Result := Application.UpdateFormatSettings
{$endif}
end;

procedure TS_ApplicationWrapper.SetUpdateFormatSettings(Value: Boolean);
begin
{$ifdef VER80}
  fUpdateFormatSettings := Value
{$else}
  Application.UpdateFormatSettings := Value
{$endif}
end;

{ Handle a Wm_DropFiles message by calling the OnFileDrop event handler. }
procedure TS_ApplicationWrapper.DropFiles(Handle: THandle);
var
  Files: TStrings;
  Filename: array[0..255] of Char;
  Count, I: Integer;
  Pt: TPoint;
begin
  try
    DragQueryPoint(Handle, fDropPoint);
    { Get the number of dropped files. }
    Count := DragQueryFile(Handle, Cardinal(-1), nil, 0);
    { Store the list of file names in the Files string list. }
    Files := TStringList.Create;
    try
      for I := 0 to Count-1 do
      begin
        { Get a file name and add it to the list. }
        DragQueryFile(Handle, I, Filename, SizeOf(Filename));
        Files.Add(StrPas(Filename));
      end;
      { Call the event handler. }
      fOnFileDrop(Self, Files);
    finally
      Files.Free;
    end;
  finally
    { Important to tell Windows to clean up. }
    DragFinish(Handle);
  end;
end;

{ Set the OnFileDrop property. }
procedure TS_ApplicationWrapper.SetOnFileDrop(Value: TS_FileDropEvent);
begin
  fOnFileDrop := Value;
  if not (csDesigning in ComponentState) then
    { At run time, tell Windows whether the application object is
      willing to receive file drop events. This is true only when
      the OnFileDrop property is not nil. }
    DragAcceptFiles(Application.Handle, Assigned(Value));
end;

end.
