Как сделать Multi Screen Emulator?

Code:

{

The GlobalAddAtom function adds a character string to the global atom table

and returns a unique value (an atom) identifying the string.

The GlobalFindAtom function searches the global atom table for the

specified character string and retrieves the global atom associated with that string.

If I have already run the programm then the GlobalFindAtom function returns a value

<> 0 because the atom is already present: in this case I abort the execution of the program.

Instead, if the GlobalFindAtom function returns 0 then this is the first time I run the

program, so I create the atom. At the end I delete the atom.

In order to remove the button on the taskbar I inserted the following code

inside the OnCreate event of the form:

}

{...}

ShowWindow( Application.handle, SW_HIDE );

SetWindowLong( Application.handle,

              GWL_EXSTYLE,

              GetWindowLong( application.handle, GWL_EXSTYLE ) and

              not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW);

ShowWindow( Application.handle, SW_SHOW );

{...}

{

In order to have a tray icon in the traybar (wich display a menu containing showing,

hiding and closing of the form), I used a component (TTrayIcon),

I built a year ago; this is the source:

}

unit TrayIcon;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

  ShellAPI, extctrls, Menus;

const

    WM_SYSTEM_TRAY_NOTIFY = WM_USER + 1;

type TTrayIconMessage =(imClick, imDoubleClick, imMouseDown,

                       imMouseUp, imLeftClickUp, imLeftDoubleClick,

                       imRightClickUp, imRightDoubleClick, imNone);

type

TTrayIcon = class(TComponent)

private

   { Private declarations }

  FData: TNotifyIconData;

  FIsClicked: Boolean;

  FIcon: TIcon;

  FIconList: TImageList;

  FPopupMenu: TPopupMenu;

  FTimer: TTimer;

  FHint: string;

  FIconIndex: integer;

  FVisible: Boolean;

  FHide: Boolean;

  FAnimate: Boolean;

  FAppRestore: TTrayIconMessage;

  FPopupMenuShow: TTrayIconMessage;

  FApplicationHook: TWindowHook;

  FOnMinimize: TNotifyEvent;

  FOnRestore: TNotifyEvent;

  FOnMouseMove: TMouseMoveEvent;

  FOnMouseExit: TMouseMoveEvent;

  FOnMouseEnter: TMouseMoveEvent;

  FOnClick: TNotifyEvent;

  FOnDblClick: TNotifyEvent;

  FOnMouseDown: TMouseEvent;

  FOnMouseUp: TMouseEvent;

  FOnAnimate: TNotifyEvent;

  FOnCreate: TNotifyEvent;

  FOnDestroy: TNotifyEvent;

  FOnActivate: TNotifyEvent;

  FOnDeactivate: TNotifyEvent;

  procedure SetHint(Hint: string);

  procedure SetHide(Value: Boolean);

  function GetAnimateInterval: integer;

  procedure SetAnimateInterval(Value: integer);

  function GetAnimate: Boolean;

  procedure SetAnimate(Value: Boolean);

  procedure EndSession;

  function ShiftState: TShiftState;

protected

   { Protected declarations }

  procedure SetVisible(Value: Boolean); virtual;

  procedure DoMessage(var Message: TMessage);virtual;

  procedure DoClick; virtual;

  procedure DoDblClick; virtual;

  procedure DoMouseMove(Shift: TShiftState; X: integer; Y: integer); virtual;

  procedure DoMouseDown(Button: TMouseButton; Shift: TShiftState; X: integer; Y: integer); virtual;

  procedure DoMouseUp(Button: TMouseButton; Shift: TShiftState; X: integer; Y: integer); virtual;

  procedure DoOnAnimate(Sender: TObject); virtual;

  procedure Notification(AComponent: TComponent; Operation: TOperation); override;

  function ApplicationHookProc(var Message: TMessage): Boolean;

  procedure Loaded(); override;

  property Data: TNotifyIconData read FData;

public

   { Public declarations }

  constructor Create(Owner: TComponent); override;

  destructor Destroy; override;

  procedure Minimize(); virtual;

  procedure Restore(); virtual;

  procedure Update(); virtual;

  procedure ShowMenu(); virtual;

  procedure SetIconIndex(Value: integer); virtual;

  procedure SetDefaultIcon(); virtual;

  function GetHandle():HWND;

