Discussion :

[ch16089]

Bonjour,

Comment interdire le lancement de plusieurs instances d'une application (VCL ou Console) ?
Si une instance est en cours d'exécution (masquée par une autre application, réduite dans la barre des tâches, ...), je souhaite restaurer l'application et la mettre au 1er plan.

Merci pour votre aide.

Thierry RICHET

[ShaiLeTroll]

UniqueInstance Delphi se trouve assez vite, c'est via un message pour la mise au premier plan, parfois cela fonctionne moins bien que si c'est l'application externe qui remet l'autre devant.

c'est un
Comment n'instancier qu'une seule fois un programme ?


Ajoute ensuite un FindWindow pour trouver la fenêtre et faire un SetForegroundWindow, comme dans ce code Programme qui se ferme si une autre instance est déjà démarrée

Je ne l'ai pas fait depuis longtemps donc faut mettre au neuf ce code, l'unicode en particulier

Un vieux code de 2002 (il peut être même plus vieux, c'est inspiré d'un exemple de Phidels) qui en plus met la fenêtre de la précédente instance au premier plan
Avec les Delphi gère différemment la MainForm cela peut ne pas fonctionner (MainFormOnTaskbar à False)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
unit Unique_Instance;
 
{
 dans la projet :
 
Application.Initialize;
Application.Title := 'Titre du Programme';
if not UniqueInstance(Application.Title) then Exit;
Application.CreateForm(TMenuFrm, MenuFrm);
Application.Run;
 }
 
 
interface
 
uses
    forms,windows,sysutils;
 
type
  PFindWindowStruct = ^TFindWindowStruct;
  TFindWindowStruct = record
    Caption: string;
    ClassName: string;
    WindowHandle: THandle;
  end;
 
function UniqueInstance(Nom: String): boolean;
procedure GoMainApp(Nom: String);
function FindAWindow(ACaption: string): THandle;
function EnumWindowsProc(hWindow: hWnd;lParam : LongInt): Boolean; stdcall;
 
implementation
 
function UniqueInstance(Nom: String): boolean;
begin
  CreateMutex(nil, False, PChar(Nom));
  Result := GetLastError <> ERROR_ALREADY_EXISTS;
  if not Result then GoMainApp(Application.Title);
end;
 
 
 
procedure GoMainApp(Nom: String);
var
  ActifHnd: THandle;
begin
     ActifHnd:= FindAWindow(Nom);
     if ActifHnd <> 0 then begin
       ShowWindow(ActifHnd, SW_NORMAL);
       SetForegroundWindow(ActifHnd);
     end;
end;
 
function FindAWindow(ACaption: string): THandle;
var
  WindowInfo: TFindWindowStruct;
begin
     with WindowInfo do begin
          Caption:= ACaption;
          ClassName:= '';
          WindowHandle:= 0;
          EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo));
          result:= WindowHandle;
          //showmessage(IntTostr(result));
 
     end;
end;
 
function EnumWindowsProc(hWindow: hWnd;lParam : LongInt): Boolean; stdcall;
var
  lpBuffer: PChar;
  WindowCaptionFound: bool;
  ClassNameFound: bool;
 
begin
     GetMem(lpBuffer, 255);
     Result:= True;
     WindowCaptionFound:= False;
     ClassNameFound:= False;
     try
        if GetWindowText(hWindow, lpBuffer, 255) > 0 then
           if Pos(PFindWindowStruct(lParam).Caption, StrPas(lpBuffer)) = 1 then begin
              WindowCaptionFound:= true;
              if PFindWindowStruct(lParam).ClassName = '' then
            ClassNameFound:= True
         else if GetClassName(hWindow, lpBuffer, 255) > 0 then
              if Pos(PFindWindowStruct(lParam).ClassName, StrPas(lpBuffer)) > 0 then
                 ClassNameFound:= True;
      end;
    if (WindowCaptionFound and ClassNameFound) then begin
      PFindWindowStruct(lParam).WindowHandle:= hWindow;
      Result:= False;
    end;
 
  finally
    FreeMem(lpBuffer, sizeof(lpBuffer^));
  end;
end;
 
end.

[Andnotor]

Les conditions pour passer une fenêtre au premier plan par SetForegroundWindow sont très restrictives et ne seront pas satisfaites au démarrage de la nouvelle instance.

Peut peut-être fonctionner si précédé de SetWindowPos(PrevWnd, HWND_TOP, 0, 0, 0, 0, SWP_SHOWWINDOW or SWP_NOMOVE or SWP_NOSIZE);

[ShaiLeTroll]

Je confirme que si ça fonctionnait bien sous Win98 et Win2K, c'était bien moins efficace en Win Vista, j'ai abandonné depuis longtemps ce genre de fantaisie, ce n'est même pas une chose que j'ai dans ma lib perso que je maintiens depuis 20 ans, c'est resté un code à l'époque de D4/D5 déjà en D7 sous XP, je ne le faisais plus.

Attention, en DEBUG sous Delphi, le comportement n'est pas le même que si tu lances l'EXE en autonome, ça aussi cela peut jouer des tours, on croit que cela fonctionne mais c'est un effort de bord du débogage.


Idem, SetForegroundWindow était précédé souvent de ShowWindow + SetWindowPos
Je confirme, c'est très capricieux !


Sinon SetForegroundWindow, je l'utilise surtout pour EXCEL, une instance lancée ou manipulé par OLE par le programme en cours et même là, c'est capricieux malgré que le programme Delphi soit le créateur de l'instance Excel, mais parfois en forçant un peu :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
//------------------------------------------------------------------------------
procedure SetForegroundWindowAsync(const AWindowExcelCaption: string; Delay: Cardinal = INFINITE);
begin
  TThread.CreateAnonymousThread(
    procedure
    var
      Tentative: Integer;
      ExcelWnd: HWND;
      ForegroundedExcel: Boolean;
    begin
      Tentative := 0;
      repeat
        if Delay <> INFINITE then
          Sleep(Delay);
 
        ExcelWnd := FindWindow(nil, PChar(AWindowExcelCaption));
        ForegroundedExcel := (SetForegroundWindow(ExcelWnd) or LongBool(SetActiveWindow(ExcelWnd)))
          and (GetForegroundWindow() = ExcelWnd);
 
        Inc(Tentative);
      until ForegroundedExcel or (Tentative > 5);
 
    end).Start();
end;

[ch16089]

Merci pour votre réponse.
La solution proposée dans la FAQ répond à mon problème.