FAQ DelphiConsultez toutes les FAQ

1
2
if MyComponent.CanFocus then 
  MyComponent.SetFocus;

1
2
Caption = 'Première ligne' #13#10 'Seconde ligne'; 
Hint = 'Première ligne' #13#10 'Seconde ligne';

1
2
MyLabel.Caption := 'Première ligne' + sLineBreak + 'Seconde ligne'; 
MyLabel.Hint := 'Première ligne' + sLineBreak + 'Seconde ligne';

1
2
ShowMessage('Première ligne' + sLineBreak + 'Seconde ligne'); 
MessageDlg('Première ligne'+ sLineBreak + 'Seconde ligne', mtInformation, [mbOK], 0);

1
2
3
4
{Indique une localisation moyen-orientale } 
SysLocale.MiddleEast := True; 
{Exemple avec un TEdit } 
MyEdit.BiDiMode := bdRightToLeft;

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
type  
  TMonEdit = class(TEdit)  
  private  
    FTextAlign: TAlignment;  
    procedure SetTextAlign(Value: TAlignment);  
  protected  
    procedure CreateParams(var Params: TCreateParams); override;  
  public  
    constructor Create(AOwner: TComponent); override;  
  published  
    property TextAlignment: TAlignment read FTextAlign write SetTextAlign;  
  end;  
implementation  
  
constructor TMonEdit.Create(AOwner: TComponent);  
begin  
  inherited;  
  FTextAlign := taLeftJustify;  
end;  
  
procedure TMonEdit.CreateParams(var Params: TCreateParams);  
const  
Alignments: array[TAlignment] of Word = (ES_LEFT, ES_RIGHT, ES_CENTER);  
begin  
inherited CreateParams(Params);  
Params.Style := Params.Style or Alignments[TextAlignment];  
end;  
  
procedure TMonEdit.SetTextAlign(Value: TAlignment);  
begin  
  if FTextAlign <>Value then  
    Begin  
    FTextAlign := Value;  
    RecreateWnd;  
  End;  
end;

1
2
3
4
5
6
7
8
procedure TMyForm.MyEditKeyPress(Sender: TObject; var Key: Char); 
begin 
  if not (Key in ['0'..'9', DecimalSeparator, Chr(VK_BACK), Chr(VK_DELETE)]) then 
  Key := #0; 
  if Key = DecimalSeparator then 
    if Pos(DecimalSeparator, MyEdit.Text) <> 0 then 
      Key := #0; 