published

   { Published declarations }

  property Visible: Boolean  read FVisible write SetVisible default false;

  property Hint: string read FHint write SetHint;

  property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;

  property Hide: Boolean read FHide write SetHide;

  property RestoreOn: TTrayIconMessage read FAppRestore write FAppRestore;

  property PopupMenuOn: TTrayIconMessage read FPopupMenuShow write FPopupMenuShow;

  property Icons: TImageList read FIconList write FIconList;

  property IconIndex: integer read FIconIndex write SetIconIndex default 0;

  property AnimateInterval: integer read GetAnimateInterval write SetAnimateInterval default 1000;

  property Animate: Boolean read GetAnimate write SetAnimate default false;

  property Handle: HWND read GetHandle;

  // Events

  property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;

  property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;

  property OnClick: TNotifyEvent read FOnClick write FOnClick;

  property OnMouseEnter: TMouseMoveEvent read FOnMouseEnter write FOnMouseEnter;

  property OnMouseExit: TMouseMoveEvent read FOnMouseExit write FOnMouseExit;

  property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;

  property OnMouseUp:TMouseEvent read FOnMouseUp write FOnMouseUp;

  property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;

  property OnAnimate: TNotifyEvent read FOnAnimate write FOnAnimate;

  property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;

  property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;

  property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;

  property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Carlo Pasolini', [TTrayIcon]);

end;

constructor TTrayIcon.Create(Owner: TComponent);

