Capture d'écran composant

**XeGregory** · 25/02/2025, 06h58

Bonjour à tous,

Peut-on capturer l'intégralité du composant en prenant en considération la scrollbar verticale ?

Dans cette configuration, je ne capture que la partie visible de la TListBox.

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
procedure TForm1.CaptureClick(Sender: TObject);
var
  _HDC: HDC;
  _Rect: TRect;
  _Canvas: TCanvas;
  _Bitmap: TBitmap;
begin
  Image.Picture := nil;
 
  _HDC := GetWindowDC(ListBox.Handle);
 
  _Bitmap := TBitmap.Create;
  _Canvas := TCanvas.Create;
  _Canvas.Handle := _HDC;
 
  _Bitmap.Width := ListBox.Width;
  _Bitmap.Height := ListBox.Height;
 
  _Rect := Rect(0, 0, _Bitmap.Width, _Bitmap.Height);
  _Bitmap.Canvas.CopyRect(_Rect, _Canvas, _Rect);
 
  Image.Picture.Bitmap.Assign(_Bitmap);
 
  ReleaseDC(_Canvas.Handle, _HDC);
  FreeAndNil(_Bitmap);
  FreeAndNil(_Canvas);
end;

Nom : Capture d'écran 2025-02-25 065754.png
Affichages : 118
Taille : 13,4 Ko

Merci

**Lung** · 25/02/2025, 08h05

Peut-être une piste :
https://www.developpez.net/forums/d1...cran-d-grille/

**ShaiLeTroll** · 25/02/2025, 09h14

Voir aussi : Impression d'un composant grille : TStringGrid,TDbGrid… c'est vieillissant avec QuickReport mais faudrait voire comme reproduire cela avec RaveReport, FastReport ou je ne sais plus le quel c'est désormais.
C'est un peu ce que le fonctionnement de ce que mes prédécesseurs ont développés dans outil que je maintiens avec TClientDataSet et FastReport, entièrement dynamique pour imprimer n'importe quelle "grille"

un sujet comme Ici

La Recherche propose ceci

En FMX, j'aurais évoqué TControl.MakeScreenshot mais cela ne doit encore une fois que recopie le Clip Rect Visible

Quel est le but réel ?

**ALWEBER** · 25/02/2025, 10h10

Hello. Est ce que tu as testé avec la fonction BitBLT ?

**ShaiLeTroll** · 25/02/2025, 12h20

Pour commencer, on peut écarter PaintTo, recopie la partie cliente uniquement, sans la scrollBar
Sauf si finalement, cela va, d'ailleurs, la prochaine version dans la réponse suivant sera avec un PaintTo...

Avant de faire plus compliqué, autant regarder CopyRect directement depuis le Canvas de la TListBox, amusant, il manque un pixel en haut et sur le côté
Cependant, en jouant sur ckbCaptureSizeStrict, on voit que l'on capture ce qu'il y a autour et pas seulement la TListBoxCopyRect n'étant pas terrible, reprise du GetWindowDC, j'ai remis en forme pour utiliser un Canvas cible, juste corrigé le ReleaseDC.
D'ailleurs, je propose une version simplifié sans Bitmap mais directement un Canvas

Dans le code de XeGregory, forcément cela provoque " je ne capture que la partie visible de la TListBox." puisque c'est ce qui est exclusivement demandé

Code :

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

1
2
  _Bitmap.Width := ListBox.Width;
  _Bitmap.Height := ListBox.Height;

Pour le moment, cela déborde hors de la TListBox mais on devine que l'on peut tricher ... même si l'on sera limité

Nom : Sans titre.png
Affichages : 89
Taille : 69,7 Ko

Nom : Sans titre.png
Affichages : 89
Taille : 69,7 Ko

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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
unit Unit1;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;
 
