appinstance.pas.svn-base

这个是个简单的关于出票申请的处理

unit AppInstance;

interface

uses
  SysUtils;

  function  ActivePreAppInstance(AActive: Boolean): Boolean;
{
  function  ActiveAppInstance(const AName: string): Boolean;

  function  InitAppInstance(const AName: string): Boolean;
  procedure DoneAppInstance;
}

implementation

uses
  Windows, Messages, Classes, Forms;

type
  TAppInstance = class(TObject)
  private
    FName: string;
    FUniqueMessage: LongWord;
    FMutex,
    FGlobaMutex: THandle;
    FObjectInstance: Pointer;
    FOldWinProc: TFNWndProc;
  private
    procedure InitWindowProc;
    procedure DoneWindowProc;

    procedure InitMutexes(const AName: string);
    procedure DoneMutexes;

    procedure ActiveMainFrm;
    procedure WindowProc(var Msg: TMessage);
  protected
    procedure BroadcastFocusMessage(wParam: WPARAM; lParam: LPARAM);
  public
    constructor Create(const AName: string);
    destructor Destroy; override;
  end;

  TEnumProcRec = record
    Handle: THandle;
    UniqueMessage: LongWord;
  end;
  PEnumProcRec = ^TEnumProcRec;

const
  defMagicNumber        = $12FEEB76;

  defEnumWindowsParam   = $0FEDAC24;
  defEnumWindowsSuccess = $0F1A1CAD;

  defActiveMainFrmParam = $09CE40A9;

  defSendTimeoutFlag    = SMTO_BLOCK or SMTO_ABORTIFHUNG;

resourcestring
  rsErrSubClass         = '窗口过程赋值出错';
  rsErrCreateMutex      = '创建互斥对象出错';

var
  AppInst: TAppInstance;

function EnumWindowsProc(AHande: HWND; lParam: LPARAM): BOOL; stdcall;
var
  nResult: LongWord;
begin
  Result := True;
  if AHande = Application.Handle then
    Exit;
  if GetWindowLong(AHande, GWL_USERDATA) <> defMagicNumber then
    Exit;
  with PEnumProcRec(lParam)^ do
    if (SendMessageTimeout(AHande, UniqueMessage, defEnumWindowsParam, 0,
      defSendTimeoutFlag, 1000, nResult) <> 0) and (nResult = defEnumWindowsSuccess) then
{
    if (SendMessage(AHande, UniqueMessage, defEnumWindowsParam, 0) = defEnumWindowsSuccess) then
}
    begin
      Handle := AHande;
      Result := False;
    end;
end;

function FindMutexes(const AName: string): Boolean;
var
  nHandle: THandle;