begin

  inherited;

  FIcon := TIcon.Create();

  FTimer := TTimer.Create(nil);

  FIconIndex := 0;

  FIcon.Assign(Application.Icon);

  FAppRestore := imDoubleClick;

  FOnAnimate := DoOnAnimate;

  FPopupMenuShow := imNone;

  FVisible := false;

  FHide := true;

  FTimer.Enabled := false;

  FTimer.OnTimer := OnAnimate;

  FTimer.Interval := 1000;

  if not (csDesigning in ComponentState) then

     begin

          FillChar(FData, sizeof(TNotifyIconData), #0);

//           memset(&FData, 0, sizeof(TNotifyIconData));

          FData.cbSize := sizeof(TNotifyIconData);

          FData.Wnd := AllocateHWnd(DoMessage);

          FData.uID := UINT(Self);

          FData.hIcon := FIcon.Handle;

          FData.uFlags := NIF_ICON or NIF_MESSAGE;

          FData.uCallbackMessage := WM_SYSTEM_TRAY_NOTIFY;

          FApplicationHook := ApplicationHookProc;

          Update;

     end;

end;

//---------------------------------------------------------------------------

destructor TTrayIcon.Destroy();

begin

  if not (csDesigning in ComponentState) then

     begin

          Shell_NotifyIcon(NIM_DELETE, @FData);  //booh forse @FData

          DeallocateHWnd(FData.Wnd);

     end;

  if (Assigned(FIcon)) then

     FIcon.Free;

  if (Assigned(FTimer)) then

     FTimer.Free;

  inherited;

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.Notification(AComponent: TComponent; Operation: TOperation);

begin

inherited Notification(AComponent, Operation);

if Operation = opRemove then

    begin

         if (AComponent = FIconList) then

            FIconList := nil

         else

            if (AComponent = FPopupMenu) then

               FPopupMenu := nil;

    end;

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.Loaded();

begin

  inherited Loaded();

  if (not Assigned(FIconList)) then

     begin

          FAnimate := false;

          FIcon.Assign(Application.Icon);

     end

  else

     begin

          FTimer.Enabled := FAnimate;

          FIconList.GetIcon(FIconIndex, FIcon);

     end;

  Update();

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.SetVisible(Value: Boolean);

begin

  FVisible := Value;

  if not (csDesigning in ComponentState) then

   begin

     if FVisible then

      begin

        if (not Shell_NotifyIcon(NIM_ADD, @FData)) then

           raise EOutOfResources.Create('Cannot Create System Shell Notification Icon');

        Hide := true;

        Application.HookMainWindow(FApplicationHook);

      end

     else

      begin

        if (not Shell_NotifyIcon(NIM_DELETE, @FData)) then

           raise EOutOfResources.Create('Cannot Remove System Shell Notification Icon');

        Hide := false;

        Application.UnhookMainWindow(FApplicationHook);

      end;

   end;

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.SetHint(Hint: string);

begin

  // The new hint must be different than the previous hint and less than

  // 64 characters to be modified. 64 is an operating system limit.

  if ((FHint <> Hint) and (Length(Hint) < 64)) then

   begin

     FHint := Hint;

     StrPLCopy(FData.szTip, Hint, sizeof(FData.szTip) - 1);

     // If there is no hint then there is no tool tip.

     if (Length(Hint) <> 0) then

        FData.uFlags := FData.uFlags or NIF_TIP

     else

        FData.uFlags := FData.uFlags and (not NIF_TIP);

     Update();

   end;

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.SetHide(Value: Boolean);

begin

  FHide := Value;

end;

//---------------------------------------------------------------------------

function TTrayIcon.GetAnimateInterval(): integer;

begin

  Result := FTimer.Interval;

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.SetAnimateInterval(Value: integer);

begin

  FTimer.Interval := Value;

end;

//---------------------------------------------------------------------------

function TTrayIcon.GetAnimate(): Boolean;

begin

  Result := FAnimate;

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.SetAnimate(Value: Boolean);

begin

  if (Assigned(FIconList) or (csLoading in ComponentState)) then

     FAnimate := Value;

  if (Assigned(FIconList) and (not (csDesigning in ComponentState))) then

     FTimer.Enabled := Value;

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.EndSession();

begin

  Shell_NotifyIcon(NIM_DELETE, @FData);

end;

//---------------------------------------------------------------------------

function TTrayIcon.ShiftState(): TShiftState;

var

  Res: TShiftState;

begin

  Res := [];

  if (GetKeyState(VK_SHIFT) < 0) then

     Res := Res + [ssShift];

  if (GetKeyState(VK_CONTROL) < 0) then

     Res := Res + [ssCtrl];

  if (GetKeyState(VK_MENU) < 0) then

     Res := Res + [ssAlt];

  Result := Res;

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.DoMessage(var Message: TMessage);

var

  point: TPoint;

  shift: TShiftState;

begin

  case (Message.Msg) of

   //begin

     WM_QUERYENDSESSION:

        Message.Result := 1;

        //break;

     WM_ENDSESSION:

        EndSession();

        //break;

     WM_SYSTEM_TRAY_NOTIFY:

        case (Message.LParam) of

         //begin

           WM_MOUSEMOVE:

              if (Assigned(FOnClick)) then

               begin

                 shift := ShiftState();

                 GetCursorPos(point);

                 DoMouseMove(shift, point.x, point.y);

               end;

              //break;

           WM_LBUTTONDOWN:

            begin

              shift := ShiftState();

              shift := shift + [ssLeft];

              GetCursorPos(point);

              DoMouseDown(mbLeft, shift, point.x, point.y);

              FIsClicked := true;

              //break;

            end;

           WM_LBUTTONUP:

             begin

              shift := ShiftState();

              shift := shift + [ssLeft];

              GetCursorPos(point);

              if (Assigned(FOnClick)) then

                 DoClick();

              DoMouseUp(mbLeft, shift, point.x, point.y);

              if (FAppRestore = imLeftClickUp) then

                 Restore();

              if (FPopupMenuShow = imLeftClickUp) then

                 ShowMenu();

              //break;

             end;

           WM_LBUTTONDBLCLK:

             begin

              DoDblClick();

              if (FAppRestore = imLeftDoubleClick) then

                 Restore();

              if (FPopupMenuShow = imLeftDoubleClick) then

                 ShowMenu();

              //break;

             end;

           WM_RBUTTONDOWN:

             begin

              shift := ShiftState();

              shift := shift + [ssRight];

              GetCursorPos(point);

              DoMouseDown(mbRight, shift, point.x, point.y);

              //break;

             end;

           WM_RBUTTONUP:

             begin

              shift := ShiftState();

              shift := shift + [ssRight];

              GetCursorPos(point);

              DoMouseUp(mbRight, shift, point.x, point.y);

              if (FAppRestore = imRightClickUp) then

                 Restore();

              if (FPopupMenuShow = imRightClickUp) then

                 ShowMenu();

              //break;

             end;

           WM_RBUTTONDBLCLK:

             begin

              DoDblClick();

              if (FAppRestore = imRightDoubleClick) then

                 Restore();

              if (FPopupMenuShow = imRightDoubleClick) then

                 ShowMenu();

              //break;

             end;

           WM_MBUTTONDOWN:

             begin

              shift := ShiftState();

              shift := shift + [ssMiddle];

              GetCursorPos(point);

              DoMouseDown(mbMiddle, shift, point.x, point.y);

              //break;

             end;

           WM_MBUTTONUP:

             begin

              shift := ShiftState();

              shift := shift + [ssMiddle];

              GetCursorPos(point);

              DoMouseUp(mbMiddle, shift, point.x, point.y);

              //break;

             end;

           WM_MBUTTONDBLCLK:

              DoDblClick();

              //break;

        end;

  end;

  inherited Dispatch(Message);

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.ShowMenu();

var

  point: TPoint;

begin

  GetCursorPos(point);

  if (Screen.ActiveForm.Handle <> 0) then

     SetForegroundWindow(Screen.ActiveForm.Handle);

  FPopupMenu.Popup(point.x, point.y);

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.DoClick();

begin

  if (FAppRestore = imClick) then

     Restore();

  if (FPopupMenuShow = imClick) then

     ShowMenu();

  if (Assigned(FOnClick)) then

     FOnClick(Self);

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.DoDblClick();

begin

  if (FAppRestore = imDoubleClick) then

     Restore();

  if (FPopupMenuShow = imDoubleClick) then

     ShowMenu();

  if (Assigned(FOnDblClick)) then

     FOnDblClick(Self);

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.DoMouseMove(Shift: TShiftState; X:integer; Y: integer);

begin

  if (Assigned(FOnMouseMove)) then

     FOnMouseMove(Self, Shift, X, Y);

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.DoMouseDown(Button: TMouseButton; Shift: TShiftState;

                                      X: integer; Y: integer);

begin

  if (FAppRestore = imMouseDown) then

     Restore();

  if (FPopupMenuShow = imMouseDown) then

     ShowMenu();

  if (Assigned(FOnMouseDown)) then

     FOnMouseDown(Self, Button, Shift, X, Y);

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.DoMouseUp(Button: TMouseButton; Shift: TShiftState;

                                    X: integer; Y:integer);

begin

  if (FAppRestore = imMouseDown) then

     Restore();

  if (FPopupMenuShow = imMouseDown) then

     ShowMenu();

  if (Assigned(FOnMouseUp)) then

     FOnMouseUp(Self, Button, Shift, X, Y);

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.DoOnAnimate(Sender: TObject);

begin

  if (IconIndex < FIconList.Count) then

     Inc(FIconIndex)

  else

     FIconIndex := 0;

  SetIconIndex(FIconIndex);

  Update();

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.Minimize();

begin

  Application.Minimize();

  ShowWindow(Application.Handle, SW_HIDE);

  if (Assigned(FOnMinimize)) then

     FOnMinimize(Self);

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.Restore();

begin

  Application.Restore();

  ShowWindow(Application.Handle, SW_RESTORE);

  SetForegroundWindow(Application.Handle);

  if (Assigned(FOnRestore)) then

     FOnRestore(Self);

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.Update();

begin

  if not (csDesigning in ComponentState) then

   begin

     FData.hIcon := FIcon.Handle;

     if (Visible = true) then

        Shell_NotifyIcon(NIM_MODIFY, @FData);

   end;

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.SetIconIndex(Value: integer);

begin

  FIconIndex := Value;

  if (Assigned(FIconList)) then

     FIconList.GetIcon(FIconIndex, FIcon);

  Update();

end;

//---------------------------------------------------------------------------

function TTrayIcon.ApplicationHookProc(var Message: TMessage): Boolean;

begin

  if (Message.Msg = WM_SYSCOMMAND) then

   begin

     if (Message.WParam = SC_MINIMIZE) then

        Minimize();

     if (Message.WParam = SC_RESTORE) then

        Restore();

   end;

  Result:= false;

end;

//---------------------------------------------------------------------------

procedure TTrayIcon.SetDefaultIcon();

begin

FIcon.Assign(Application.Icon);

Update();

end;

//---------------------------------------------------------------------------

function TTrayIcon.GetHandle(): HWND;

begin

  Result := FData.Wnd;

end;

//---------------------------------------------------------------------------

end.