Project1.dpr

program
Project1;

uses
Forms,
Dialogs,
Unit1 in 'Unit1.pas'{FMain};

{$R *.RES}

begin
Application.Initialize;
Application.Title:='OneInstanceAPP';
If IsTitleExists=0 Then
Begin
Application.CreateForm(TFMain,FMain);
Application.Run;
End Else ShowMessage('Application Already Running !');
End.

Haut de Page ^

Unit1.pas

unit
Unit1;

interface

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

{$R *.DFM}

type
TFMain=class(TForm)
LbMain:TLabel;
LbLink:TLabel;
procedure LbLinkClick(Sender:TObject);

private

public
end;

var
FMain:TFMain;

function IsTitleExists:HWND;

implementation

Function IsTitleExists:HWND;
Var
CNA:Array[0..255]of Char;
ATT:String;
Begin
Result:=0;
ATT:=Application.Title;
Application.Title:='';
Try
GetClassName(Application.Handle,CNA,254);
Result:=FindWindow(CNA,PChar(ATT));
Finally
Application.Title:=ATT;
End;
End;

Procedure TFMain.LbLinkClick(Sender:TObject);
Begin
ShellExecute(Handle,'open',PChar(LbLink.Caption),nil,nil,1);
End;
End.

Haut de Page ^

Unit1.dfm

object FMain: TFMain
Left = 378
Top = 184
BorderIcons = [biSystemMenu]
BorderStyle = bsSingle
Caption = 'OneInstanceAPP'
ClientHeight = 150
ClientWidth = 372
Color = 13619151
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object LbMain: TLabel
Left = 13
Top = 32
Width = 222
Height = 13
Caption = 'Essayez d''executer cette application deux fois'
Font.Charset = ANSI_CHARSET
Font.Color = 3618615
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
Layout = tlCenter
WordWrap = True
end
object LbLink: TLabel
Left = 0
Top = 0
Width = 372
Height = 20
Cursor = crHandPoint
Align = alTop
Alignment = taCenter
AutoSize = False
Caption = 'http://www.delphilab.com'
Color = 9923379
Font.Charset = ANSI_CHARSET
Font.Color = clWhite
Font.Height = -13
Font.Name = 'Tahoma'
Font.Style = []
ParentColor = False
ParentFont = False
Layout = tlCenter
OnClick = LbLinkClick
end
end

Haut de Page ^