uniqueinstance.pas

成本系统三层结构源码 开发工具：Delphi 7.0+SQLServer 2005 主要技术：Midas、COM+ 所用第三方控件： FastReport V2.47 D7 Inforp

unit UniqueInstance;

interface

uses Classes, SysUtils, Windows, Forms;

implementation

var
  UniqueMessageID: UINT;
  UniqueMutexHandle: THandle;
  PreviousWndProc: TFNWndProc;
  NextInitProc: Pointer;

function ApplicationWndProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM;
  lParam: LPARAM): LResult; stdcall;
begin
  // Note: Use "<>" may boost application speed.
  if uMsg <> UniqueMessageID then
    Result := CallWindowProc(PreviousWndProc, hWnd, uMsg, wParam, lParam)
  else begin
    if IsIconic(Application.Handle) then Application.Restore;
    SetForegroundWindow(Application.Handle);
    Result := 0;
  end;
end;

procedure BringPreiviousInstanceForeground;
const
  BSMRecipients: DWORD = BSM_APPLICATIONS;
begin
  BroadcastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
    @BSMRecipients, UniqueMessageID, 0, 0);
  Halt;
end;

procedure SubClassApplication;
begin
  PreviousWndProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC,
    Integer(@ApplicationWndProc)));
end;

procedure CheckPreviousInstance;
var
  UniqueApplicationName: PChar;
begin
  // Unique application name, default set to EXE file name,
  // you can change it to yourself.
  UniqueApplicationName := PChar(ExtractFileName(Application.ExeName));

  // Register unique message id
  UniqueMessageID := RegisterWindowMessage(UniqueApplicationName);

  // Create mutex object
  UniqueMutexHandle := CreateMutex(nil, False, UniqueApplicationName);

  // Create mutex failed, terminate application
  if UniqueMutexHandle = 0 then
    Halt
  // The same named mutex exists, show previous instance
  else if GetLastError = ERROR_ALREADY_EXISTS then
    BringPreiviousInstanceForeground
  // No previous instance, subclass application window
  else
    SubClassApplication;

  // Call next InitProc
  if NextInitProc <> nil then TProcedure(NextInitProc);
end;

initialization
  // Must use InitProc to check privious instance,
  // as the reason of Application hasn't been created!
  NextInitProc := InitProc;
  InitProc := @CheckPreviousInstance;

finalization
  // Close the mutex handle
  if UniqueMutexHandle <> 0 then CloseHandle(UniqueMutexHandle);

end.