comment
IRC Chat
play_arrow
Este sitio utiliza cookies propias y de terceros. Si continúa navegando consideramos que acepta el uso de cookies. OK Más Información.

[Delphi] DH ScreenShoter 0.1

  • 1 Respuestas
  • 1402 Vistas

0 Usuarios y 1 Visitante están viendo este tema.

Desconectado BigBear

  • *
  • Underc0der
  • Mensajes: 543
  • Actividad:
    0%
  • Reputación 3
    • Ver Perfil
« en: Septiembre 06, 2013, 01:58:27 pm »
Un simple programa para sacar un screenshot y subir la imagen a imageshack.

Una imagen :



El codigo :

Código: Delphi
  1. // DH Screenshoter 0.1
  2. // Coded By Doddy H
  3. // Credits
  4. // Based on : http://forum.codecall.net/topic/60613-how-to-capture-screen-with-delphi-code/
  5.  
  6. unit dh;
  7.  
  8. interface
  9.  
  10. uses
  11.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  12.   Dialogs, sSkinManager, StdCtrls, sGroupBox, ComCtrls, sStatusBar, sLabel,
  13.   sCheckBox, sEdit, sButton, acPNG, ExtCtrls, Jpeg, ShellApi,
  14.   IdMultipartFormData,
  15.   PerlRegEx, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP;
  16.  
  17. type
  18.   TForm1 = class(TForm)
  19.     sSkinManager1: TsSkinManager;
  20.     sGroupBox1: TsGroupBox;
  21.     sStatusBar1: TsStatusBar;
  22.     sCheckBox1: TsCheckBox;
  23.     sEdit1: TsEdit;
  24.     sCheckBox2: TsCheckBox;
  25.     sEdit2: TsEdit;
  26.     sLabel1: TsLabel;
  27.     sCheckBox3: TsCheckBox;
  28.     sGroupBox2: TsGroupBox;
  29.     sEdit3: TsEdit;
  30.     sGroupBox3: TsGroupBox;
  31.     sButton1: TsButton;
  32.     sButton2: TsButton;
  33.     sButton3: TsButton;
  34.     sButton4: TsButton;
  35.     sCheckBox4: TsCheckBox;
  36.     Image1: TImage;
  37.     IdHTTP1: TIdHTTP;
  38.     PerlRegEx1: TPerlRegEx;
  39.     procedure sButton3Click(Sender: TObject);
  40.     procedure sButton4Click(Sender: TObject);
  41.     procedure sButton2Click(Sender: TObject);
  42.     procedure sButton1Click(Sender: TObject);
  43.     procedure FormCreate(Sender: TObject);
  44.   private
  45.     { Private declarations }
  46.   public
  47.     { Public declarations }
  48.   end;
  49.  
  50. var
  51.   Form1: TForm1;
  52.  
  53. implementation
  54.  
  55. {$R *.dfm}
  56.  
  57. procedure capturar(nombre: string);
  58. var
  59.   imagen2: TJpegImage;
  60.   imagen1: TBitmap;
  61.   aca: HDC;
  62.  
  63. begin
  64.  
  65.   aca := GetWindowDC(GetDesktopWindow);
  66.  
  67.   imagen1 := TBitmap.Create;
  68.   imagen1.PixelFormat := pf24bit;
  69.   imagen1.Height := Screen.Height;
  70.   imagen1.Width := Screen.Width;
  71.  
  72.   BitBlt(imagen1.Canvas.Handle, 0, 0, imagen1.Width, imagen1.Height, aca, 0, 0,
  73.     SRCCOPY);
  74.  
  75.   imagen2 := TJpegImage.Create;
  76.   imagen2.Assign(imagen1);
  77.   imagen2.CompressionQuality := 60;
  78.   imagen2.SaveToFile(nombre);
  79.  
  80. end;
  81.  
  82. procedure TForm1.FormCreate(Sender: TObject);
  83. var
  84.   dir: string;
  85. begin
  86.   sSkinManager1.SkinDirectory := ExtractFilePath(Application.ExeName) + 'Data';
  87.   sSkinManager1.SkinName := 'cold';
  88.   sSkinManager1.Active := True;
  89.  
  90.   dir := ExtractFilePath(Application.ExeName) + '/captures';
  91.  
  92.   if not(DirectoryExists(dir)) then
  93.   begin
  94.     CreateDir(dir);
  95.   end;
  96.  
  97.   ChDir(dir);
  98.  
  99. end;
  100.  
  101. procedure TForm1.sButton1Click(Sender: TObject);
  102. var
  103.   fecha: TDateTime;
  104.   fechafinal: string;
  105.   nombrefecha: string;
  106.   i: integer;
  107.   datos: TIdMultiPartFormDataStream;
  108.   code: string;
  109.  
  110. begin
  111.  
  112.   fecha := now();
  113.   fechafinal := DateTimeToStr(fecha);
  114.   nombrefecha := fechafinal + '.jpg';
  115.  
  116.   nombrefecha := StringReplace(nombrefecha, '/', ':', [rfReplaceAll,
  117.     rfIgnoreCase]);
  118.   nombrefecha := StringReplace
  119.     (nombrefecha, ' ', '', [rfReplaceAll, rfIgnoreCase]);
  120.   nombrefecha := StringReplace(nombrefecha, ':', '_', [rfReplaceAll,
  121.     rfIgnoreCase]);
  122.  
  123.   if (sCheckBox2.Checked) then
  124.   begin
  125.     for i := 1 to StrToInt(sEdit2.text) do
  126.     begin
  127.       sStatusBar1.Panels[0].text := '[+] Taking picture on  : ' + IntToStr(i)
  128.         + ' seconds ';
  129.       Form1.sStatusBar1.Update;
  130.       Sleep(i * 1000);
  131.     end;
  132.   end;
  133.  
  134.   Form1.Hide;
  135.  
  136.   Sleep(1000);
  137.  
  138.   if (sCheckBox1.Checked) then
  139.   begin
  140.     capturar(sEdit1.text);
  141.   end
  142.   else
  143.   begin
  144.     capturar(nombrefecha);
  145.   end;
  146.  
  147.   Form1.Show;
  148.  
  149.   sStatusBar1.Panels[0].text := '[+] Photo taken';
  150.   Form1.sStatusBar1.Update;
  151.  
  152.   if (sCheckBox3.Checked) then
  153.   begin
  154.  
  155.     sStatusBar1.Panels[0].text := '[+] Uploading ...';
  156.     Form1.sStatusBar1.Update;
  157.  
  158.     datos := TIdMultiPartFormDataStream.Create;
  159.     datos.AddFormField('key', 'Fuck You');
  160.  
  161.     if (sCheckBox1.Checked) then
  162.     begin
  163.       datos.AddFile('fileupload', sEdit1.text, 'application/octet-stream');
  164.     end
  165.     else
  166.     begin
  167.       datos.AddFile('fileupload', nombrefecha, 'application/octet-stream');
  168.     end;
  169.     datos.AddFormField('format', 'json');
  170.  
  171.     code := IdHTTP1.Post('http://post.imageshack.us/upload_api.php', datos);
  172.  
  173.     PerlRegEx1.Regex := '"image_link":"(.*?)"';
  174.     PerlRegEx1.Subject := code;
  175.  
  176.     if PerlRegEx1.Match then
  177.     begin
  178.       sEdit3.text := PerlRegEx1.SubExpressions[1];
  179.       sStatusBar1.Panels[0].text := '[+] Done';
  180.       Form1.sStatusBar1.Update;
  181.     end
  182.     else
  183.     begin
  184.       sStatusBar1.Panels[0].text := '[-] Error uploading';
  185.       Form1.sStatusBar1.Update;
  186.     end;
  187.   end;
  188.  
  189.   if (sCheckBox4.Checked) then
  190.   begin
  191.     if (sCheckBox1.Checked) then
  192.     begin
  193.       ShellExecute(Handle, 'open', Pchar(sEdit1.text), nil, nil, SW_SHOWNORMAL);
  194.     end
  195.     else
  196.     begin
  197.       ShellExecute(Handle, 'open', Pchar(nombrefecha), nil, nil, SW_SHOWNORMAL);
  198.     end;
  199.   end;
  200.  
  201. end;
  202.  
  203. procedure TForm1.sButton2Click(Sender: TObject);
  204. begin
  205.   sEdit3.SelectAll;
  206.   sEdit3.CopyToClipboard;
  207. end;
  208.  
  209. procedure TForm1.sButton3Click(Sender: TObject);
  210. begin
  211.   ShowMessage('Contact to lepuke[at]hotmail[com]');
  212. end;
  213.  
  214. procedure TForm1.sButton4Click(Sender: TObject);
  215. begin
  216.   Form1.Close();
  217. end;
  218.  
  219. end.
  220.  
  221. // The End ?
  222.  


