[Delphi] DH ScreenShoter 0.3

[BigBear]

Version final de este programa para sacar un screenshot y subirlo ImageShack.

Una imagen :



El codigo :

Código (delphi) [Seleccionar] Expandir


// DH Screenshoter 0.3
// (C) Doddy Hackman 2014
// Based in the API of : https://imageshack.com/

unit screen;

interface

uses
  Windows, System.SysUtils, System.Variants,
  System.Classes, Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Imaging.pngimage, Vcl.ExtCtrls,
  Vcl.ComCtrls, Vcl.StdCtrls, Jpeg, ShellApi, IdMultipartFormData,
  IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, PerlRegEx,
  about;

type
  TForm1 = class(TForm)
    Image1: TImage;
    StatusBar1: TStatusBar;
    GroupBox1: TGroupBox;
    CheckBox1: TCheckBox;
    Edit1: TEdit;
    CheckBox2: TCheckBox;
    Edit2: TEdit;
    Label1: TLabel;
    CheckBox3: TCheckBox;
    CheckBox4: TCheckBox;
    GroupBox2: TGroupBox;
    Edit3: TEdit;
    GroupBox3: TGroupBox;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    IdHTTP1: TIdHTTP;
    procedure Button1Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
// Functions

procedure capturar(nombre: string);

// Function capturar() based in :
// http://forum.codecall.net/topic/60613-how-to-capture-screen-with-delphi-code/
// http://delphi.about.com/cs/adptips2001/a/bltip0501_4.htm
// http://stackoverflow.com/questions/21971605/show-mouse-cursor-in-screenshot-with-delphi
// Thanks to Zarko Gajic , Luthfi and Ken White

var
  aca: HDC;
  tan: TRect;
  posnow: TPoint;
  imagen1: TBitmap;
  imagen2: TJpegImage;
  curnow: THandle;

begin

  aca := GetWindowDC(GetDesktopWindow);
  imagen1 := TBitmap.Create;

  GetWindowRect(GetDesktopWindow, tan);
  imagen1.Width := tan.Right - tan.Left;
  imagen1.Height := tan.Bottom - tan.Top;
  BitBlt(imagen1.Canvas.Handle, 0, 0, imagen1.Width, imagen1.Height, aca, 0,
    0, SRCCOPY);

  GetCursorPos(posnow);

  curnow := GetCursor;
  DrawIconEx(imagen1.Canvas.Handle, posnow.X, posnow.Y, curnow, 32, 32, 0, 0,
    DI_NORMAL);

  imagen2 := TJpegImage.Create;
  imagen2.Assign(imagen1);
  imagen2.CompressionQuality := 60;
  imagen2.SaveToFile(nombre);

  imagen1.Free;
  imagen2.Free;

end;

//

procedure TForm1.Button1Click(Sender: TObject);
var
  fecha: TDateTime;
  fechafinal: string;
  nombrefecha: string;
  i: integer;
  datos: TIdMultiPartFormDataStream;
  code: string;
  regex: TPerlRegEx;
  url: string;

begin

  Edit3.Text := '';
  regex := TPerlRegEx.Create();

  fecha := now();
  fechafinal := DateTimeToStr(fecha);
  nombrefecha := fechafinal + '.jpg';

  nombrefecha := StringReplace(nombrefecha, '/', ':',
    [rfReplaceAll, rfIgnoreCase]);
  nombrefecha := StringReplace(nombrefecha, ' ', '',
    [rfReplaceAll, rfIgnoreCase]);
  nombrefecha := StringReplace(nombrefecha, ':', '_',
    [rfReplaceAll, rfIgnoreCase]);

  if (CheckBox2.Checked) then
  begin
    for i := 1 to StrToInt(Edit2.Text) do
    begin
      StatusBar1.Panels[0].Text := '[+] Taking picture on  : ' + IntToStr(i) +
        ' seconds ';
      Form1.StatusBar1.Update;
      Sleep(i * 1000);
    end;
  end;

  Form1.Hide;

  Sleep(1000);

  if (CheckBox1.Checked) then
  begin
    capturar(Edit1.Text);
  end
  else
  begin
    capturar(nombrefecha);
  end;

  Form1.Show;

  StatusBar1.Panels[0].Text := '[+] Photo taken';
  Form1.StatusBar1.Update;

  if (CheckBox4.Checked) then
  begin

    StatusBar1.Panels[0].Text := '[+] Uploading ...';
    Form1.StatusBar1.Update;

    datos := TIdMultiPartFormDataStream.Create;
    datos.AddFormField('key', '');
    // Fuck You

    if (CheckBox1.Checked) then
    begin
      datos.AddFile('fileupload', Edit1.Text, 'application/octet-stream');
    end
    else
    begin
      datos.AddFile('fileupload', nombrefecha, 'application/octet-stream');
    end;
    datos.AddFormField('format', 'json');

    code := IdHTTP1.Post('http://post.imageshack.us/upload_api.php', datos);

    regex.regex := '"image_link":"(.*?)"';
    regex.Subject := code;

    if regex.Match then
    begin
      url := regex.Groups[1];
      url := StringReplace(url, '\', '', [rfReplaceAll, rfIgnoreCase]);
      Edit3.Text := url;
      StatusBar1.Panels[0].Text := '[+] Done';
      Form1.StatusBar1.Update;
    end
    else
    begin
      StatusBar1.Panels[0].Text := '[-] Error uploading';
      Form1.StatusBar1.Update;
    end;
  end;

  if (CheckBox3.Checked) then
  begin
    if (CheckBox1.Checked) then
    begin
      ShellExecute(Handle, 'open', Pchar(Edit1.Text), nil, nil, SW_SHOWNORMAL);
    end
    else
    begin
      ShellExecute(Handle, 'open', Pchar(nombrefecha), nil, nil, SW_SHOWNORMAL);
    end;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Edit3.SelectAll;
  Edit3.CopyToClipboard;
end;

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

procedure TForm1.Button4Click(Sender: TObject);
begin
  Form1.Close();
  Form2.Close();
end;

end.

// The End ?


Si quieren bajar el programa lo pueden hacer de aca.