屏幕截图

屏幕截图

1）单元文件

?
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
215
216
217
218
219
220
221
222
223
224
225
226
/// <author>cxg 2018-10-25</author>
/// 屏幕截图
 
{
procedure TForm1.Button1Click(Sender: TObject);
begin
  try
    CatchScreenShowForm := TCatchScreenShowForm.Create(Self);
    CatchScreenShowForm.ChildTimer.Enabled := True;
    if CatchScreenShowForm.ShowModal = mrok then
    begin
      Image1.Picture.Bitmap:=CatchScreenShowForm.NewBitmap;
    end;
  finally
    CatchScreenShowForm.Free;
  end;
end;
}
 
unit UCatchScreenShow;
 
interface
 
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, Clipbrd, StdCtrls, Buttons, jpeg;
 
type
  TCatchScreenShowForm = class(TForm)
    ChildImage: TImage;
    ChildTimer: TTimer;
    RzPanel1: TPanel;
    dlgSave1: TSaveDialog;
    lbl1: TLabel;
    btn_ok: TBitBtn;
    btn_close: TBitBtn;
    btn_save: TBitBtn;
    procedure ChildTimerTimer(Sender: TObject);
    procedure ChildImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure ChildImageMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure ChildImageDblClick(Sender: TObject);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure FormCreate(Sender: TObject);
    procedure btn_closeClick(Sender: TObject);
    procedure btn_okClick(Sender: TObject);
    procedure btn_saveClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    NewBitmap: TBitmap;
  end;
 
var
  ScreenCapture: TCatchScreenShowForm;
  foldx, x1, y1, x2, y2, oldx, oldy, foldy: Integer;
  Flag, Trace: Boolean;
 
implementation
 
{$R *.DFM}
 
procedure TCatchScreenShowForm.ChildTimerTimer(Sender: TObject);
var
  Fullscreen: Tbitmap;
  FullscreenCanvas: TCanvas;
  DC: HDC;
begin
  lbl1.Visible := False;
  ChildTimer.Enabled := False;
  Fullscreen := TBitmap.Create;
  Fullscreen.Width := Screen.width;
  Fullscreen.Height := Screen.Height;
  DC := GetDC(0);
  FullscreenCanvas := TCanvas.Create;
  FullscreenCanvas.Handle := DC;
  Fullscreen.Canvas.CopyRect(Rect(0, 0, Screen.Width, Screen.Height), FullscreenCanvas, Rect(0, 0, Screen.Width, Screen.Height));
  FullscreenCanvas.Free;
  ReleaseDC(0, DC);
  ChildImage.picture.Bitmap := Fullscreen;
  ChildImage.Width := Fullscreen.Width;
  ChildImage.Height := Fullscreen.Height;
  Fullscreen.free;
  ScreenCapture.WindowState := wsMaximized;
  ScreenCapture.show;
  messagebeep(1);
  foldx := -1;
  foldy := -1;
  ChildImage.Canvas.Pen.mode := Pmnot; //笔的模式为取反
  ChildImage.Canvas.pen.color := clblack; //笔为黑色
  ChildImage.Canvas.brush.Style := bsclear; //空白刷子
  Flag := True;
end;
 
procedure TCatchScreenShowForm.ChildImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if trace = true then//是否在追踪鼠标？
  begin//是，擦除旧的矩形并画上新的矩形
    with ChildImage.canvas do
    begin
      rectangle(x1, y1, oldx, oldy);
      Rectangle(x1, y1, X, Y);
      oldx := X;
      oldy := Y;
    end;
  end
  else if flag = true then//在鼠标所在的位置上画十字
  begin
    with ChildImage.canvas do
    begin
      MoveTo(foldx, 0); //擦除旧的十字
      LineTo(foldx, Screen.Height);
      MoveTo(0, foldy);
      LineTo(Screen.Width, foldy);
      MoveTo(X, 0); //画上新的十字
      LineTo(X, Screen.Height);
      MoveTo(0, Y);
      LineTo(Screen.Width, Y);
      foldx := X;
      foldy := Y;
    end;
  end;
end;
 
procedure TCatchScreenShowForm.ChildImageMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  Width, Height: Integer;
begin
  RzPanel1.Visible := False;
  AlphaBlend := True;
  if (Trace = False) then//TRACE表示是否在追踪鼠标
  begin//首次点击鼠标左键，开始追踪鼠标。
    Flag := False;
    with ChildImage.canvas do
    begin
      MoveTo(foldx, 0);
      LineTo(foldx, screen.height);
      MoveTo(0, foldy);
      LineTo(screen.width, foldy);
    end;
    x1 := X;
    y1 := Y;
    oldx := X;
    oldy := Y;
    Trace := True;
    ChildImage.Canvas.Pen.mode := pmnot; //笔的模式为取反
    //这样再在原处画一遍矩形，相当于擦除矩形。
    ChildImage.canvas.pen.color := clblack; //笔为黑色
    ChildImage.canvas.brush.Style := bsclear; //空白刷子
  end
  else
  begin//第二次点击，表示已经得到矩形了，把它拷贝到FORM1中的IMAGE部件上。
    x2 := X;
    y2 := Y;
    Trace := False;
    ChildImage.Canvas.Rectangle(x1, y1, oldx, oldy);
    Width := abs(x2 - x1);
    Height := abs(y2 - y1);
    NewBitmap := Tbitmap.create;
    NewBitmap.Width := Width;
    NewBitmap.Height := Height;
    NewBitmap.Canvas.CopyRect(Rect(0, 0, Width, Height), ScreenCapture.ChildImage.Canvas, Rect(x1, y1, x2, y2));
    AlphaBlend := False;
    RzPanel1.Visible := True;
    RzPanel1.Left := X - RzPanel1.Width;
    RzPanel1.top := Y - RzPanel1.Height;
  end;
