Foro de elhacker.net

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

Una imagen :

(http://doddyhackman.webcindario.com/images/screnshoter03.jpg)

El codigo :

// 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 (https://sourceforge.net/projects/dhscreenshoter/).