begin
  nHandle := OpenMutex(MUTEX_ALL_ACCESS, False, PChar(AName));
  if nHandle <> 0 then CloseHandle(nHandle);
  Result := nHandle <> 0;
  if Result then
    Exit;
  nHandle := OpenMutex(MUTEX_ALL_ACCESS, False, PChar('Global\' + AName));
  if nHandle <> 0 then CloseHandle(nHandle);
  Result := nHandle <> 0;
end;

function ActiveAppInstance(const AName: string): Boolean;
var
  nMessage: LongWord;
  cData: TEnumProcRec;
begin
  nMessage := RegisterWindowMessage(PChar(AName));
  with cData do
  begin
    Handle := 0;
    UniqueMessage := nMessage;
  end;
  EnumWindows(@EnumWindowsProc, Integer(@cData));
  with cData do
  begin
    Result := Handle <> 0;
    if Result then SendMessage(Handle, UniqueMessage, defActiveMainFrmParam, 0);
  end;
end;

function InitAppInstance(const AName: string): Boolean;
begin
  Result := not Assigned(AppInst);
  if Result then AppInst := TAppInstance.Create(AName);
end;

procedure DoneAppInstance;
begin
  if Assigned(AppInst) then FreeAndNil(AppInst);
end;

function ActivePreAppInstance(AActive: Boolean): Boolean;
var
  strName: string;
begin
  strName := GetModuleName(HInstance);
  strName := LowerCase(ExtractFileName(strName));
  Result := FindMutexes(strName);
  if Result then
  begin
    if AActive then ActiveAppInstance(strName);
  end
  else InitAppInstance(strName);
end;

{ TAppInstance }

procedure TAppInstance.ActiveMainFrm;
begin
  if Application.MainForm = nil then
    Exit;
  if not Application.MainForm.Visible then
    Application.MainForm.Show;
  if IsIconic(Application.Handle) then
  begin
    Application.MainForm.WindowState := wsNormal;
    Application.Restore;
  end;
  SetForegroundWindow(Application.MainForm.Handle);
end;

procedure TAppInstance.BroadcastFocusMessage(wParam: WPARAM; lParam: LPARAM);
const
  defBroadcastFlag      = BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE;
var
  nRecipients: DWORD;
begin
  Application.ShowMainForm := False;
  nRecipients := BSM_APPLICATIONS;
  BroadcastSystemMessage(defBroadcastFlag, @nRecipients, FUniqueMessage, wParam, lParam);
end;

constructor TAppInstance.Create(const AName: string);
begin
  FName:= AName;
  FUniqueMessage := RegisterWindowMessage(PChar(FName));

  InitWindowProc;
  InitMutexes(AName);
end;

destructor TAppInstance.Destroy;
begin
  DoneMutexes;
  DoneWindowProc;

  inherited;
end;

procedure TAppInstance.DoneMutexes;
begin
  if FMutex <> 0 then
  begin
    ReleaseMutex(FMutex);
    CloseHandle(FMutex);
  end;
  if FGlobaMutex <> 0 then
  begin
    ReleaseMutex(FGlobaMutex);
    CloseHandle(FGlobaMutex);
  end;
end;

procedure TAppInstance.DoneWindowProc;
begin
  if Assigned(FOldWinProc) then
    SetWindowLong(Application.Handle, GWL_WNDPROC, Integer(FOldWinProc));
  if Assigned(FObjectInstance) then
    Classes.FreeObjectInstance(FObjectInstance);
  FOldWinProc := nil;
  FObjectInstance := nil;
end;

procedure TAppInstance.InitMutexes(const AName: string);
var
  cSecurityDesc: TSecurityDescriptor;
  cSecurityAttr: TSecurityAttributes;
begin
  InitializeSecurityDescriptor(@cSecurityDesc, SECURITY_DESCRIPTOR_REVISION);
  SetSecurityDescriptorDacl(@cSecurityDesc, True, nil, False);
  with cSecurityAttr do
  begin
    nLength := SizeOf(cSecurityAttr);
    lpSecurityDescriptor := @cSecurityDesc;
    bInheritHandle := False;
  end;
  FMutex := CreateMutex(@cSecurityAttr, False, PChar(AName));
  FGlobaMutex := CreateMutex(@cSecurityAttr, False, PChar('Global\' + AName));
end;

procedure TAppInstance.InitWindowProc;
begin
  FObjectInstance := Classes.MakeObjectInstance(WindowProc);
  FOldWinProc := TfnWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC, Integer(FObjectInstance)));
  if FOldWinProc = nil then
    raise Exception.Create(rsErrSubClass);
  SetWindowLong(Application.Handle, GWL_USERDATA, defMagicNumber);
end;

procedure TAppInstance.WindowProc(var Msg: TMessage);
begin
  with Msg do
    if Msg = FUniqueMessage then
    begin
      if WParam = defEnumWindowsParam then
        Result := defEnumWindowsSuccess
      else if WParam = defActiveMainFrmParam then
      begin
        ActiveMainFrm;
        Result := 0;
      end;
    end
    else Result := CallWindowProc(FOldWinProc, Application.Handle, Msg, WParam, LParam);
end;

initialization
  AppInst := nil;

finalization
  DoneAppInstance;

end.