type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    btnFill: TButton;
    edFillCount: TEdit;
    PaintBox1: TPaintBox;
    rgrpCaptureMode: TRadioGroup;
    ckbCaptureSizeStrict: TCheckBox;
    procedure btnFillClick(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure rgrpCaptureModeClick(Sender: TObject);
  private
    { Déclarations privées }
  public
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.btnFillClick(Sender: TObject);
var
  I: Integer;
begin
  ListBox1.Items.BeginUpdate();
  try
    for I := 0 to StrToInt(edFillCount.Text) do
      ListBox1.Items.Add(I.ToString());
  finally
    ListBox1.Items.EndUpdate();
  end;
end;
 
procedure TForm1.PaintBox1Paint(Sender: TObject);
 
  procedure CaptureByCopyRect(AListBox: TListBox; ACanvas: TCanvas; AWidth, AHeight: Integer);
  var
    VRect: TRect;
  begin
    VRect := Rect(0, 0, AWidth, AHeight);
    ACanvas.CopyRect(VRect, AListBox.Canvas, VRect);
  end;
 
  procedure CaptureByWindowDC(AListBox: TListBox; ACanvas: TCanvas; AWidth, AHeight: Integer);
  var
    SourceHDC: HDC;
    VRect: TRect;
    SourceCanvas: TCanvas;
    DestBitmap: TBitmap;
  begin
    SourceHDC := GetWindowDC(AListBox.Handle);
    try
      SourceCanvas := TCanvas.Create;
      try
        SourceCanvas.Handle := SourceHDC;
 
        DestBitmap := TBitmap.Create;
        try
          DestBitmap.Width := AWidth;
          DestBitmap.Height := AHeight;
 
          VRect := Rect(0, 0, AWidth, AHeight);
          DestBitmap.Canvas.CopyRect(VRect, SourceCanvas, VRect);
 
          ACanvas.Draw(0, 0, DestBitmap);
        finally
          FreeAndNil(DestBitmap);
        end;
      finally
        FreeAndNil(SourceCanvas);
      end;
    finally
      ReleaseDC(AListBox.Handle, SourceHDC);
    end;
  end;
 
  procedure CaptureByWindowDCSimplify(AListBox: TListBox; ACanvas: TCanvas; AWidth, AHeight: Integer);
  var
    SourceHDC: HDC;
    VRect: TRect;
    SourceCanvas: TCanvas;
    DestBitmap: TBitmap;
  begin
    SourceHDC := GetWindowDC(AListBox.Handle);
    try
      SourceCanvas := TCanvas.Create;
      try
        SourceCanvas.Handle := SourceHDC;
 
        VRect := Rect(0, 0, AWidth, AHeight);
        ACanvas.CopyRect(VRect, SourceCanvas, VRect);
      finally
        FreeAndNil(SourceCanvas);
      end;
    finally
      ReleaseDC(AListBox.Handle, SourceHDC);
    end;
  end;
 
 
var
  LWidth, LHeight: Integer;
begin
  if ckbCaptureSizeStrict.Checked then
  begin
    LWidth := ListBox1.Width;
    LHeight := ListBox1.Height;
  end
  else
  begin
    LWidth := PaintBox1.Width;
    LHeight := PaintBox1.Height;
  end;
 
  case rgrpCaptureMode.ItemIndex of
    0: ListBox1.PaintTo(PaintBox1.Canvas, 0, 0);
    1: CaptureByCopyRect(ListBox1, PaintBox1.Canvas, LWidth, LHeight);
    2: CaptureByWindowDC(ListBox1, PaintBox1.Canvas, LWidth, LHeight);
    3: CaptureByWindowDCSimplify(ListBox1, PaintBox1.Canvas, LWidth, LHeight);
  end;
end;
 
procedure TForm1.rgrpCaptureModeClick(Sender: TObject);
begin
  PaintBox1.Invalidate();
end;
 
end.

Code dfm :

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
object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 655
  ClientWidth = 635
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  DesignSize = (
    635
    655)
  PixelsPerInch = 96
  TextHeight = 13
  object PaintBox1: TPaintBox
    Left = 183
    Top = 40
    Width = 444
    Height = 607
    Anchors = [akLeft, akTop, akRight, akBottom]
    OnPaint = PaintBox1Paint
  end
  object ListBox1: TListBox
    Left = 8
    Top = 40
    Width = 169
    Height = 209
    ItemHeight = 13
    TabOrder = 0
  end
  object btnFill: TButton
    Left = 8
    Top = 8
    Width = 75
    Height = 25
    Caption = 'Remplir'
    TabOrder = 1
    OnClick = btnFillClick
  end
  object edFillCount: TEdit
    Left = 89
    Top = 8
    Width = 88
    Height = 21
    NumbersOnly = True
    TabOrder = 2
    Text = '1000'
  end
  object rgrpCaptureMode: TRadioGroup
    Left = 8
    Top = 255
    Width = 169
    Height = 98
    Caption = 'Capture'
    Items.Strings = (
      'Simple'
      'Copy Rect'
      'Contexte'
      'Contexte simplifi'#233
      'Etendu')
    TabOrder = 3
    OnClick = rgrpCaptureModeClick
  end
  object ckbCaptureSizeStrict: TCheckBox
    Left = 8
    Top = 383
    Width = 137
    Height = 17
    Caption = 'Capture Size Strict'
    TabOrder = 4
  end
end

**ShaiLeTroll** · 25/02/2025, 12h48

Comme prévu, la mouture avec tricherie mais c'est TRES moche !

Pour le moment, cela affiche au maximum de la taille de la cible, le Canvas de la TPaintBox

Si c'est pour l'imprimer faudra gérer les ruptures de page ... autant directement codé l'impression avec DrawText que cette bidouille, en plus faudra gérer la différence de DPI en calculant le meilleur ratio qui fera le Strech tout en conservant les propotions

Si c'est pour faire une image, faudra juste changer AListBox.Height := AHeight; en un truc AListBox.Height := AListBox.Items.Count * AListBox.ItemHeight + 8 ...

Nom : Sans titre.png
Affichages : 88
Taille : 79,8 Ko

Nom : Sans titre.png
Affichages : 88
Taille : 79,8 Ko

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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
unit Unit1;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;
 
type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    btnFill: TButton;
    edFillCount: TEdit;
    PaintBox1: TPaintBox;
    rgrpCaptureMode: TRadioGroup;
    ckbCaptureSizeStrict: TCheckBox;
    procedure btnFillClick(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure rgrpCaptureModeClick(Sender: TObject);
    procedure ckbCaptureSizeStrictClick(Sender: TObject);
  private
    { Déclarations privées }
  public
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.btnFillClick(Sender: TObject);
var
  I: Integer;
begin
  ListBox1.Items.BeginUpdate();
  try
    for I := 0 to StrToInt(edFillCount.Text) do
      ListBox1.Items.Add(I.ToString());
  finally
    ListBox1.Items.EndUpdate();
  end;
end;
 
procedure TForm1.PaintBox1Paint(Sender: TObject);
 
  procedure CaptureByCopyRect(AListBox: TListBox; ACanvas: TCanvas; AWidth, AHeight: Integer);
  var
    VRect: TRect;
  begin
    VRect := Rect(0, 0, AWidth, AHeight);
    ACanvas.CopyRect(VRect, AListBox.Canvas, VRect);
  end;
 
  procedure CaptureByWindowDC(AListBox: TListBox; ACanvas: TCanvas; AWidth, AHeight: Integer);
  var
    SourceHDC: HDC;
    VRect: TRect;
    SourceCanvas: TCanvas;
    DestBitmap: TBitmap;
  begin
    SourceHDC := GetWindowDC(AListBox.Handle);
    try
      SourceCanvas := TCanvas.Create;
      try
        SourceCanvas.Handle := SourceHDC;
 
        DestBitmap := TBitmap.Create;
        try
          DestBitmap.Width := AWidth;
          DestBitmap.Height := AHeight;
 
          VRect := Rect(0, 0, AWidth, AHeight);
          DestBitmap.Canvas.CopyRect(VRect, SourceCanvas, VRect);
 
          ACanvas.Draw(0, 0, DestBitmap);
        finally
          FreeAndNil(DestBitmap);
        end;
      finally
        FreeAndNil(SourceCanvas);
      end;
    finally
      ReleaseDC(AListBox.Handle, SourceHDC);
    end;
  end;
 
  procedure CaptureByWindowDCSimplify(AListBox: TListBox; ACanvas: TCanvas; AWidth, AHeight: Integer);
  var
    SourceHDC: HDC;
    VRect: TRect;
    SourceCanvas: TCanvas;
  begin
    SourceHDC := GetWindowDC(AListBox.Handle);
    try
      SourceCanvas := TCanvas.Create;
      try
        SourceCanvas.Handle := SourceHDC;
 
        VRect := Rect(0, 0, AWidth, AHeight);
        ACanvas.CopyRect(VRect, SourceCanvas, VRect);
      finally
        FreeAndNil(SourceCanvas);
      end;
    finally
      ReleaseDC(AListBox.Handle, SourceHDC);
    end;
  end;
 
  procedure CaptureByFormAndPaintTo(AListBox: TListBox; ACanvas: TCanvas; AWidth, AHeight: Integer);
  var
    VForm: TForm;
    VParent: TWinControl;
    VBoundsRect: TRect;
    VRect: TRect;
  begin
    VForm := TForm.Create(nil);
    try
      //VForm.Position := poDesigned;
      //VForm.Left := Screen.Width;
      VForm.AutoSize := True;
      VForm.BorderStyle := bsNone;
 
      VParent := AListBox.Parent;
      VBoundsRect := AListBox.BoundsRect;
      try
        AListBox.Parent := VForm;
        VForm.Show();
        AListBox.Height := AHeight;
        VForm.Refresh();
 
        AListBox.PaintTo(ACanvas, 0, 0);
 
      finally
        AListBox.Parent := VParent;
        AListBox.SetBounds(VBoundsRect.Left, VBoundsRect.Top, VBoundsRect.Width, VBoundsRect.Height);
      end;
    finally
      VForm.Free();
    end;
  end;
 
  procedure CaptureByFormAndByWindowDCSimplify(AListBox: TListBox; ACanvas: TCanvas; AWidth, AHeight: Integer);
  var
    VForm: TForm;
    VParent: TWinControl;
    VBoundsRect: TRect;
    VRect: TRect;
  begin
    VForm := TForm.Create(nil);
    try
      //VForm.Position := poDesigned;
      //VForm.Left := Screen.Width;
      VForm.AutoSize := True;
      VForm.BorderStyle := bsNone;
 
      VParent := AListBox.Parent;
      VBoundsRect := AListBox.BoundsRect;
      try
        AListBox.Parent := VForm;
        VForm.Show();
        AListBox.Height := AHeight;
        VForm.Refresh();
 
        CaptureByWindowDCSimplify(AListBox, ACanvas, AWidth, AHeight);
 
      finally
        AListBox.Parent := VParent;
        AListBox.SetBounds(VBoundsRect.Left, VBoundsRect.Top, VBoundsRect.Width, VBoundsRect.Height);
      end;
    finally
      VForm.Free();
    end;
  end;
 
 
var
  LWidth, LHeight: Integer;
begin
  if ckbCaptureSizeStrict.Checked then
  begin
    LWidth := ListBox1.Width;
    LHeight := ListBox1.Height;
  end
  else
  begin
    LWidth := PaintBox1.Width;
    LHeight := PaintBox1.Height;
  end;
 
  case rgrpCaptureMode.ItemIndex of
    0: ListBox1.PaintTo(PaintBox1.Canvas, 0, 0);
    1: CaptureByCopyRect(ListBox1, PaintBox1.Canvas, LWidth, LHeight);
    2: CaptureByWindowDC(ListBox1, PaintBox1.Canvas, LWidth, LHeight);
    3: CaptureByWindowDCSimplify(ListBox1, PaintBox1.Canvas, LWidth, LHeight);
    4: CaptureByFormAndPaintTo(ListBox1, PaintBox1.Canvas, LWidth, LHeight);
    5: CaptureByFormAndByWindowDCSimplify(ListBox1, PaintBox1.Canvas, LWidth, LHeight);
  end;
end;
 
procedure TForm1.rgrpCaptureModeClick(Sender: TObject);
begin
  PaintBox1.Invalidate();
end;
 
procedure TForm1.ckbCaptureSizeStrictClick(Sender: TObject);
begin
  PaintBox1.Invalidate();
end;
 
 
end.

Code dfm :

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
 
object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 655
  ClientWidth = 635
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  DesignSize = (
    635
    655)
  PixelsPerInch = 96
  TextHeight = 13
  object PaintBox1: TPaintBox
    Left = 183
    Top = 40
    Width = 444
    Height = 607
    Anchors = [akLeft, akTop, akRight, akBottom]
    OnPaint = PaintBox1Paint
  end
  object ListBox1: TListBox
    Left = 8
    Top = 40
    Width = 169
    Height = 209
    ItemHeight = 13
    TabOrder = 0
  end
  object btnFill: TButton
    Left = 8
    Top = 8
    Width = 75
    Height = 25
    Caption = 'Remplir'
    TabOrder = 1
    OnClick = btnFillClick
  end
  object edFillCount: TEdit
    Left = 89
    Top = 8
    Width = 88
    Height = 21
    NumbersOnly = True
    TabOrder = 2
    Text = '1000'
  end
  object rgrpCaptureMode: TRadioGroup
    Left = 8
    Top = 255
    Width = 169
    Height = 130
    Caption = 'Capture'
    Items.Strings = (
      'Simple'
      'Copy Rect'
      'Contexte'
      'Contexte simplifi'#233
      'Simple Etendu '
      'Contexte simplifi'#233' Etendu ')
    TabOrder = 3
    OnClick = rgrpCaptureModeClick
  end
  object ckbCaptureSizeStrict: TCheckBox
    Left = 8
    Top = 391
    Width = 137
    Height = 17
    Caption = 'Capture Size Strict'
    TabOrder = 4
    OnClick = ckbCaptureSizeStrictClick
  end
end

**ShaiLeTroll** · 25/02/2025, 13h01

Version à l'arrache vers un fichier BMP, il fera 8,39 Mio pour 1000 éléments
Et sans surprise, la limite sera de 65535 pixels soit 5041 éléments pour 42,2 Mio

ListBox.zip

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
procedure TForm1.btnSaveToFileClick(Sender: TObject);
var
  VBitmap: TBitmap;
  VBoundsRect: TRect;
begin
  VBitmap := TBitmap.Create();
  try
    VBoundsRect := ListBox1.BoundsRect;
    try
      ListBox1.Height := ListBox1.Items.Count * ListBox1.ItemHeight + 8;
      VBitmap.Height := ListBox1.Height;
      VBitmap.Width := ListBox1.Width;
 
      ListBox1.PaintTo(VBitmap.Canvas, 0, 0);
      VBitmap.SaveToFile('ListBox1.BMP');
 
    finally
      ListBox1.SetBounds(VBoundsRect.Left, VBoundsRect.Top, VBoundsRect.Width, VBoundsRect.Height);
    end;
  finally
    VBitmap.Free();
  end;
end;

**XeGregory** · 26/02/2025, 07h48

Bonjour ShaiLeTroll & Merci

,

L'objectif était de pouvoir capturer, dans une image, la totalité d'une listbox, Donc 20 Items exactement.

Nom : Capture d'écran 2025-02-26 051054.png
Affichages : 73
Taille : 83,0 Ko

Nom : Capture d'écran 2025-02-26 051054.png
Affichages : 73
Taille : 83,0 Ko

J'avais deux choix : Capturer la liste complète ou la redessiner dans un bitmap Item par Item visa Bitmap.Canvas.TextOut

Après avoir pesé le pour et le contre, redessiner la liste serait beaucoup plus judicieux, Créer une Card avec toutes les informations de la liste.

Capture d'écran composant

Delphi

Vue hybride

Discussions similaires

Partager

Partager