home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 October / PCWorld_2000-10_cd2.bin / Borland / interbase / IBConsole_src.ZIP / ibconsole / zluPrevInstance.pas < prev    next >
Pascal/Delphi Source File  |  2000-07-24  |  4KB  |  133 lines
  1. {
  2.  * The contents of this file are subject to the InterBase Public License
  3.  * Version 1.0 (the "License"); you may not use this file except in
  4.  * compliance with the License.
  5.  * 
  6.  * You may obtain a copy of the License at http://www.Inprise.com/IPL.html.
  7.  * 
  8.  * Software distributed under the License is distributed on an "AS IS"
  9.  * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
  10.  * the License for the specific language governing rights and limitations
  11.  * under the License.  The Original Code was created by Inprise
  12.  * Corporation and its predecessors.
  13.  * 
  14.  * Portions created by Inprise Corporation are Copyright (C) Inprise
  15.  * Corporation. All Rights Reserved.
  16.  * 
  17.  * Contributor(s): ______________________________________.
  18. }
  19.  
  20. unit zluPrevInstance;
  21.  
  22. interface
  23.  
  24. uses Forms, Windows, Dialogs, SysUtils;
  25.  
  26. // The following declaration is necessary because of an error in
  27. // the declaration of BroadcastSystemMessage() in the Windows unit
  28. //function BroadcastSystemMessage(Flags: DWORD; Recipients: PDWORD;
  29. //  uiMessage: UINT; wParam: WPARAM; lParam: LPARAM): Longint; stdcall;
  30. //  external 'user32.dll';
  31.  
  32.  
  33. const
  34.   MI_NO_ERROR          = 0;
  35.   MI_FAIL_SUBCLASS     = 1;
  36.   MI_FAIL_CREATE_MUTEX = 2;
  37.  
  38. { Query this function to determine if error occurred in startup. }
  39. { Value will be one or more of the MI_* error flags. }
  40. function GetMIError: Integer;
  41.  
  42. implementation
  43.  
  44. const
  45.   UniqueAppStr : PChar = 'IBCONSOLE';
  46.  
  47. var
  48.   MessageId: Integer;
  49.   WProc: TFNWndProc = Nil;
  50.   MutHandle: THandle = 0;
  51.   MIError: Integer = 0;
  52.  
  53. function GetMIError: Integer;
  54. begin
  55.   Result := MIError;
  56. end;
  57.  
  58. function NewWndProc(Handle: HWND; Msg: Integer; wParam, lParam: Longint):
  59.   Longint; stdcall;
  60. begin
  61.  
  62.   { If this is the registered message... }
  63.   if Msg = MessageID then
  64.   begin
  65.     { if main form is minimized, normalize it }
  66.     { set focus to application }
  67.     if IsIconic(Application.Handle) then
  68.     begin
  69.       Application.MainForm.WindowState := wsNormal;
  70.       Application.Restore;
  71.     end;
  72.     SetForegroundWindow(Application.MainForm.Handle);
  73.     Result := 0;
  74.   end
  75.   { Otherwise, pass message on to old window proc }
  76.   else
  77.     Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam);
  78. end;
  79.  
  80. procedure SubClassApplication;
  81. begin
  82.   { We subclass Application window procedure so that }
  83.   { Application.OnMessage remains available for user. }
  84.   WProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC,
  85.                                     Longint(@NewWndProc)));
  86.   { Set appropriate error flag if error condition occurred }
  87.   if WProc = Nil then
  88.     MIError := MIError or MI_FAIL_SUBCLASS;
  89. end;
  90.  
  91. procedure DoFirstInstance;
  92. begin
  93.   SubClassApplication;
  94.   MutHandle := CreateMutex(Nil, False, UniqueAppStr);
  95.   if MutHandle = 0 then
  96.     MIError := MIError or MI_FAIL_CREATE_MUTEX;
  97. end;
  98.  
  99. procedure BroadcastFocusMessage;
  100. { This is called when there is already an instance running. }
  101. var
  102.   BSMRecipients: DWORD;
  103. begin
  104.   { Don't flash main form }
  105.   Application.ShowMainForm := False;
  106.   { Post message and inform other instance to focus itself }
  107.   BSMRecipients := BSM_APPLICATIONS;
  108.   BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
  109.     @BSMRecipients, MessageID, 0, 0);
  110.   Application.Terminate;
  111. end;
  112.  
  113. procedure InitInstance;
  114. begin
  115.   MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
  116.   if MutHandle = 0 then
  117.     { Mutex object has not yet been created, meaning that no previous }
  118.     { instance has been created. }
  119.     DoFirstInstance
  120.   else
  121.     BroadcastFocusMessage;
  122. end;
  123.  
  124. initialization
  125.   MessageID := RegisterWindowMessage(UniqueAppStr);
  126.   InitInstance;
  127. finalization
  128.   if WProc <> Nil then
  129.     { Restore old window procedure }
  130.     SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc));
  131. end.
  132.  
  133.