unit1.pas

一个快速截取屏幕数据

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,comobj, ExtCtrls, pngextra,PNGimage,DateUtils;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Memo1: TMemo;
    Button3: TButton;
    Image1: TImage;
    Timer1: TTimer;
    Button4: TButton;
    ListBox1: TListBox;
    Button5: TButton;
    Button6: TButton;
    Timer2: TTimer;
    Label1: TLabel;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    Timer3: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button3Click(Sender: TObject);
    procedure Timer3Timer(Sender: TObject);
    procedure CheckBox2Click(Sender: TObject);
  private
    { Private declarations }
    procedure proSY(fname:string);
    procedure HotKeyDown(var Msg: Tmessage); message WM_HOTKEY;
    procedure captureSCR;
  public
    { Public declarations }
    kk:boolean;
  end;

var
  Form1: TForm1;
  app:Variant;
  kkk:integer;
  ppath:string;

  Fullscreen:Tbitmap;
  FullscreenCanvas:TCanvas;
  dc:HDC;
  PNG: TPNGObject;
  HotKeyId:integer;
  HotKeyId1:integer;
implementation

{$R *.dfm}
function DeletePath(mDirName: string; Ext: String = '*'): Boolean;
var
  vSearchRec: TSearchRec;
  vPathName, tmpExt: string;
  K: Integer;
