[Delphi] DH ScreenShoter 0.1

[BigBear]

Un simple programa para sacar un screenshot y subir la imagen a imageshack.

Una imagen :



El codigo :

Código (delphi) [Seleccionar] Expandir


// DH Screenshoter 0.1
// Coded By Doddy H
// Credits
// Based on : http://forum.codecall.net/topic/60613-how-to-capture-screen-with-delphi-code/

unit dh;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, sSkinManager, StdCtrls, sGroupBox, ComCtrls, sStatusBar, sLabel,
  sCheckBox, sEdit, sButton, acPNG, ExtCtrls, Jpeg, ShellApi,
  IdMultipartFormData,
  PerlRegEx, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP;

type
  TForm1 = class(TForm)
    sSkinManager1: TsSkinManager;
    sGroupBox1: TsGroupBox;
    sStatusBar1: TsStatusBar;
    sCheckBox1: TsCheckBox;
    sEdit1: TsEdit;
    sCheckBox2: TsCheckBox;
    sEdit2: TsEdit;
    sLabel1: TsLabel;
    sCheckBox3: TsCheckBox;
    sGroupBox2: TsGroupBox;
    sEdit3: TsEdit;
    sGroupBox3: TsGroupBox;
    sButton1: TsButton;
    sButton2: TsButton;
    sButton3: TsButton;
    sButton4: TsButton;
    sCheckBox4: TsCheckBox;
    Image1: TImage;
    IdHTTP1: TIdHTTP;
    PerlRegEx1: TPerlRegEx;
    procedure sButton3Click(Sender: TObject);
    procedure sButton4Click(Sender: TObject);
    procedure sButton2Click(Sender: TObject);
    procedure sButton1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure capturar(nombre: string);
var
  imagen2: TJpegImage;
  imagen1: TBitmap;
  aca: HDC;

begin

  aca := GetWindowDC(GetDesktopWindow);

  imagen1 := TBitmap.Create;
  imagen1.PixelFormat := pf24bit;
  imagen1.Height := Screen.Height;
  imagen1.Width := Screen.Width;

  BitBlt(imagen1.Canvas.Handle, 0, 0, imagen1.Width, imagen1.Height, aca, 0, 0,
    SRCCOPY);

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

end;

procedure TForm1.FormCreate(Sender: TObject);
var
  dir: string;
begin
  sSkinManager1.SkinDirectory := ExtractFilePath(Application.ExeName) + 'Data';
  sSkinManager1.SkinName := 'cold';
  sSkinManager1.Active := True;

  dir := ExtractFilePath(Application.ExeName) + '/captures';

  if not(DirectoryExists(dir)) then
  begin
    CreateDir(dir);
  end;

  ChDir(dir);

end;

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

begin

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

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

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

  Form1.Hide;

  Sleep(1000);

  if (sCheckBox1.Checked) then
  begin
    capturar(sEdit1.text);
  end
  else
  begin
    capturar(nombrefecha);
  end;

  Form1.Show;

  sStatusBar1.Panels[0].text := '[+] Photo taken';
  Form1.sStatusBar1.Update;

  if (sCheckBox3.Checked) then
  begin

    sStatusBar1.Panels[0].text := '[+] Uploading ...';
    Form1.sStatusBar1.Update;

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

    if (sCheckBox1.Checked) then
    begin
      datos.AddFile('fileupload', sEdit1.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);

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

    if PerlRegEx1.Match then
    begin
      sEdit3.text := PerlRegEx1.SubExpressions[1];
      sStatusBar1.Panels[0].text := '[+] Done';
      Form1.sStatusBar1.Update;
    end
    else
    begin
      sStatusBar1.Panels[0].text := '[-] Error uploading';
      Form1.sStatusBar1.Update;
    end;
  end;

  if (sCheckBox4.Checked) then
  begin
    if (sCheckBox1.Checked) then
    begin
      ShellExecute(Handle, 'open', Pchar(sEdit1.text), nil, nil, SW_SHOWNORMAL);
    end
    else
    begin
      ShellExecute(Handle, 'open', Pchar(nombrefecha), nil, nil, SW_SHOWNORMAL);
    end;
  end;

end;

procedure TForm1.sButton2Click(Sender: TObject);
begin
  sEdit3.SelectAll;
  sEdit3.CopyToClipboard;
end;

procedure TForm1.sButton3Click(Sender: TObject);
begin
  ShowMessage('Contact to lepuke[at]hotmail[com]');
end;

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

end.

// The End ?



Si quieren bajar el programa lo pueden hacer de aca.