Si quieren bajar el programa lo pueden hacer de No tienes permisos para ver links. Registrate o Entra con tu cuenta.

Desconectado ZanGetsu

  • *
  • Underc0der
  • Mensajes: 325
  • Actividad:
    0%
  • Reputación 0
  • I ZanGetsu
    • Ver Perfil
  • Skype: thenicox
  • Twitter: black_zangetsu
« Respuesta #1 en: Septiembre 06, 2013, 03:39:21 pm »
Muy ingenioso Doody, me sera de gran utilidad, gracias !

 

¿Te gustó el post? COMPARTILO!



[Sintaxis general de Delphi] By: Geek Lord Venezuela [R00t] Team

Iniciado por ANTRAX

Respuestas: 0
Vistas: 1984
Último mensaje Febrero 24, 2010, 04:35:15 pm
por ANTRAX
Eliminar acentos y otros agregados de un caracter/cadena Delphi 2009

Iniciado por ANTRAX

Respuestas: 0
Vistas: 3130
Último mensaje Febrero 24, 2010, 04:57:14 pm
por ANTRAX
1er troyano en Delphi By: Geek Lord Venezuela [R00t] Team

Iniciado por ANTRAX

Respuestas: 0
Vistas: 3258
Último mensaje Febrero 24, 2010, 04:34:48 pm
por ANTRAX
[Delphi] Creacion de un Server Builder con recursos

Iniciado por BigBear

Respuestas: 1
Vistas: 1413
Último mensaje Marzo 09, 2015, 07:56:20 pm
por Flemon
[Delphi] Project Arsenal X 0.2 (Regalo de navidad)

Iniciado por BigBear

Respuestas: 2
Vistas: 2575
Último mensaje Diciembre 28, 2015, 10:27:44 am
por BigBear