begin
  Result := true;

  tmpExt := Ext;
  if Pos('.', tmpExt) = 0 then
    tmpExt := '.' + tmpExt;

  vPathName := mDirName + '\*.*';
  K := FindFirst(vPathName, faAnyFile, vSearchRec);
  while K = 0 do
  begin
    if (vSearchRec.Attr and faDirectory > 0) and
      (Pos(vSearchRec.Name, '..') = 0) then
    begin
      FileSetAttr(mDirName + '\' + vSearchRec.Name, faDirectory);
      Result := DeletePath(mDirName + '\' + vSearchRec.Name, Ext);
    end
    else if Pos(vSearchRec.Name, '..') = 0 then
    begin
      FileSetAttr(mDirName + '\' + vSearchRec.Name, 0);
      if ((CompareText(tmpExt, ExtractFileExt(vSearchRec.Name)) = 0) or (CompareText(tmpExt, '.*') = 0)) then
        Result := DeleteFile(PChar(mDirName + '\' + vSearchRec.Name));
    end;
    if not Result then
      Break;
    K := FindNext(vSearchRec);
  end;
  FindClose(vSearchRec);
end; 


procedure TForm1.proSY(fname:string);
begin
  app.open(fname);
  //sleep(100);
  app.doaction('去水印','去水印.atn');
end;
procedure TForm1.Button1Click(Sender: TObject);

begin

  //appRef.DoAction   "Molten   Lead",   "Default   Actions.atn"
  //app.doaction('打开水印','打开水印.atn');
 app:=createoleobject('Photoshop.Application');
// app.visible:=false;
 app.doaction('打开水印','打开水印');
  //app.quit;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  kk:=false;
  HotKeyId := GlobalAddAtom('MyHotKey')-$C000;
  registerhotkey(handle,hotkeyid,mod_Alt,VK_F8); //Alt+f8
  HotKeyId1 := GlobalAddAtom('MyHotKey1')-$C000;
  registerhotkey(handle,hotkeyid1,mod_Alt,VK_F9); //Alt+f8

 kkk:=1;
 ppath:=extractfilepath(paramstr(0));
 if fileexists(ppath+'dp\list.txt') then
 try
   listbox1.Items.LoadFromFile(ppath+'dp\list.txt');
 except
 end;
 Fullscreen:=TBitmap.Create;//创建一个BITMAP来存放图象　
  PNG := TPNGObject.Create;
  png.CompressionLevel:=9;
  //png.
  Fullscreen.Width:=screen.width;
  //Fullscreen.Height:=screen.Height-168;
  Fullscreen.Height:=700;
  DC:=GetDC(0);//取得屏幕的DC，参数0指的是屏幕　
  FullscreenCanvas:=TCanvas.Create;//创建一个CANVAS对象　
  FullscreenCanvas.Handle:=DC;

end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  ReleaseDC(0,DC);
  Fullscreen.Free;
  FullscreenCanvas.Free;
  png.Free;
  app.quit;
  close;

end;

procedure TForm1.captureSCR;
var
  //Fullscreen:Tbitmap;
  //FullscreenCanvas:TCanvas;
  //dc:HDC;
  //PNG: TPNGObject;
  fname,dt:string;
  x,i:integer;
begin
  {Fullscreen:=TBitmap.Create;//创建一个BITMAP来存放图象　
  PNG := TPNGObject.Create;
  png.CompressionLevel:=7;
  //png.
  Fullscreen.Width:=screen.width;
  //Fullscreen.Height:=screen.Height-168;
  Fullscreen.Height:=700;
  DC:=GetDC(0);//取得屏幕的DC，参数0指的是屏幕　
  FullscreenCanvas:=TCanvas.Create;//创建一个CANVAS对象　
  FullscreenCanvas.Handle:=DC;     }
  //Fullscreen.Canvas.CopyRect(Rect(0,0,screen.Width,screen.Height),fullscreenCanvas,Rect(0,0,Screen.Width,Screen.Height)); //把整个屏幕复制到BITMAP中　
  //setcursorpos(56,300);
  setcursorpos(705,300);
  timer3.Enabled:=true;
  if time()>strtotime('13:00:00') then
    x:=385+trunc(MinutesBetween(time(),strtotime('13:00:00'))*163/60+0.5)
  else
    x:=60+trunc(MinutesBetween(time(),strtotime('9:30:00'))*163/60+0.5) ;
  if x>708 then
    x:=708;

  {for i:=0 downto 5 do
   begin
    setcursorpos(708,300+i*8);
    application.ProcessMessages;
    end;
   }
   
  Fullscreen.Canvas.CopyRect(Rect(0,0,screen.Width,700),
     fullscreenCanvas,Rect(0,40,Screen.Width,740)); //把整个屏幕复制到BITMAP中　
  //FullscreenCanvas.Free;//释放CANVAS对象　
  //ReleaseDC(0,DC);//释放DC　//*******************************　
  //x:=
  timer3.Enabled:=false;
  image1.picture.Bitmap:=fullscreen;//拷贝下的图象赋给IMAGE对象　
  image1.Width:=fullscreen.Width;
  image1.Height:=fullscreen.Height;
  //image1.Picture.Bitmap.PixelFormat:=pf16bit	;
  //fullscreen.free;//释放bitmap　
  //form1.WindowState:=wsNormal;//复原窗口状态　
  //form1.show;//显示窗口　
  //messagebeep(1);//BEEP叫一声，报告图象已经截取好了。
  //image1.Picture.SaveToFile(inttostr(kkk)+'.bmp');
  dt:=formatdatetime('yyyymmddhhmmss',now);
  fname:=ppath+'dp\'+dt+'.png';
  try
  PNG.Assign(image1.Picture.Bitmap);
  png.Filters:=[pfSub];
  PNG.SaveToFile(fname);
  except
    exit;
  end;
  //png.Free;
  if checkbox1.Checked  then
  try
    proSY(fname);
  except
    exit;
  end;
  listbox1.Items.Add(dt);
  listbox1.Items.SaveToFile(ppath+'dp\list.txt');

end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  capturescr;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  timer1.Enabled:=true;
end;

procedure TForm1.Button6Click(Sender: TObject);
var
  i:integer;
begin
  for i:=0 to memo1.Lines.Count-1 do
   begin
    if not fileexists(memo1.Lines.Strings[i]) then
     continue;
    app.open(memo1.Lines.Strings[i]);
    app.doaction('去水印','去水印.atn');
  end;
end;

procedure TForm1.Button5Click(Sender: TObject);
begin
  listbox1.Items.Clear;
  listbox1.Items.SaveToFile(ppath+'dp\list.txt');
  DeletePath(ppath+'dp','.png');
end;

procedure TForm1.Timer2Timer(Sender: TObject);
var
  t:ttime;
  i,x:integer;
begin
{
  if time()>strtotime('13:00:00') then
    x:=385+trunc(MinutesBetween(time(),strtotime('13:00:00'))*163/60+0.5)
  else
    x:=60+trunc(MinutesBetween(time(),strtotime('9:30:00'))*163/60+0.5) ;
  if x>710 then
    x:=710;
  for i:=x+20 downto x do
    setcursorpos(i,300);
 }
 if kk then
 setcursorpos(700,300);
  ShortTimeFormat:='hh:mm:ss';
  t:=strtotime('15:03:00');
 if kk then
 setcursorpos(708,350);
  if time()>t then
    begin
      timer1.Enabled:=false;
      exit;
    end;
  t:=strtotime('12:57:00');
  if time()>t then
    begin
      timer1.Enabled:=true;
      exit;
    end;
  t:=strtotime('11:31:00');
  if time()>t then
    begin
      timer1.Enabled:=false;
      exit;
    end;
  t:=strtotime('9:27:00');
  if time()>t then
    begin
      timer1.Enabled:=true;
      exit;
    end;

  t:=strtotime('9:15:00');
  if time()>t then
    begin
      listbox1.Clear;
      timer1.Enabled:=false;
      DeletePath(ppath+'dp','*.png');
      listbox1.Items.SaveToFile(ppath+'dp\list.txt');
      exit;
    end;


end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  UnRegisterHotKey(handle, HotKeyId);
  DeleteAtom(hotKeyID);
  UnRegisterHotKey(handle, HotKeyId1);
  DeleteAtom(hotKeyID1);

end;


procedure TForm1.HotKeyDown(var Msg: Tmessage);
begin
  //
  if (Msg.LparamLo = MOD_ALT) AND (Msg.LParamHi = VK_F8) then // 假设热键为ALT+F8
    begin
      captureSCR;
    end;
  if (Msg.LparamLo = MOD_ALT) AND (Msg.LParamHi = VK_F9) then // 启动鼠标轰动
    begin
      kk:=not kk;
    end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  captureSCR;
end;

procedure TForm1.Timer3Timer(Sender: TObject);
var
  t:ttime;
  i,x:integer;
begin
 {
  if time()>strtotime('13:00:00') then
    x:=385+trunc(MinutesBetween(time(),strtotime('13:00:00'))*163/60+0.5)
  else
    x:=60+trunc(MinutesBetween(time(),strtotime('9:30:00'))*163/60+0.5) ;
  if x>710 then
    x:=710;
  }
  timer3.Enabled:=false;
  for i:=0 to 50 do
    begin
      if 700+i>708 then
          setcursorpos(705,300+i*2)
      else
          setcursorpos(700+i,300+i);
      mouse_event(MOUSEEVENTF_LEFTDOWN,0,0,0,0);
      mouse_event(MOUSEEVENTF_LEFTUP,0,0,0,0);
      //Mouse_Event(MOUSEEVENTF_ABSOLUTE+MOUSEEVENTF_leftup	, 705, 300+random(10), 0, GetMessageExtraInfo);
      application.ProcessMessages;
      sleep(50)  ;
    end;
//    end;
  //setcursorpos(700,300);

end;

procedure TForm1.CheckBox2Click(Sender: TObject);
begin
  if checkbox2.Checked then
    timer3.Enabled:=true
  else
    timer3.Enabled:=false;
end;

end.