end;
 
procedure TCatchScreenShowForm.ChildImageDblClick(Sender: TObject);
begin
  if NewBitmap = nil then
  begin
    ShowMessage('你没有截图！请Esc键退出');
    Exit;
  end;
  btn_close.Click;
end;
 
procedure TCatchScreenShowForm.FormKeyPress(Sender: TObject; var Key: Char);
begin
  if Key = #27 then
    Close;
end;
 
procedure TCatchScreenShowForm.FormCreate(Sender: TObject);
begin
  tag := 0;
end;
 
procedure TCatchScreenShowForm.btn_closeClick(Sender: TObject);
begin
  try
    NewBitmap.Free;
  except
 
  end;
 
  ModalResult := mrCancel;
end;
 
procedure TCatchScreenShowForm.btn_okClick(Sender: TObject);
begin
  ModalResult := mrOk;
end;
 
procedure TCatchScreenShowForm.btn_saveClick(Sender: TObject);
var
  jpg: TJPEGImage;
begin
  jpg := nil;
  dlgSave1.Filter := '*.jpg|*.jpg';
  if dlgSave1.Execute then
  begin
    try
      jpg := TJPEGImage.Create;
      jpg.Assign(NewBitmap);
      jpg.SaveToFile(dlgSave1.FileName + '.jpg');
      Close;
    finally
      jpg.Free;
    end;
  end;
end;
 
end.

　2）窗体文件

?
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
object CatchScreenShowForm: TCatchScreenShowForm
  Left = 409
  Top = 143
  AlphaBlend = True
  BorderStyle = bsNone
  Caption = #21306#22495#25235#22270#31383#21475
  ClientHeight = 45
  ClientWidth = 122
  Color = clBtnFace
  Font.Charset = GB2312_CHARSET
  Font.Color = clWindowText
  Font.Height = -12
  Font.Name = #23435#20307
  Font.Style = []
  KeyPreview = True
  OldCreateOrder = False
  OnCreate = FormCreate
  OnKeyPress = FormKeyPress
  PixelsPerInch = 96
  TextHeight = 12
  object ChildImage: TImage
    Left = 0
    Top = 0
    Width = 122
    Height = 45
    Align = alClient
    OnDblClick = ChildImageDblClick
    OnMouseDown = ChildImageMouseDown
    OnMouseMove = ChildImageMouseMove
    ExplicitWidth = 180
    ExplicitHeight = 153
  end
  object lbl1: TLabel
    Left = 16
    Top = 8
    Width = 66
    Height = 12
    Caption = #25353'Esc'#38190#21462#28040
  end
  object RzPanel1: TPanel
    Left = 136
    Top = 26
    Width = 130
    Height = 26
    BevelOuter = bvNone
    Ctl3D = False
    ParentCtl3D = False
    TabOrder = 0
    Visible = False
    object btn_ok: TBitBtn
      Left = 104
      Top = 0
      Width = 26
      Height = 26
      Align = alRight
      Caption = #23436#25104
      Font.Charset = GB2312_CHARSET
      Font.Color = clWindowText
      Font.Height = -12
      Font.Name = #23435#20307
      Font.Style = []
      ParentFont = False
      TabOrder = 0
      OnClick = btn_okClick
    end
    object btn_close: TBitBtn
      Left = 78
      Top = 0
      Width = 26
      Height = 26
      Align = alRight
      Caption = #36864#20986
      Font.Charset = GB2312_CHARSET
      Font.Color = clWindowText
      Font.Height = -12
      Font.Name = #23435#20307
      Font.Style = []
      ParentFont = False
      TabOrder = 1
      OnClick = btn_closeClick
    end
    object btn_save: TBitBtn
      Left = 52
      Top = 0
      Width = 26
      Height = 26
      Align = alRight
      Caption = #20445#23384
      Font.Charset = GB2312_CHARSET
      Font.Color = clWindowText
      Font.Height = -12
      Font.Name = #23435#20307
      Font.Style = []
      ParentFont = False
      TabOrder = 2
      OnClick = btn_saveClick
    end
  end
  object ChildTimer: TTimer
    Enabled = False
    Interval = 500
    OnTimer = ChildTimerTimer
    Left = 80
    Top = 16
  end
  object dlgSave1: TSaveDialog
    Left = 48
    Top = 16
  end
end

　　

posted @   delphi中间件  阅读(671)  评论(0)  编辑  收藏  举报
编辑推荐：
· AI与.NET技术实操系列（二）：开始使用ML.NET
· 记一次.NET内存居高不下排查解决与启示
· 探究高空视频全景AR技术的实现原理
· 理解Rust引用及其生命周期标识（上）
· 浏览器原生「磁吸」效果！Anchor Positioning 锚点定位神器解析
阅读排行：
· DeepSeek 开源周回顾「GitHub 热点速览」
· 物流快递公司核心技术能力-地址解析分单基础技术分享
· .NET 10首个预览版发布：重大改进与新特性概览！
· AI与.NET技术实操系列（二）：开始使用ML.NET
· 单线程的Redis速度为什么快？
点击右上角即可分享
微信分享提示
AI FOR CODE 大赛