end;

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
procedure VerNumAll(Edit: TEdit; 
    var Key: Char; Moins: Boolean = True; Virgul: Boolean = False); 
  var i, j: integer; 
  begin 
    if Key in [',', '.'] then 
      Key := DecimalSeparator; 
    if not (Key in ['0'..'9', DecimalSeparator, '-', #8]) or ((Key = '-') and not (Moins)) 
      or ((Key = DecimalSeparator) and not (Virgul)) then 
    begin 
      Key := #0; 
    end; 
    if (Key = DecimalSeparator) and (Virgul) then 
      if Pos(DecimalSeparator, Edit.Text) > 0 then 
Key := #0; 
    if (Key = DecimalSeparator) and (Virgul) then 
      if length(Edit.Text) < 1 then 
      begin 
Edit.Text := '0' + DecimalSeparator; 
Edit.SelStart := 2; 
Key := #0; 
      end; 
    if (Key = DecimalSeparator) and (Virgul) then 
      if (copy(Edit.Text, 1, 1) = '-') and (Length(Edit.Text) = 1) then 
      begin 
Edit.Text := '-0' + DecimalSeparator; 
Edit.SelStart := 3; 
Key := #0; 
      end; 
    if (Key = '-') and (Moins) then 
    begin 
      i := Edit.SelStart; 
      j := Edit.SelLength; 
      if Length(Edit.Text) > 1 then 
      begin 
if Edit.Text[1] = '-' then 
begin 
  Edit.Text := Copy(Edit.Text, 2, Length(Edit.Text) - 1); 
  if i = 0 then 
    Dec(j); 
end 
else 
  Edit.Text := '-' + Edit.Text; 
      end 
      else 
if Edit.Text = '-' then 
  Edit.Text := '' 
else 
  Edit.Text := '-' + Edit.Text; 
      if Edit.Text <> '' then 
if Edit.Text[1] = '-' then 
  i := i + 1 
else 
  i := i - 1; 
      Edit.Selstart := i; 
      Edit.SelLength := j; 
      Key := #0; 
    end; 
  end;

1
2
3
4
5
6
7
8
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); 
  begin 
  //Le 3eme paramètre permet de contrôler la saisie du signe 
  //moins 
  //Le 4eme paramètre permet de contrôler la saisie du 
  //séparateur de décimal   
      VerNumAll(TEdit(Sender), Key, True, True); 
  end;

1
2
3
4
5
6
7
8
procedure TForm1.Button1Click(Sender: TObject); 
var 
  i: Integer; 
begin 
  for i:=0 to ControlCount - 1 do 
    if IsPublishedProp(Controls[i], 'Color') and PropIsType(Controls[i], 'Color', tkInteger) then 
      SetOrdProp(Controls[i], 'Color', clRed); 
end;

1
2
3
4
5
6
procedure TForm1.Timer1Timer(Sender: TObject); 
Const Saut=1; 
begin 
  Label1.Caption:=Copy(Label1.Caption,Saut+1,Length(Label1.Caption)-Saut) 
  +Copy(Label1.Caption,1,Saut) ; 
end;

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
function ClientPosToCharIndex(AnEdit: TCustomEdit; ClientPos: TPoint): Integer; 
var 
  lParam: Integer; 
begin 
  { Le format du paramètre LParam étant différent selon le type de composant } 
  { il nous faut tester s'il s'agit d'un RichEdit ou d'un simple Edit (ou Memo).} 
  
  if AnEdit is TRichEdit then 
  begin 
    { Dans le cas d'un RichEdit, le paramètre représente l'adresse d'une } 
    { structure de type TRect contenant la position en coordonnées écran } 
    { relative au composant.} 
    lParam:= Integer(@ClientPos); 
  
    { La valeur retournée correspond à l'index absolu du caractère le plus } 
    { près du point ou du dernier caractère si le point est plus bas que le } 
    { dernier caractère du contrôle. } 
    result:= AnEdit.Perform(EM_CHARFROMPOS, 0, lParam); 
  end 
  else 
  begin 
    { Dans le cas d'un Edit, le paramètre contient deux mots correspondants } 
    { à la position en coordonnées écran relative au composant. Le mot de poids } 
    { faible contient la position horizontale (X) et le mot de poids fort la } 
    { position verticale (Y) } 
    lParam:= ClientPos.Y shl 16 + ClientPos.X; 
  
    { La valeur retournée contient l'index absolu du caractère ainsi que } 
    { l'index de la ligne. } 
    { Le mot de poids faible correspond à l'index absolu du caractère le plus } 
    { près du point ou du dernier caractère si le point est plus bas que le } 
    { dernier caractère du contrôle. } 
    { Le mot de poids fort (l'index de la ligne) n'est pas utilisé dans cet } 
    { exemple. } 
    result:= LoWord(AnEdit.Perform(EM_CHARFROMPOS, 0, lParam)); 
  end; 
end;

1
2
3
4
5
procedure TForm1.Memo1MouseMove(Sender: TObject; Shift: TShiftState; X, 
  Y: Integer); 
begin 
  Label1.Caption:= Memo1.Lines.Text[ClientPosToCharIndex(Memo1, Point(X, Y))]; 
end;

1
2
3
4
MessageDlg(const Msg: string; 
  DlgType: TMsgDlgType; 
  Buttons: TMsgDlgButtons; 
  HelpCtx: Longint): Word;

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
function MDChecked(const Msg,                  { Message à afficher} 
  ChkMsg: string;             { Message de la case à cocher} 
  var checkedValue : boolean; { Valeur de la case à cocher} 
  DlgType: TMsgDlgType;       { Type de la boite de message} 
  Buttons: TMsgDlgButtons)    { boutons} 
  : Word; 
var 
  chk : TCheckBox; 
  frm : TForm; 
begin 
  frm := CreateMessageDialog(Msg, DlgType, Buttons); 
  with frm do 
  try 
    { Ajout d'une case à cocher en bas à gauche} 
    chk := TCheckBox.Create(frm); 
    with chk do 
    begin 
      Checked := checkedValue; 
      Caption := chkMsg; 
      Left := 8; 
      Top := frm.Height - Height - 12; 
      Width := frm.width - left - 1; 
      Parent := frm; 
    end; 
    { Agrandissement de la fenêtre} 
    Height := Height + chk.Height; 
    Position := poScreenCenter; 
    { Affichage} 
    Result := ShowModal; 
    { Récupération de la case à cocher} 
    checkedValue := chk.Checked; 
  finally 
    Free; 
  end; 
end;

1
2
3
4
5
6
7
8
9
10
11
var 
  chk : boolean;  
... 
  if ParametresAppli.AfficherMessage then 
  begin 
    chk := false; 
    MDChecked('Bla bla bla…','Ne plus afficher ce message',chk,mtInformation,[mbOK]); 
    { on inverse la valeur car le texte associé } 
    { à la case à cocher est l'inverse de ce qu'on stocke} 
    ParametresAppli.AfficherMessage := not chk; 
  end;

Pdf1.LoadFile('fichier.pdf');

Image1.Picture := nil;

1
2
3
4
5
6
7
procedure TMainForm.GoToNextEditControls(Sender: TObject; var Key: Word; 
  Shift: TShiftState); 
begin 
  if key = VK_RETURN then  
PostMessage(self.Handle,WM_NEXTDLGCTL,0,0); 
//Nous pouvons aussi utiliser : perform(WM_NEXTDLGCTL,0,0); 
end;

1
2
3
4
procedure TForm1.SynEdit1ContextHelp(Sender: TObject; word: String); 
begin 
  Application.HelpKeyword(word); 
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
procedure TForm1.Button1Click(Sender: TObject); 
var 
  i: Integer; 
begin 
  { Dans cet exemple, nous vidons le TListBox et y ajoutons un grand nombre 
    de chaînes. Nous avons placé l'appel à EndUpdate dans un bloc finally 
    afin d'être certains qu'il soit toujours appelé, même si une exception 
    est levée pendant le remplissage. } 
  
  ListBox1.Items.BeginUpdate; 
  try 
    ListBox1.Items.Clear; 
    for i:= 0 to 99999 do 
      ListBox1.Items.Add(IntToStr(i)); 
  finally 
    ListBox1.Items.EndUpdate; 
  end; 
end;

Self.Menu := nil;

Self.Menu := MainMenu1;

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
function CompareGraphic(const Graphic1, Graphic2: TGraphic): boolean;  
var  
  MyImage1, MyImage2: TMemoryStream;  
begin  
  // Code librement adapté de la fonction TGraphic.Equals  
 //Si l'un des deux vaut nil... 
  if Graphic1 = nil then  
    result:= Graphic2 = nil  
  else if Graphic2 = nil then  
  begin  
    result:= false;  
    exit;  
  end  
  else  
  begin  
    Result:= Graphic1.ClassType = Graphic2.ClassType;  
   //Si l'un des deux est vide 
    if Graphic1.Empty then  
      result:= Graphic2.Empty  
    else  
    begin  
      if result then  
      begin  
        MyImage1 := TMemoryStream.Create;  
        try  
          Graphic1.SaveToStream(MyImage1);  
          MyImage2 := TMemoryStream.Create;  
          try  
            Graphic2.SaveToStream(MyImage2);  
             //On compare la taille des images et la taille binaire des images en mémoire 
            Result := (MyImage1.Size = MyImage2.Size) and  
              CompareMem(MyImage1.Memory, MyImage2.Memory, MyImage1.Size);  
          finally  
            MyImage2.Free;  
          end;  
        finally  
          MyImage1.Free;  
        end;  
      end;  
    end;  
  end;  
end;

1
2
3
4
5
procedure TAboutBox.Label1Click(Sender: TObject); 
begin 
   ShellExecute(Handle,'OPEN','http://www.Developpez.com', 
                       Nil,Nil,SW_SHOW); 
end;

1
2
3
4
procedure TAboutBox.Label1MouseEnter(Sender: TObject);  
begin  
  Label1.Font.Color := clBlue;  
end;

1
2
3
4
procedure TAboutBox.Label1MouseLeave(Sender: TObject);  
begin  
  Label1.Font.Color := clNavy;  
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
var fCanvas: TControlCanvas; 
  
procedure TForm1.CreateClick(Sender: TObject); 
begin 
  fcanvas:=TControlCanvas.Create; 
  fcanvas.Control := Edit1;  // Edit1 est un TEdit 
end; 
  
procedure TForm1.UseClick(Sender: TObject); 
begin 
  fCanvas.Brush.Color := clRed; 
  fCanvas.Rectangle(1, 1,  15, 15); 
  fCanvas.Brush.Color := clWhite; 
  fCanvas.TextOut(17, 0, 'rouge'); 
  //Edit1 contient maintenant un carré rouge puis le texte 'rouge' 
end; 
  
procedure TForm1.freeClick(Sender: TObject); 
begin 
  fCanvas.Free; 
end;

Key := UpCase(Key);

TEdit(Memo1).CharCase := ecUpperCase;

SetWindowLong(Memo1.Handle,GWL_STYLE,GetWindowLong(Memo1.Handle,GWL_STYLE)Or ES_UPPERCASE);

1
2
3
4
procedure TFiche1.FormKeyPress(Sender: TObject; var Key: Char)  
begin  
  MessageDlg(Format('La touche %c a été enfoncée',[Key]).',mtInformation,[mbOk],0);  
end;

FormKeyPress(Fiche1, 'p');

1
2
3
4
5
var c:char;  
begin  
c:='p';  
Fiche1.OnKeyPress(Fiche1, c);  
end;

1
2
3
4
5
var c:char;  
begin  
c:='p';  
self.OnKeyPress(self, c);  
end;

FormKeyPress(nil,c);

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
unit UnitMenusCouleurs;  
  
interface  
uses Windows,Menus,Graphics,types;  
  
type  
  TMenuItemHelper=class(TMenuItem)  
  public  
    procedure DoAdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);  
  end;  
  
implementation  
  
procedure TMenuItemHelper.DoAdvancedDrawItem(  
  ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);  
var IsTopLevel:Boolean;  
    OldEvent:TAdvancedMenuDrawItemEvent;  
begin  
  OldEvent:=OnAdvancedDrawItem;  
  OnAdvancedDrawItem:=nil;  
  IsTopLevel:=(GetParentComponent is TMainMenu);  
  AdvancedDrawItem(ACanvas,ARect,State,IstopLevel);  
  OnAdvancedDrawItem:=OldEvent;  
end;  
  
end.

1
2
3
4
5
...  
implementation  
uses UnitMenusCouleurs;  
{$R *.dfm}  
...

1
2
3
4
5
6
7
procedure TForm1.UnMenuItem2AdvancedDrawItem(Sender: TObject;  
  ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);  
begin  
  ACanvas.Font.Color:=clRed;  
  ACanvas.Brush.Color:=clYellow;  
  TMenuItemHelper(Sender).DoAdvancedDrawItem(ACanvas,ARect,State);  
end;

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
unit UnitSuperMenus;  
  
interface  
uses Windows, Classes, Menus,Graphics,types,ImgList;  
  
type  
  TImageIndex=type Integer;  
  
  TMenuItemPublic=class(TComponent)  
  public  
    FCaption: string;  
    FHandle: HMENU;  
    FChecked: Boolean;  
    FEnabled: Boolean;  
    FDefault: Boolean;  
    FAutoHotkeys: TMenuItemAutoFlag;  
    FAutoLineReduction: TMenuItemAutoFlag;  
    FRadioItem: Boolean;  
    FVisible: Boolean;  
    FGroupIndex: Byte;  
    FImageIndex: TImageIndex;  
    FActionLink: TMenuActionLink;  
    FBreak: TMenuBreak;  
    FBitmap: TBitmap;  
    FCommand: Word;  
    FHelpContext: THelpContext;  
    FHint: string;  
    FItems: TList;  
    FShortCut: TShortCut;  
    FParent: TMenuItem;  
    FMerged: TMenuItem;  
    FMergedWith: TMenuItem;  
    FMenu: TMenu;  
    FStreamedRebuild: Boolean;  
    FImageChangeLink: TChangeLink;  
    FSubMenuImages: TCustomImageList;  
    FOnChange: TMenuChangeEvent;  
    FOnClick: TNotifyEvent;  
    FOnDrawItem: TMenuDrawItemEvent;  
    FOnAdvancedDrawItem: TAdvancedMenuDrawItemEvent;  
    FOnMeasureItem: TMenuMeasureItemEvent;  
    FAutoCheck: Boolean;  
  end;  
  
  TMenuItemHelper=class(TMenuItem)  
  public  
    procedure DoAdvancedDrawItem(ACanvas: TCanvas; ARect: TRect;  
      State: TOwnerDrawState; NewIndex:Integer);  
  end;  
  
implementation  
uses SysUtils;  
  
  
{ TMenuItemHelper }  
  
procedure TMenuItemHelper.DoAdvancedDrawItem(ACanvas: TCanvas;  
  ARect: TRect; State: TOwnerDrawState;  
  NewIndex: Integer);  
var OldMenuDrawItemEvent:TMenuDrawItemEvent;  
    OldAdvancedMenuDrawItemEvent:TAdvancedMenuDrawItemEvent;  
    IsTopLevel:Boolean;  
begin  
  OldMenuDrawItemEvent:=OnDrawItem;  
  OldAdvancedMenuDrawItemEvent:=OnAdvancedDrawItem;  
  OnDrawItem:=nil;  
  OnAdvancedDrawItem:=nil;  
  TMenuItemPublic(Self).FImageIndex:=NewIndex;  
  IsTopLevel:=(GetParentComponent is TMainMenu);  
  AdvancedDrawItem(ACanvas,ARect,State,IsTopLevel);  
  OnDrawItem:=OldMenuDrawItemEvent;  
  OnAdvancedDrawItem:=OldAdvancedMenuDrawItemEvent;  
end;  
  
end.

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
procedure TForm1.HelpItemAdvancedDrawItem(Sender: TObject;  
  ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);  
var NewImageIndex:Integer;  
begin  
  // En fonction de l'état de l'élément de menu, on assigne un Nouvel ImageIndex  
  if (OdSelected   in State)  
  then NewImageIndex:=1  
  else NewImageIndex:=2;  
 // Puis on effectue le dessin du MenuItem comme ceci  :  
TMenuItemHelper(Sender).DoAdvancedDrawItem(ACanvas,ARect,State,NewImageIndex);  
end;  
  
procedure TForm1.ExitItemAdvancedDrawItem(Sender: TObject;  
  ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);  
var NewImageIndex:Integer;  
begin  
  // Bonus1 : on en profite pour changer la Police du MenuItem  
  ACanvas.Font.Color:=clRed;  
  // ...et sa couleur d'arrière plan (voir rubriques connexes)  
  ACanvas.Brush.Color:=clYellow;  
  
  // En fonction de l'état de l'élément de menu, on assigne un Nouvel ImageIndex  
  if (OdSelected   in State)  
  then NewImageIndex:=3  
  else NewImageIndex:=4;  
  //Puis on effectue le dessin du MenuItem comme ceci  :  
TMenuItemHelper(Sender).DoAdvancedDrawItem(ACanvas,ARect,State,NewImageIndex);  
end;

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
101
102
103
104
105
106
interface 
... 
type 
  TAlignementVertical=(alVTop,alVCenter,alVBottom); 
  TAlignementHorizontal=(alHLeft,alHCenter,alHRight); 
  TJustification=(JustLeft,JustCenter,JustRight); 
  procedure DessineTexteMultiligne(AString:string;ACanvas:TCanvas;ARect: TRect; 
                       AlignementHorizontal:TAlignementHorizontal; 
                       AlignementVertical:TAlignementVertical; 
                       TextJustification:TJustification); 
... 
implementation 
  
// Voir FAQ Delphi de www.developpez.com pour cette fonction : 
// URL : http://delphi.developpez.com/faq/?page=Chaines-de-caracteres#Comment-connaitre-la-largeur-et-la-hauteur-en-pixels-d-un-texte 
Function TextSize(Phrase : string; Police : TFont = nil) : TPoint; 
var 
  DC: HDC; 
  X: Integer; 
  Rect: TRect; 
  C : TBitmap; 
begin 
  C := TBitmap.create; 
  if police <> nil then  C.canvas.Font := police; 
  
    Rect.Left := 0; 
    Rect.Top:=0; 
    Rect.Right:=0; 
    Rect.Bottom:=0; 
    DC := GetDC(0); 
    C.Canvas.Handle := DC; 
    DrawText(C.Canvas.Handle, PChar(Phrase), -1, Rect, (DT_EXPANDTABS or DT_CALCRECT)); 
    C.Canvas.Handle := 0; 
    ReleaseDC(0, DC); 
    result.X:=Rect.Right-Rect.Left; 
    result.Y:=Rect.Bottom-Rect.Top; 
    C.Free; 
end; 
  
// Notre procedure d'affichage de texte multiligne 
procedure DessineTexteMultiligne(AString: string;ACanvas:TCanvas;ARect: TRect; 
                       AlignementHorizontal:TAlignementHorizontal; 
                       AlignementVertical:TAlignementVertical; 
                       TextJustification:TJustification); 
var 
  AHeight,AWidth:integer; 
  Rect,oldClipRect:TRect; 
  ATop,ALeft,H,W:Integer; 
  AText:string; 
  JustificationDuTexte:Integer; 
  MyRgn:HRGN; 
begin 
  with ACanvas do 
  begin 
    Lock; 
    AHeight:=ARect.Bottom-ARect.Top; 
  
    AWidth:=ARect.Right-ARect.Left; 
    // On calcule la taille du rectangle dans lequel va tenir le texte 
    W:=TextSize(AString,ACanvas.Font).X; 
    H:=TextSize(AString,ACanvas.Font).Y; 
  
    // On calcule la position (Haut,Gauche) du rectangle dans lequel va tenir le texte 
    // en fonction de l'alignement horizontal et vertical choisi 
    ATop:=ARect.Top; 
    ALeft:=ARect.Left; 
  
  
    case AlignementVertical of 
      alVBottom : ATop:=ARect.Bottom-H; 
      alVCenter : ATop:=ARect.Top+((AHeight-H) div 2); 
      alVTop    : ATop:=ARect.Top; 
    end; 
  
    case AlignementHorizontal of 
      alHLeft  : ALeft:=ARect.Left; 
      alHCenter: ALeft:=ARect.Left+(AWidth-W) div 2; 
      alHRight : ALeft:=ARect.Right-W; 
    end; 
  
    // Fin du calcul du rectangle, on met le resultat dans Rect 
    Rect:=Bounds(ALeft,ATop,W,H); 
  
    //On remplit le rectangle de la zone sinon on voit le texte que delphi à dessiné 
    FillRect(ARect); 
  
    // On détermine les paramètres de justification à passer à Windows 
    case TextJustification of 
      JustLeft  : JustificationDuTexte:=DT_LEFT; 
      JustCenter: JustificationDuTexte:=DT_CENTER; 
      JustRight : JustificationDuTexte:=DT_RIGHT; 
    end; 
  
    // Si le texte est plus grand que notre zone, on prend cette précaution (Clipping) 
    with ARect do MyRgn :=CreateRectRgn(Left,Top,Right,Bottom); 
    SelectClipRgn(Handle,MyRgn); 
  
    // On dessine le texte 
    DrawText(Handle,PChar(AString),-1,Rect,JustificationDuTexte or DT_NOPREFIX or DT_WORDBREAK ); 
  
    // On a plus besoin de la zone de clipping 
    SelectClipRgn(Handle,0); 
    DeleteObject(MyRgn); 
    Unlock; 
  end; 
end;

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
101
102
103
104
105
106
interface 
... 
type 
  TAlignementVertical=(alVTop,alVCenter,alVBottom); 
  TAlignementHorizontal=(alHLeft,alHCenter,alHRight); 
  TJustification=(JustLeft,JustCenter,JustRight); 
  procedure DessineTexteMultiligne(AString:string;ACanvas:TCanvas;ARect: TRect; 
                       AlignementHorizontal:TAlignementHorizontal; 
                       AlignementVertical:TAlignementVertical; 
                       TextJustification:TJustification); 
... 
implementation 
  
//Voir FAQ Delphi de www.developpez.com pour cette fonction : 
//URL : http://delphi.developpez.com/faq/?page=http://delphi.developpez.com/faq/?page=Chaines-de-caracteres#Comment-connaitre-la-largeur-et-la-hauteur-en-pixels-d-un-texte 
Function TextSize(Phrase : string; Police : TFont = nil) : TPoint; 
var 
  DC: HDC; 
  X: Integer; 
  Rect: TRect; 
  C : TBitmap; 
begin 
  C := TBitmap.create; 
  if police <> nil then  C.canvas.Font := police; 
  
    Rect.Left := 0; 
    Rect.Top:=0; 
    Rect.Right:=0; 
    Rect.Bottom:=0; 
    DC := GetDC(0); 
    C.Canvas.Handle := DC; 
    DrawText(C.Canvas.Handle, PChar(Phrase), -1, Rect, (DT_EXPANDTABS or DT_CALCRECT)); 
    C.Canvas.Handle := 0; 
    ReleaseDC(0, DC); 
    result.X:=Rect.Right-Rect.Left; 
    result.Y:=Rect.Bottom-Rect.Top; 
    C.Free; 
end; 
  
//Notre procedure d'affichage de texte multiligne 
procedure DessineTexteMultiligne(AString: string;ACanvas:TCanvas;ARect: TRect; 
                       AlignementHorizontal:TAlignementHorizontal; 
                       AlignementVertical:TAlignementVertical; 
                       TextJustification:TJustification); 
var 
  AHeight,AWidth:integer; 
  Rect,oldClipRect:TRect; 
  ATop,ALeft,H,W:Integer; 
  AText:string; 
  JustificationDuTexte:Integer; 
  MyRgn:HRGN; 
begin 
  with ACanvas do 
  begin 
    Lock; 
    AHeight:=ARect.Bottom-ARect.Top; 
  
    AWidth:=ARect.Right-ARect.Left; 
    // On calcule la taille du rectangle dans lequel va tenir le texte 
    W:=TextSize(AString,ACanvas.Font).X; 
    H:=TextSize(AString,ACanvas.Font).Y; 
  
    // On calcule la position (Haut,Gauche) du rectangle dans lequel va tenir le texte 
    // en fonction de l'alignement horizontal et vertical choisi 
    ATop:=ARect.Top; 
    ALeft:=ARect.Left; 
  
  
    case AlignementVertical of 
      alVBottom : ATop:=ARect.Bottom-H; 
      alVCenter : ATop:=ARect.Top+((AHeight-H) div 2); 
      alVTop    : ATop:=ARect.Top; 
    end; 
  
    case AlignementHorizontal of 
      alHLeft  : ALeft:=ARect.Left; 
      alHCenter: ALeft:=ARect.Left+(AWidth-W) div 2; 
      alHRight : ALeft:=ARect.Right-W; 
    end; 
  
    // Fin du calcul du rectangle, on met le resultat dans Rect 
    Rect:=Bounds(ALeft,ATop,W,H); 
  
    // On remplit le rectangle de la zone sinon on voit le texte que delphi à dessiné 
    FillRect(ARect); 
  
    // On détermine les paramètres de justification à passer à Windows 
    case TextJustification of 
      JustLeft  : JustificationDuTexte:=DT_LEFT; 
      JustCenter: JustificationDuTexte:=DT_CENTER; 
      JustRight : JustificationDuTexte:=DT_RIGHT; 
    end; 
  
    // Si le texte est plus grand que notre zone, on prend cette précaution (Clipping) 
    with ARect do MyRgn :=CreateRectRgn(Left,Top,Right,Bottom); 
    SelectClipRgn(Handle,MyRgn); 
  
    // On dessine le texte 
    DrawText(Handle,PChar(AString),-1,Rect,JustificationDuTexte or DT_NOPREFIX or DT_WORDBREAK ); 
  
    // On a plus besoin de la zone de clipping 
    SelectClipRgn(Handle,0); 
    DeleteObject(MyRgn); 
    Unlock; 
  end; 
end;

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
function DefMessageDlg(const aCaption: string; const Msg: string; DlgType: TMsgDlgType; 
 Buttons: TMsgDlgButtons; DefButton: TModalResult; HelpCtx: Longint): Integer; 
// Crée une fenêtre de dialogue en précisant le bouton actif. 
// Exemple avec le bouton non par défaut 
// if DefMessageDlg('Voulez-vous le supprimer ?', mtConfirmation, mbYesNoCancel, mrno, 0) ... 
var 
 i: Integer; 
 btn: TButton; 
begin 
 with CreateMessageDialog(Msg, DlgType, Buttons) do 
 try 
   Caption := aCaption; 
   HelpContext := HelpCtx; 
   for i := 0 to ComponentCount - 1 do 
   begin 
     if Components[i] is TButton then 
     begin 
       btn := TButton(Components[i]); 
       btn.default := btn.ModalResult = DefButton; 
       if btn.default then 
         ActiveControl := Btn; 
     end; 
   end; 
   Result := ShowModal; 
 finally 
   Free; 
 end; 
end;

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
function MsgEx(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; DefaultButton:TMsgDlgBtn):TModalresult; 
var phr:string; 
begin 
  if DefaultButton in Buttons then 
  begin 
      case DefaultButton of //On récupère le nom du bouton d'après son type 
        mbYes:phr:='Yes'; 
        mbNo:phr:='No'; 
        mbOK:phr:='OK'; 
        mbCancel:phr:='Cancel'; 
        mbAbort:phr:='Abort'; 
        mbRetry:phr:='Retry'; 
        mbIgnore:phr:='Ignore'; 
        mbAll:phr:='All'; 
        mbNoToAll:phr:='NoToAll'; 
        mbYesToAll:phr:='YesToAll'; 
        mbHelp:phr:='Help'; 
      end; 
      with CreateMessageDialog(Msg,DlgType,Buttons) do 
      try 
        activecontrol:=twincontrol(findcomponent(phr)); 
        result:=ShowModal; 
      finally 
        free; 
    end; 
  end else result:=Messagedlg(Msg,DlgType,Buttons,0); 
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
procedure WinControl_to_Bitmap(AWinControl:TWinControl;ABitmap:TBitmap); 
begin 
  ABitmap.Width:=AWinControl.Width; 
  ABitmap.Height:=AWinControl.Height; 
  AWinControl.PaintTo(ABitmap.Canvas,0,0); 
end; 
  
procedure TForm1.Button2Click(Sender: TObject); 
var ABitmap:TBitmap; 
begin 
  ABitmap:=TBitmap.Create; 
  WinControl_to_Bitmap(Panel1,ABitmap); 
  
  //utilisation du Bitmap 
  Form1.Canvas.Draw(0,0,ABitmap); 
  
  ABitmap.Free; 
end;

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
type 
  // Pour rendre la propriété canvas publique voir FAQ  
  // Comment accéder aux Méthodes "Protected" d'une classe ? 
  // ici : http://delphi.developpez.com/faq/?page=Langage#Comment-acceder-aux-methodes-Protected-d-une-classe 
  // La méthode décrite dans la FAQ fonctionne aussi avec les propriétés 
  TPublicGraphicControl=class(TGraphicControl); 
  
procedure GraphicControl_to_Bitmap(AGraphicControl:TGraphicControl;ABitmap:TBitmap); 
begin 
  ABitmap.Width:=AGraphicControl.Width; 
  ABitmap.Height:=AGraphicControl.Height; 
  ABitmap.Canvas.CopyRect(ABitmap.Canvas.ClipRect,TPublicGraphicControl(AGraphicControl).Canvas, 
                          AGraphicControl.ClientRect); 
end; 
  
procedure TForm1.Button3Click(Sender: TObject); 
var ABitmap:TBitmap; 
begin 
  ABitmap:=TBitmap.Create; 
  GraphicControl_to_Bitmap(Shape1,ABitmap); 
  
  //utilisation du Bitmap 
  Form1.Canvas.Draw(0,0,ABitmap); 
  
  ABitmap.Free; 
end;

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 Control_to_Bitmap(AControl:TControl;ABitmap:TBitmap); 
begin 
  if (AControl is TWinControl) then WinControl_to_Bitmap((AControl as TWinControl),ABitmap); 
  if (AControl is TGraphicControl) then GraphicControl_to_Bitmap((AControl as TGraphicControl),ABitmap); 
end; 
  
procedure TForm1.Button4Click(Sender: TObject); 
var ABitmap:TBitmap; 
begin 
  ABitmap:=TBitmap.Create; 
  
  // Copie du Panel dans le Bitmap 
  Control_to_Bitmap(Panel1,ABitmap); 
  
  // Utilisation du premier Duplicata (celui du TPanel et de son contenu) 
  Form1.Canvas.Draw(0,0,ABitmap); 
  
  // Copie du Panel dans le Bitmap 
  Control_to_Bitmap(Shape1,ABitmap); 
  
  // Utilisation du deuxième Duplicata (celui du TShape et de son contenu) 
  Form1.Canvas.Draw(0,0,ABitmap); 
  ABitmap.Free; 
end;

Pt : TPoint ;

1
2
3
4
5
6
7
8
9
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; 
    Rect: TRect; State: TGridDrawState); 
  begin 
    if gdSelected in State then 
    begin 
      Pt.X := Rect.Left; 
      Pt.Y := Rect.Top; 
    end; 
  end;

1
2
3
4
5
6
7
8
9
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; 
    DataCol: Integer; Column: TColumn; State: TGridDrawState); 
  begin 
    if gdSelected in State then 
    begin 
      Pt.X := Rect.Left; 
      Pt.Y := Rect.Top; 
    end; 
  end;

1
2
3
4
5
6
7
procedure TForm1.StringGrid1KeyUp(Sender: TObject; var Key: Word; 
    Shift: TShiftState); 
  begin 
    if Key = VK_Apps then 
      with TCustomGrid(Sender).ClientToScreen(Pt) do 
        PopupMenu1.Popup(X + 4, Y + 4); 
  end;

1
2
3
4
5
6
7
8
9
10
11
12
type 
  TUneClasse = class(TCustomPanel) 
  private 
    { Déclarations privées } 
  protected 
    { Déclarations protégées } 
  public 
    { Déclarations publiques } 
    procedure ValidateInsert(AComponent: TComponent); override; 
  published 
    { Déclarations publiées } 
  end;

1
2
3
4
5
procedure TUneClasse.ValidateInsert(AComponent: TComponent); 
begin 
  if not (AComponent is TButton) then 
    Raise Exception.Create('Ce contrôle n''est pas un TButton. Insertion annulée'); 
end;

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
unit Unit1; 
  
 interface 
  
 uses 
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
   Dialogs, StdCtrls, ExtDlgs, ExtCtrls; 
  
 type 
   TForm1 = class(TForm) 
     Button1: TButton; 
     procedure FormCreate(Sender: TObject); 
     procedure Button1Click(Sender: TObject); 
   private 
     { Déclarations privées } 
     oldBtnProc : TWndMethod; 
     Procedure MyBtnWndProc( Var msg : TMessage ); 
   public 
     { Déclarations publiques }      
   end; 
  
 var 
   Form1: TForm1; 
  
 implementation 
  
 {$R *.dfm} 
 procedure TForm1.FormCreate(Sender: TObject); 
 begin 
   // Sauvegarde la WndProc actuelle du bouton 
   oldBtnProc := Button1.WindowProc; 
   // Affecte une nouvelle procédure de fenêtre. 
   Button1.WindowProc := MyBtnWndProc; 
 end; 
  
 procedure TForm1.Button1Click(Sender: TObject); 
 begin 
   ShowMessage('Coucou !'); 
 end; 
  
 procedure TForm1.MyBtnWndProc(var msg: TMessage); 
 Var hdcBtn : HDC; 
     btnCanvas : TControlCanvas; 
     i,j:Integer; 
     AColor,OldColor:TColor; 
 Begin 
   OldBtnProc(msg); 
   If (msg.Msg = BM_SETSTATE) Or (msg.Msg = WM_PAINT) Or (msg.Msg = WM_NCPAINT) Then 
   Begin 
     btnCanvas := TControlCanvas.Create;   
     Try       
       btnCanvas.Control:=Button1; 
       OldColor:=TColor(GetTextColor(btnCanvas.Handle));  
       for i:=2 to Button1.ClientWidth-3 do 
         for j:=2 to Button1.ClientHeight-3 do 
         begin 
           AColor:=btnCanvas.Pixels[i,j]; 
           if AColor<>OldColor 
           then btnCanvas.Pixels[i,j]:=clyellow; 
         end; 
     Finally 
       btnCanvas.Free; 
     End; 
   End; 
 End; 
  
 end.

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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
unit Unit1; 
  
interface 
  
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls, XPMan; 
  
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    XPManifest1: TXPManifest; 
    procedure FormCreate(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
  private 
    { Déclarations privées } 
    oldBtnProc : TWndMethod; 
    Procedure MyBtnWndProc( Var msg : TMessage ); 
   public 
     { Déclarations publiques } 
  end; 
  
var 
  Form1: TForm1; 
  
implementation 
  
{$R *.dfm} 
type 
   pRGBTripleArray = ^TRGBTripleArray; 
   TRGBTripleArray = array [0 .. 65535] of TRGBTriple; 
   TColorMatch=(cmEqual,cmDifferent); 
  
procedure ChangeColor(Source: TBitmap; const OldColor,NewColor: TColor;ColorMatch:TColorMatch;TransparencePourcent:integer); 
var 
      I, J: Integer; 
      P: pRGBTripleArray; 
      R1, G1, B1: Integer; 
      R2, G2, B2: Integer; 
      R3, G3, B3: Integer; 
      CL1,CL2:Integer; 
      egal:boolean; 
      p1,p2:single; 
begin 
      if ((TransparencePourcent<0) or (TransparencePourcent>100)) then exit; 
      Source.PixelFormat := pf24bit; 
      CL1:=ColorToRGB(OldColor); 
      CL2:=ColorToRGB(NewColor); 
      R1 := GetRValue(CL1); 
      G1 := GetGValue(CL1); 
      B1 := GetBValue(CL1); 
      R2 := GetRValue(CL2); 
      G2 := GetGValue(CL2); 
      B2 := GetBValue(CL2); 
      p1:=TransparencePourcent/100; 
      p2:=1-p1; 
      for J := 0 to Source.Height - 1 do 
      begin 
        P := Source.ScanLine[J]; 
        for I := 0 to Source.Width - 1 do 
        begin 
          R3 := P[i].rgbtRed; 
          G3 := P[i].rgbtGreen; 
          B3 := P[i].rgbtBlue; 
          egal:=((P[i].rgbtRed=R1) and (P[i].rgbtGreen=G1) and (P[i].rgbtBlue=B1)); 
          if (egal=(ColorMatch=cmequal)) then 
          begin 
            P[i].rgbtRed   := round(R2*p2+R3*p1); 
            P[i].rgbtGreen := round(G2*p2+G3*p1); 
            P[i].rgbtBlue  := round(B2*p2+B3*p1); 
          end; 
        end; 
      end; 
end; 
  
procedure TForm1.MyBtnWndProc(var msg: TMessage); 
 Var hdcBtn : HDC; 
     btnCanvas : TControlCanvas; 
     i,j:Integer; 
     AColor,OldColor:TColor; 
     ABitmap:TBitmap; 
     ARect:TRect; 
 Begin 
   OldBtnProc(msg); 
   If (msg.Msg = BM_SETSTATE) Or (msg.Msg = WM_PAINT) Or (msg.Msg = WM_NCPAINT) Then 
   Begin 
     btnCanvas := TControlCanvas.Create; 
     ABitmap:=TBitmap.Create; 
     Try 
       btnCanvas.Control:=Button1; 
       OldColor:=TColor(GetTextColor(btnCanvas.Handle)); 
  
       //copie du canvas dans le bitmap; 
       ABitmap.Width:=Button1.ClientWidth; 
       ABitmap.Height:=Button1.ClientHeight; 
  
       ARect:=ABitmap.Canvas.ClipRect; 
       ABitmap.Canvas.CopyRect(ARect,btnCanvas,ARect); 
       ChangeColor(ABitmap,OldColor,clYellow,cmDifferent,50); 
       btnCanvas.CopyRect(ARect,ABitmap.Canvas,ARect); 
     Finally 
       btnCanvas.Free; 
       ABitmap.Free; 
     End; 
   End; 
 End; 
  
procedure TForm1.FormCreate(Sender: TObject); 
begin 
   // Sauvegarde la WndProc actuelle du bouton 
   oldBtnProc := Button1.WindowProc; 
   // Affecte une nouvelle procédure de fenêtre. 
   Button1.WindowProc := MyBtnWndProc; 
end; 
  
procedure TForm1.Button1Click(Sender: TObject); 
begin 
   ShowMessage('Coucou !'); 
end; 
  
end.

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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
interface 
... 
type 
  TAlignementVertical=(alVTop,alVCenter,alVBottom); 
  TAlignementHorizontal=(alHLeft,alHCenter,alHRight); 
  TJustification=(JustLeft,JustCenter,JustRight); 
  procedure DessineTexteMultiligne(AString: string;  
                       ACanvas:TCanvas;ARect: TRect; 
                       AlignementHorizontal:TAlignementHorizontal; 
                       AlignementVertical:TAlignementVertical; 
                       TextJustification:TJustification; 
                       WordWrap:boolean); 
... 
implementation 
  
///La valeur du paramètre AWidth détermine si on effectue un retour 
//à la ligne automatique ou non : 
//    - avec AWidth=0 => pas de WordWrap 
//    - avec AWidth<>0 => WorWrap sur la largeur donnée 
Function TextSize2(Phrase: string; AWidth: integer; Police: TFont = nil): TPoint; 
var 
  DC: HDC; 
  X: Integer; 
  Rect: TRect; 
  C : TBitmap; 
  WordWrapParams:integer; 
begin 
  C := TBitmap.create; 
  if police <> nil then  C.canvas.Font := police; 
  
  Rect.Left := 0; 
  Rect.Top:=0; 
  Rect.Right:=AWidth; 
  Rect.Bottom:=0; 
  DC := GetDC(0); 
  C.Canvas.Handle := DC; 
  
  WordWrapParams:=0; 
  if AWidth<>0 then WordWrapParams:=DT_NOPREFIX or DT_WORDBREAK; 
  
  DrawText(C.Canvas.Handle, PChar(Phrase), -1, Rect, WordWrapParams or (DT_EXPANDTABS or DT_CALCRECT)); 
  C.Canvas.Handle := 0; 
  ReleaseDC(0, DC); 
  Result.X:=Rect.Right-Rect.Left; 
  Result.Y:=Rect.Bottom-Rect.Top; 
  C.Free; 
end; 
  
//Notre procedure d'affichage de texte multiligne 
function DessineTexteMultiligne(AString: string;ACanvas:TCanvas;ARect: TRect; 
                       AlignementHorizontal:TAlignementHorizontal; 
                       AlignementVertical:TAlignementVertical; 
                       TextJustification:TJustification; 
                       WordWrap:boolean):TRect; 
var 
  AHeight,AWidth:integer; 
  Rect,oldClipRect:TRect; 
  ATop,ALeft,H,W:Integer; 
  AText:string; 
  JustificationDuTexte:Integer; 
  APoint:TPoint; 
begin 
  with ACanvas do 
  begin 
    Lock; 
    AHeight:=ARect.Bottom-ARect.Top; 
    AWidth:=ARect.Right-ARect.Left; 
    //on calcule la taille du rectangle dans lequel va tenir le texte (sans WordWrap) 
    APoint:=TextSize2(AString,0,ACanvas.Font); 
    W:=APoint.X; 
    H:=APoint.Y; 
  
    //on calcule la position (Haut,Gauche) du rectangle dans lequel va tenir le texte 
    //en fonction de l'alignement horizontal et vertical choisi 
    ATop:=ARect.Top; 
    ALeft:=ARect.Left; 
  
    If WordWrap then //Si on veut un "WordWrap" (retour à la ligne automatique) 
      if W>(ARect.Right-ARect.Left) then //et que le texte dépasse du rectangle de destination 
      begin //alors... 
        W:=(ARect.Right-ARect.Left); //on fixe la largeur du texte 
        H:=TextSize2(AString,W,ACanvas.Font).y; //on recalcule la hauteur du texte 
      end; 
  
    case AlignementVertical of 
      alVBottom : ATop:=ARect.Bottom-H; 
      alVCenter : ATop:=ARect.Top+((AHeight-H) div 2); 
      alVTop    : ATop:=ARect.Top; 
    end; 
  
    case AlignementHorizontal of 
      alHLeft  : ALeft:=ARect.Left; 
      alHCenter: ALeft:=ARect.Left+(AWidth-W) div 2; 
      alHRight : ALeft:=ARect.Right-W; 
    end; 
  
    //Fin du calcul du rectangle, on met le resultat dans Rect 
    Rect:=Bounds(ALeft,ATop,W,H); 
    //Si le texte est plus grand que notre zone, on prend cette précaution (Clipping) 
    IntersectRect(Rect,Rect,ARect); 
    //On détermine les paramètres de justification à passer à Windows 
    case TextJustification of 
      JustLeft  : JustificationDuTexte:=DT_LEFT; 
      JustCenter: JustificationDuTexte:=DT_CENTER; 
      JustRight : JustificationDuTexte:=DT_RIGHT; 
    end; 
  
  
    //On dessine le texte 
    DrawText(Handle,PChar(AString),-1,Rect,JustificationDuTexte or DT_NOPREFIX or DT_WORDBREAK ); 
  
    result:=Rect;     
    unlock; 
  end; 
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
//unités à déclarer dans votre clause uses 
uses windows,Graphics; 
... 
function IsTrueTypeFont(NomPolice : string):boolean; 
var 
  Metrics: TTextMetric; 
  ACanvas : TCanvas; 
  DC:HDC; 
begin 
  ACanvas:=TCanvas.Create; 
  try 
    DC:=GetDC(HWND_DESKTOP); 
    ACanvas.Handle:=DC; 
    ACanvas.Font.Name:=NomPolice ; 
    GetTextMetrics(ACanvas.Handle, Metrics) ; 
    ReleaseDC(0,DC); 
    Result:=(Metrics.tmPitchAndFamily and TMPF_TRUETYPE) <> 0; 
  finally 
    ACanvas.free; 
  end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
procedure SupprimerDoublons(Strings : TStrings; CaseSensitive : boolean = True); 
var SL : THashedStringList; 
begin 
  SL := THashedStringList.Create; 
  try 
    SL.Duplicates := dupIgnore; 
    SL.CaseSensitive := CaseSensitive; 
    SL.Sorted := True; // Sinon Duplicates ne fait rien ! 
  
    SL.Capacity := Strings.Capacity;// Allocation du tableau une fois pour toutes 
    SL.AddStrings(Strings); 
  
    Strings.BeginUpdate(); 
    try 
      Strings.Clear(); 
      Strings.Capacity := SL.Capacity;// Allocation du tableau 
      Strings.AddStrings(SL); 
    finally 
      Strings.EndUpdate(); 
    end; 
    SL.Free; 
  end; 
end;

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
function GetTextSize  (const AControl : TWinControl; 
                       const AFont    : TFont; 
                       const AText    : string): TSize; 
var DC: HDC; 
begin 
  DC := GetWindowDC(AControl.Handle); 
  Result.cx := 0; 
  Result.cy := 0; 
  SelectObject(DC, AFont.Handle); 
  GetTextExtentPoint32(DC, PChar(AText), Length(AText), Result); 
  ReleaseDC(AControl.Handle, DC); 
end; 
  
function GetTextWidth (const AControl : TWinControl; 
                       const AFont    : TFont; 
                       const AText    : string): Integer; 
begin 
  Result := GetTextSize(AControl, AFont, AText).cx 
end; 
  
function GetTextHeight(const AControl : TWinControl; 
                       const AFont    : TFont; 
                       const AText    : string): Integer; 
begin 
  Result := GetTextSize(AControl, AFont, AText).cy 
end;

1
2
// renvoie le nom du composant sur lequel il y a le focus. 
ShowMessage(maForm.ActiveControl.name);

1
2
3
4
5
6
7
8
9
10
11
12
13
{ ================================================================== } 
const 
  EM_SETCUEBANNER             = $1501; 
  EM_GETCUEBANNER             = $1502; 
// n'oubliez pas de déposer un TXPManifest sur la fiche 
procedure TForm1.FormShow(Sender: TObject); 
var 
  Value: WideString; 
begin 
  Value := 'Entrez votre Texte ici'; 
  SendMessage(Edit1.Handle, EM_SETCUEBANNER, 1, LPARAM(Value)); 
end; 
{ ================================================================== }

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
unit crCueBanner; 
 
interface 
uses Windows 
     {$if CompilerVersion < 20.00} 
       // à partir de D2009 vous devez activer les styles dans les options du projet 
     , XPMan 
     {$else} 
       // à partir de D2009 les fonctions "Edit_SetCueBannerText" & "Edit_GetCueBannerText" 
       // existent déjà. Nous les utiliserons par redirection. 
     , CommCtrl 
     {$ifend}; 
 
// https://msdn.microsoft.com/fr-fr/library/windows/desktop/bb761703(v=vs.85).aspx 
// fonction oubliée par Delphi permettant le choix ShowOnFocus: Boolean 
// qui permet ou non de voir le Cue Banner Text quand l'edit a le focus 
// active pour toutes les versions de Delphi 
function Edit_SetCueBannerTextFocused(hwnd: HWND; CueText: PWideChar; DrawFocused: Boolean = True): BOOL;{$if CompilerVersion >= 20.00} inline; {$ifend} 
 
 
{$if CompilerVersion < 20.00} 
//avant D2009 nous devons les déclarer et les implémenter 
function Edit_SetCueBannerText(hwnd: HWND; CueText: PWideChar): BOOL; 
function Edit_GetCueBannerText(hwnd: HWND; CueText: PWideChar; BufLen: Longint): BOOL; 
{$else} 
// comme elles existent depuis D2009 
type 
TEdit_SetCueBannerText = function (hwnd: HWND; CueText: PWideChar): BOOL; 
TEdit_GetCueBannerText = function (hwnd: HWND; CueText: PWideChar; BufLen: Longint): BOOL; 
 
// on va les utiliser 
var 
Edit_SetCueBannerText: TEdit_SetCueBannerText; 
Edit_GetCueBannerText: TEdit_GetCueBannerText; 
{$ifend} 
 
implementation 
const 
  EM_SETCUEBANNER             = $1501; 
  EM_GETCUEBANNER             = $1502; 
 
function Edit_SetCueBannerTextFocused(hwnd: HWND; CueText: PWideChar; DrawFocused: Boolean = True): BOOL;{$if CompilerVersion >= 20.00} inline; {$ifend} 
begin 
  Result := BOOL(SendMessage(hwnd, EM_SETCUEBANNER, wParam(DrawFocused), lParam(CueText))); 
end; 
{$if CompilerVersion < 20.00} 
function Edit_SetCueBannerText(hwnd: HWND; CueText: PWideChar): BOOL; 
begin 
  Result := BOOL(SendMessage(hwnd, EM_SETCUEBANNER, wParam(False), lParam(CueText))); 
end; 
 
function Edit_GetCueBannerText(hwnd: HWND; CueText: PWideChar; BufLen: Longint): BOOL; 
begin 
  Result := BOOL(SendMessage(hwnd, EM_GETCUEBANNER, wParam(CueText), lParam(BufLen))); 
end; 
{$else} 
initialization 
// redirige les fonctions existantes 
Edit_SetCueBannerText := @CommCtrl.Edit_SetCueBannerText; 
Edit_GetCueBannerText := @CommCtrl.Edit_GetCueBannerText; 
 
{$ifend} 
 
end.

1
2
3
4
5
6
7
{ ================================================================== } 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Edit_SetCueBannerText(Edit1.Handle, 'Entrez votre Texte ici'); 
  Edit_SetCueBannerText(Edit2.Handle, 'Votre nom'); 
end; 
{ ================================================================== }

1
2
3
4
5
6
7
8
9
{ ================================================================== } 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  aCueTxt: array[0..255] of WideChar; 
begin 
  if Edit_GetCueBannerText(Edit1.Handle, aCueTxt, 256) then 
    ShowMessage(aCueTxt); 
end; 
{ ================================================================== }

1
2
3
4
5
6
7
{ ================================================================== } 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Edit_SetCueBannerTextFocused(Edit1.Handle, 'Entrez votre Texte ici'); 
  Edit_SetCueBannerTextFocused(Edit2.Handle, 'Votre nom'); 
end; 
{ ================================================================== }