Un simple programa para sacar un screenshot y subir la imagen a imageshack.
Una imagen :
El codigo :
Código: delphi
Si quieren bajar el programa lo pueden hacer de You are not allowed to view links. You are not allowed to view links. Register or Login or You are not allowed to view links. Register or Login.
Una imagen :
El codigo :
// 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 You are not allowed to view links. You are not allowed to view links. Register or Login or You are not allowed to view links. Register or Login.
