Kun en instance af program.

prøv den her :

unit MaxInstance;
// Version:  1.1
//
// Purpose:  Allows the Delphi programmer to set a limit on the
//          number of open instances of a Win32 application.
//
// Compatibility:  Should work on any 32 bit version of Delphi
//                since it relies on Win32API calls.
//                Should also work with C++ Builder but not tested.
//
// Uses:  Win32API Semaphore calls.
//
//  Freeware:  No warranties express or implied. Use At Your Own Risk.
//
//  Platforms:  32 bit Windows9x/NT/2000.
//
//  Usage:  Drop on the main form of your application to limit
//          the number of instances of your app that can be run
//          concurrently.  This maximum number can be set at
//          design time using the Object Inspector.  In the main
//          form OnCreate Handler call the method GetSem.
//
// Example:
//        procedure TForm1.FormCreate(Sender: TObject);
//        begin
//          MaxInstance1.GetSem;
//        end;
//
// Properties:
//
//  MaxInstances - Longint:  Max number of open App instances.
//
//  TimeOut - DWORD: milliseconds to wait for the Semaphore.
//            This number has 2 "magic cookie" values, 0,
//            meaning do not wait at all but just test if the
//            Semaphore is signalled, and -1L, meaning to wait
//            for the Semaphore forever.  Use this last with
//            caution as it can easily hang your app!  The
//            default is set to 250 or 1/4 second.
//
//  AutoKill - Boolean: If true(the default) TMaxInstance calls
//            Application.Terminate if too many apps are open.
//
//  SemName - String:  The name of the global Semaphore.  See
//            the Win32API Help for specifics but basically
//            it doesn't like a '\' directory separator char
//            in the name.  The Kernel Object namespace is all
//            one so try to use a unique name so that the first
//            instance of your App can create the Semaphore.
//            (If you drop the component on the form a GUID
//            string is created automatically to guarantee
//            the kernel object name for the semaphore will
//            be unique.  See Win32API help for more info
//            on GUIDs.)
//
// Events:
//
//  OnSemFailure - Triggered if API Semaphore calls fail outright.
//
//  OnTooMany - Triggered if the current App is over the limit
//              of allowed instances.
//
//  Note that by setting AutoKill to False and assigning handlers
//  to the events above you can do something besides quit if too
//  many App instances are open(like chide the user or something,
//  who knows? :) or if the Semaphore cannot be created.
//  For this reason I included the method FreeSem so that you can
//  free open Semaphore resources in your handlers if desired.

interface

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

const
  WM_ShowYourSelf = WM_USER + 402;

