屏幕截图

最新推荐文章于 2024-05-07 21:45:53 发布

转载最新推荐文章于 2024-05-07 21:45:53 发布 · 72 阅读

屏幕截图

1）单元文件

/// <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）窗体文件

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