unit1.pas

delphi 编写的屏幕抓图软件 可以进行处理保存

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, ShellApi, ExtCtrls, ToolWin, Menus, ImgList, jpeg;

const
  WM_TRAYNOTIFY = WM_USER + 400;

type
  TForm1 = class(TForm)
    ToolBar1: TToolBar;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    ToolButton4: TToolButton;
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    N5: TMenuItem;
    ToolButton3: TToolButton;
    ToolButton5: TToolButton;
    ToolButton6: TToolButton;
    ToolButton7: TToolButton;
    ImageList1: TImageList;
    ScrollBox1: TScrollBox;
    Image1: TImage;
    N8: TMenuItem;
    N6: TMenuItem;
    N9: TMenuItem;
    ToolButton10: TToolButton;
    procedure ToolButton1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure N3Click(Sender: TObject);
    procedure N4Click(Sender: TObject);
    procedure ToolButton2Click(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure ToolButton4Click(Sender: TObject);
    procedure ToolButton5Click(Sender: TObject);
    procedure BMP1Click(Sender: TObject);
    procedure N9Click(Sender: TObject);
    procedure N5Click(Sender: TObject);
    procedure ToolButton10Click(Sender: TObject);
    procedure N6Click(Sender: TObject);
    procedure ToolButton7Click(Sender: TObject);
    procedure FormHide(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    procedure WMHotKey(var Msg: TWMHOTKEY); message WM_HOTKEY;
    procedure WMSysCommand(var msg: TMessage); message WM_SYSCOMMAND;
    procedure TrayEvent(var Msg: TMessage); message WM_TRAYNOTIFY;
  public
    { Public declarations }
    ScreenPic: TBitMap;
    procedure InstallTrayIcon;
    procedure DeleteTrayIcon;
    procedure SnagScreen(var BitMap: TBitMap);
  end;

var
  Form1: TForm1;
  ND: TNotifyIconData; //托盘图标
  IconInstalled: Boolean = False;
implementation
uses Unit2;
{$R *.dfm}


procedure TForm1.FormCreate(Sender: TObject);
begin
  ScreenPic := TBitMap.Create;
  //注册系统热键
  if not RegisterHotKey(Handle, GlobalAddAtom('ActiveHotKey'), mod_alt, vk_F1)
    then Showmessage('注册系统热键失败');
  if not RegisterHotKey(Handle, GlobalAddAtom('FullScreenHotKey'), mod_alt, vk_F2)
    then Showmessage('注册系统热键失败');
  if not RegisterHotKey(Handle, GlobalAddAtom('RectHotKey'), mod_alt, vk_F3)
    then Showmessage('注册系统热键失败');
end;


procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ScreenPic.Free;
  //删除注册的系统热键
  UnregisterHotKey(Handle, GlobalAddAtom('ActiveHotKey'));
  UnregisterHotKey(Handle, GlobalAddAtom('FullScreenHotKey'));
  UnregisterHotKey(Handle, GlobalAddAtom('RectHotKey'));
end;

//任意区域

procedure TForm1.ToolButton1Click(Sender: TObject);
begin
  //隐藏form1
  Form1.Hide;

  sleep(100);

  //作个假桌面 ^_^

  SnagScreen(ScreenPic);

  Form2.Image1.Picture.Bitmap := ScreenPic;

  Form2.Drag := False;

  with Form2 do
  begin
    BorderStyle := bsNone;
    Height := screen.height;
    Width := screen.width;
    Position := poScreenCenter;
    FormStyle := fsStayOnTop;
    Visible := True;
  end;

end;

//全屏

procedure TForm1.ToolButton2Click(Sender: TObject);
begin
  Form1.Hide;

  sleep(100);

  SnagScreen(ScreenPic);

  Image1.Width := ScreenPic.Width;
  Image1.Height := ScreenPic.Height;

  Form1.Image1.Picture.Bitmap := ScreenPic;

  Form1.WindowState := wsMaximized; //复原窗口状态
  Form1.show; //显示窗口
end;

//活动窗体

procedure TForm1.ToolButton4Click(Sender: TObject);
begin
  Hide;
end;

//热键消息

procedure TForm1.WMHotKey(var Msg: TWMHOTKEY);
var
  BitMap: TBitMap;
  h_Wnd: HWND;
  DeRect, ClientRect: TRect;
  DC: HDC;
  XOffset, YOffset: Integer;
begin
  if Msg.HotKey = GlobalAddAtom('ActiveHotKey') then
  begin
    XOffset := 0;
    YOffset := 0;
    h_Wnd := GetForegroundWindow;
    getwindowrect(h_Wnd, DeRect);

    //窗体超出屏幕区域
    if DeRect.Left < 0 then
    begin
      XOffset := -DeRect.Left;
      DeRect.Left := 0;
    end;
    if DeRect.Right > GetSystemMetrics(SM_CXSCREEN)
      then DeRect.Right := GetSystemMetrics(SM_CXSCREEN);
    if DeRect.Top < 0 then
    begin
      YOffset := -DeRect.Top;
      DeRect.Top := 0;
    end;
    if DeRect.Bottom > GetSystemMetrics(SM_CYSCREEN) then
    begin
      SystemParametersInfo(SPI_GETWORKAREA, 0, @ClientRect, 0);
      DeRect.Bottom := ClientRect.Bottom;
    end;
    OffsetRect(DeRect, -DeRect.Left, -DeRect.Top);

    if (DeRect.Right > 0) and (DeRect.Bottom > 0) then
    begin
      Image1.Width := DeRect.right;
      Image1.Height := DeRect.bottom;

      DC := getwindowdc(h_Wnd);

      BitMap := TBitMap.Create;
      with BitMap do
      begin
        width := DeRect.right;
        height := DeRect.bottom;
        BitBlt(canvas.handle, 0, 0, width, height, DC, XOffset, YOffset, SRCCOPY);
      end;
      Image1.Picture.Bitmap.Assign(BitMap);
      BitMap.Free;
    end
    else ShowMessage('扑捉不到活动窗体');

    releasedc(h_Wnd, DC);

    Form1.WindowState := wsNormal; //复原窗口状态
    Form1.show; //显示窗口
  end
  else if Msg.HotKey = GlobalAddAtom('FullScreenHotKey') then
  begin
    ToolButton2Click(nil);
  end
  else if Msg.HotKey = GlobalAddAtom('RectHotKey') then
  begin
    ToolButton1Click(nil);
  end;
end;

procedure TForm1.N3Click(Sender: TObject);
begin
  ToolButton4Click(nil);
end;

procedure TForm1.N4Click(Sender: TObject);
begin
  ToolButton1Click(nil);
end;

procedure TForm1.N2Click(Sender: TObject);
begin
  ToolButton2Click(nil);
end;


procedure TForm1.WMSysCommand(var msg: TMessage);
begin
  if msg.WParam = SC_MINIMIZE then
  begin
    Hide;
  end
  else
    inherited;
end;
//向系统托盘加入图标

procedure TForm1.InstallTrayIcon;
begin
  if IconInstalled then exit;
  //填充NotifyIconData记录型变量nd
  ND.cbSize := sizeof(NotifyIconData);
  ND.Wnd := handle;
  ND.uID := 0;
  ND.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
  ND.uCallbackMessage := WM_TRAYNOTIFY;
  ND.hIcon := Form1.Icon.Handle;
  StrPLCopy(ND.szTip, 'Snag', 63);
  Shell_NotifyIcon(NIM_ADD, @nd);

  IconInstalled := True;
end;

//删除托盘图标

procedure TForm1.DeleteTrayIcon;
begin
  if not IconInstalled then exit;
  Shell_NotifyIcon(NIM_DELETE, @nd);
  IconInstalled := False;
end;

//托盘鼠标消息

procedure TForm1.TrayEvent(var Msg: TMessage);
begin
  case msg.lParam of
    WM_LBUTTONDOWN:
      begin
        Form1.WindowState := wsNormal; //复原窗口状态
        Form1.show; //显示窗口
      end;
  end;
end;

//保存

procedure TForm1.ToolButton5Click(Sender: TObject);
var
  SaveDialog: TSaveDialog;
  Jpg: TJpegImage;
begin
  SaveDialog := TSaveDialog.Create(nil);
  SaveDialog.Filter := 'bmp|*.bmp|jpg|*.jpg';
  if SaveDialog.Execute then
  begin
    case SaveDialog.FilterIndex of
      1: Image1.Picture.SaveToFile(SaveDialog.FileName + '.bmp');
      2: begin
          Jpg := TJpegImage.Create;
          Jpg.Assign(Image1.Picture.Bitmap);
          Jpg.SaveToFile(SaveDialog.FileName + '.jpg');
          Jpg.Free;
        end;
    end;
  end;
  SaveDialog.Free;
end;


procedure TForm1.BMP1Click(Sender: TObject);
begin
  ToolButton5Click(nil);
end;


procedure TForm1.N9Click(Sender: TObject);
begin
  ToolButton10Click(nil);
end;

procedure TForm1.N5Click(Sender: TObject);
begin
  ToolButton5Click(nil);
end;

procedure TForm1.ToolButton10Click(Sender: TObject);
begin
  ShowMessage('Snag v0.1');
end;

procedure TForm1.N6Click(Sender: TObject);
begin
  shellexecute(handle, 'open', '.\help.chm', nil, nil, SW_SHOWMAXIMIZED);
end;

procedure TForm1.ToolButton7Click(Sender: TObject);
begin
  N6Click(nil);
end;

procedure TForm1.SnagScreen(var BitMap: TBitMap);
begin
  BitMap.FreeImage;
  BitMap.Width := GetSystemMetrics(SM_CXSCREEN); {Screen.Width}
  BitMap.Height := GetSystemMetrics(SM_CYSCREEN); {Screen.Height}
  BitBlt(BitMap.Canvas.handle, 0, 0, BitMap.Width, BitMap.Height, GetDc(0), 0, 0, SRCCOPY);
end;

procedure TForm1.FormHide(Sender: TObject);
begin
  if not IconInstalled then InstallTrayIcon;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  if IconInstalled then DeleteTrayIcon;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if IconInstalled then DeleteTrayIcon;
end;

end.