type
  TMaxInstance = class(TComponent)
  private
    FMaxInstances: LongInt;
    FAutoKill,
    FBringToFront: Boolean;
    FSemName,
    FTitle      : string;
    FTimeOut    : DWORD;
    FTooMany,
    FSemFailure  : TNotifyEvent;
  protected
    SemHandle: THandle;
    SemHeld: Boolean;
    ErrorCode: DWORD;

    procedure ShowYourSelf(var Msg: TMsg; var Handled: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function IsSemHeld: Boolean;
    function GetErrorCode: DWORD;
    function GetSem : Integer;
    procedure FreeSem;

  published
    property MaxInstances: LongInt      read FMaxInstances write FMaxInstances default 1;
    property AutoKill    : Boolean      read FAutoKill    write FAutoKill    default True;
    property SemName    : String      read FSemName      write FSemName;
    property TimeOut    : DWORD        read FTimeOut      write FTimeOut      default 250;
    property OnTooMany  : TNotifyEvent read FTooMany      write FTooMany;
    property OnSemFailure: TNotifyEvent read FSemFailure  write FSemFailure;
    property BringToFront: Boolean      read FBringToFront write FBringToFront default True;
    property Title      : String      read FTitle        write FTitle;
  end;

procedure Register;

implementation

uses ActiveX, ComObj;

procedure Register;
begin
  RegisterComponents('Borrisholt', [TMaxInstance]);
end;

{ ---------------------------------------------------------------------------- }

constructor TMaxInstance.Create(AOwner: TComponent);
var
  MyGuid: TGUID;
begin
  inherited Create(AOwner);
  FMaxInstances := 1;
  FAutoKill := True;
  FBringToFront := True;
  FTimeOut := 250;
  FTitle := '';

  if (csDesigning in ComponentState) and (FSemName = '') then
    if CoCreateGuid(MyGuid) = S_OK then
      FSemName := GuidToString(MyGuid);

  Application.OnMessage := ShowYourSelf;
end;

{ ---------------------------------------------------------------------------- }

destructor TMaxInstance.Destroy;
begin
  if SemHeld then
    ReleaseSemaphore(SemHandle, 1, nil);
  if SemHandle <> 0 then
    CloseHandle(SemHandle);
  inherited Destroy;
end;

{ ---------------------------------------------------------------------------- }

function TMaxInstance.IsSemHeld: Boolean;
begin
  Result := SemHeld;
end;

{ ---------------------------------------------------------------------------- }

function TMaxInstance.GetErrorCode: DWORD;
begin
  Result := ErrorCode;
end;

{ ---------------------------------------------------------------------------- }

function TMaxInstance.GetSem : Integer;
var
  WaitVal: DWORD;
  WindowHandle: HWND;
begin
  SemHeld := false;
  ErrorCode := 0;
  SemHandle := CreateSemaphore(nil, MaxInstances, MaxInstances, PChar(SemName));
  if SemHandle = 0 then
  begin
    ErrorCode := GetLastError;

    if Assigned(FSemFailure) then
      OnSemFailure(Self);

    if AutoKill then
      Application.Terminate;
  end;
  WaitVal := WaitForSingleObject(SemHandle, TimeOut);

  Result := WaitVal; //JB 25032002

  case WaitVal of
    WAIT_OBJECT_0 :
                    SemHeld := True;
    WAIT_TIMEOUT  : begin
                      if Assigned(FTooMany) then
                        OnTooMany(Self);

                      if FBringToFront then
                      begin
                        WindowHandle := FindWindow('TApplication', PChar(Title));
                        if WindowHandle <> 0 then
                          PostMessage(WindowHandle, WM_ShowYourSelf, 0, 0);
                      end;

                      if AutoKill then
                        Application.Terminate;
                    end;
    WAIT_ABANDONED: begin
                      ErrorCode := GetLastError;
                      if Assigned(FSemFailure) then
                        OnSemFailure(Self);

                      if AutoKill then
                        Application.Terminate;
                    end;
  end;
end;

{ ---------------------------------------------------------------------------- }

procedure TMaxInstance.FreeSem;
begin
  ErrorCode := 0;
  if SemHeld then
    if not ReleaseSemaphore(SemHandle, 1, nil) then
    begin
      ErrorCode := GetLastError;
      exit;
    end
    else
      SemHeld := False;

  if SemHandle <> 0 then
    if not CloseHandle(SemHandle) then
      ErrorCode := GetLastError
    else
      SemHandle := 0;
end;

{ ---------------------------------------------------------------------------- }

procedure TMaxInstance.ShowYourSelf(var Msg: TMsg; var Handled: Boolean);
// If your application already has assigned a procedure to the "OnMessage" event,
// then copy this "if" statement to the message procedure.
begin
  Handled := False;
  if msg.message = WM_ShowYourSelf then
  begin
    if IsIconic(Application.Handle) then
      Application.Restore;
    Application.BringToFront;
    Handled := True;
  end;
end;

end.


Jens B

Prøv dette:

procedure TForm1.FormCreate(Sender: TObject);
  function AppIsAlreadyRunning(const sUniqueText: String): Boolean;
  begin
    if OpenMutex(MUTEX_ALL_ACCESS,False,PChar(sUniqueText)) <> 0 then
      Result := True
    else
      Result := (CreateMutex(nil,False,PChar(sUniqueText)) = 0);
  end;

begin
  if AppIsAlreadyRunning(Application.Title) then
  begin
    ShowMessage('program terminated det er allerede startet');
    Halt;
  end;
end;

Det var et svar selvom det selvfølgelig er lidt kortere end Jens'es ;-))

Jeg har bare lavet det som et Component ....

Det synes jeg er nemmere !

Jens B

Jens B>Jammen ingen fejl på det

Morten du kan jo etv selv stjæle komponentet .. Så har du det til en anden god gang

ku' aldrig falde mig ind.... jeg er også mest til de nemme løsninger *GG*

Komponenten åbner også mulighed for at sige max 3 kopier !

Jens B

Jeg tror nok jeg spurgte forkert, det er et gammelt problem jeg tog op og jeg havde glemt hvad det egentligt var jeg ville have, jeg vil nemlig have at det allerede kørende instance lukkes ned, derfor message til dette, og så den nye instance overtager (flere grunde; fx commandolinje parameterer).

borrisholt>jeg har ikke tid til at prøve lige nu, men skulle det kunne lukke allerede (her ville det så være det ældste ?) kørende instance ned og beholde det nye ? (nej vel).

morten s>ok, det skrev jeg vist at jeg godt vidste i forvejen, tak alligevel.

tager på pinseferie til Bornholm, på arbejde onsdage igen. God pinse.

lige over !

Lige her før så jeg at hvis man åbner outlook fra quicklaunch menu'en så gøres den allerede kørende instance aktiv, ved at sende en msg til den kørende om at maximere/toFront og så lukke sig selv (det vil jeg altså tro), og jeg ønsker jo at sende en msg til exsiterende om at det skal lukke.
borrisholt>din løsning vil lukke sig selv og ikke den gamle, ved du lidt om hvordan man sender msg til "samme" application, er det jeg gør ikke rigtigt. (Jeg har et flag under init af app som jeg tester på - så app ikke lukker sig selv men kun det instance som er færdig med init, og altså er det kørende instance, det vil virke hvis altså mine msg bare blev sendt rigtigt)

Jeg prøver med et andet og nu mere konkret spørgsmål.
--nop