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.3

  • 1 Respuestas
  • 2413 Vistas

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

Desconectado BigBear

  • *
  • Underc0der
  • Mensajes: 543
  • Actividad:
    0%
  • Reputación 3
    • Ver Perfil
« en: Mayo 09, 2014, 03:22:52 pm »
Version final de este programa para sacar un screenshot y subirlo ImageShack.

Una imagen :



El codigo :

Código: Delphi
  1. // DH Screenshoter 0.3
  2. // (C) Doddy Hackman 2014
  3. // Based in the API of : https://imageshack.com/
  4.  
  5. unit screen;
  6.  
  7. interface
  8.  
  9. uses
  10.   Windows, System.SysUtils, System.Variants,
  11.   System.Classes, Graphics,
  12.   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Imaging.pngimage, Vcl.ExtCtrls,
  13.   Vcl.ComCtrls, Vcl.StdCtrls, Jpeg, ShellApi, IdMultipartFormData,
  14.   IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, PerlRegEx,
  15.   about;
  16.  
  17. type
  18.   TForm1 = class(TForm)
  19.     Image1: TImage;
  20.     StatusBar1: TStatusBar;
  21.     GroupBox1: TGroupBox;
  22.     CheckBox1: TCheckBox;
  23.     Edit1: TEdit;
  24.     CheckBox2: TCheckBox;
  25.     Edit2: TEdit;
  26.     Label1: TLabel;
  27.     CheckBox3: TCheckBox;
  28.     CheckBox4: TCheckBox;
  29.     GroupBox2: TGroupBox;
  30.     Edit3: TEdit;
  31.     GroupBox3: TGroupBox;
  32.     Button1: TButton;
  33.     Button2: TButton;
  34.     Button3: TButton;
  35.     Button4: TButton;
  36.     IdHTTP1: TIdHTTP;
  37.     procedure Button1Click(Sender: TObject);
  38.     procedure Button4Click(Sender: TObject);
  39.     procedure Button2Click(Sender: TObject);
  40.     procedure Button3Click(Sender: TObject);
  41.   private
  42.     { Private declarations }
  43.   public
  44.     { Public declarations }
  45.   end;
  46.  
  47. var
  48.   Form1: TForm1;
  49.  
  50. implementation
  51.  
  52. {$R *.dfm}
  53. // Functions
  54.  
  55. procedure capturar(nombre: string);
  56.  
  57. // Function capturar() based in :
  58. // http://forum.codecall.net/topic/60613-how-to-capture-screen-with-delphi-code/
  59. // http://delphi.about.com/cs/adptips2001/a/bltip0501_4.htm
  60. // http://stackoverflow.com/questions/21971605/show-mouse-cursor-in-screenshot-with-delphi
  61. // Thanks to Zarko Gajic , Luthfi and Ken White
  62.  
  63. var
  64.   aca: HDC;
  65.   tan: TRect;
  66.   posnow: TPoint;
  67.   imagen1: TBitmap;
  68.   imagen2: TJpegImage;
  69.   curnow: THandle;
  70.  
  71. begin
  72.  
  73.   aca := GetWindowDC(GetDesktopWindow);
  74.   imagen1 := TBitmap.Create;
  75.  
  76.   GetWindowRect(GetDesktopWindow, tan);
  77.   imagen1.Width := tan.Right - tan.Left;
  78.   imagen1.Height := tan.Bottom - tan.Top;
  79.   BitBlt(imagen1.Canvas.Handle, 0, 0, imagen1.Width, imagen1.Height, aca, 0,
  80.     0, SRCCOPY);
  81.  
  82.   GetCursorPos(posnow);
  83.  
  84.   curnow := GetCursor;
  85.   DrawIconEx(imagen1.Canvas.Handle, posnow.X, posnow.Y, curnow, 32, 32, 0, 0,
  86.     DI_NORMAL);
  87.  
  88.   imagen2 := TJpegImage.Create;
  89.   imagen2.Assign(imagen1);
  90.   imagen2.CompressionQuality := 60;
  91.   imagen2.SaveToFile(nombre);
  92.  
  93.   imagen1.Free;
  94.   imagen2.Free;
  95.  
  96. end;
  97.  
  98. //
  99.  
  100. procedure TForm1.Button1Click(Sender: TObject);
  101. var
  102.   fecha: TDateTime;
  103.   fechafinal: string;
  104.   nombrefecha: string;
  105.   i: integer;
  106.   datos: TIdMultiPartFormDataStream;
  107.   code: string;
  108.   regex: TPerlRegEx;
  109.   url: string;
  110.  
  111. begin
  112.  
  113.   Edit3.Text := '';
  114.   regex := TPerlRegEx.Create();
  115.  
  116.   fecha := now();
  117.   fechafinal := DateTimeToStr(fecha);
  118.   nombrefecha := fechafinal + '.jpg';
  119.  
  120.   nombrefecha := StringReplace(nombrefecha, '/', ':',
  121.     [rfReplaceAll, rfIgnoreCase]);
  122.   nombrefecha := StringReplace(nombrefecha, ' ', '',
  123.     [rfReplaceAll, rfIgnoreCase]);
  124.   nombrefecha := StringReplace(nombrefecha, ':', '_',
  125.     [rfReplaceAll, rfIgnoreCase]);
  126.  
  127.   if (CheckBox2.Checked) then
  128.   begin
  129.     for i := 1 to StrToInt(Edit2.Text) do
  130.     begin
  131.       StatusBar1.Panels[0].Text := '[+] Taking picture on  : ' + IntToStr(i) +
  132.         ' seconds ';
  133.       Form1.StatusBar1.Update;
  134.       Sleep(i * 1000);
  135.     end;
  136.   end;
  137.  
  138.   Form1.Hide;
  139.  
  140.   Sleep(1000);
  141.  
  142.   if (CheckBox1.Checked) then
  143.   begin
  144.     capturar(Edit1.Text);
  145.   end
  146.   else
  147.   begin
  148.     capturar(nombrefecha);
  149.   end;
  150.  
  151.   Form1.Show;
  152.  
  153.   StatusBar1.Panels[0].Text := '[+] Photo taken';
  154.   Form1.StatusBar1.Update;
  155.  
  156.   if (CheckBox4.Checked) then
  157.   begin
  158.  
  159.     StatusBar1.Panels[0].Text := '[+] Uploading ...';
  160.     Form1.StatusBar1.Update;
  161.  
  162.     datos := TIdMultiPartFormDataStream.Create;
  163.     datos.AddFormField('key', '');
  164.     // Fuck You
  165.  
  166.     if (CheckBox1.Checked) then
  167.     begin
  168.       datos.AddFile('fileupload', Edit1.Text, 'application/octet-stream');
  169.     end
  170.     else
  171.     begin
  172.       datos.AddFile('fileupload', nombrefecha, 'application/octet-stream');
  173.     end;
  174.     datos.AddFormField('format', 'json');
  175.  
  176.     code := IdHTTP1.Post('http://post.imageshack.us/upload_api.php', datos);
  177.  
  178.     regex.regex := '"image_link":"(.*?)"';
  179.     regex.Subject := code;
  180.  
  181.     if regex.Match then
  182.     begin
  183.       url := regex.Groups[1];
  184.       url := StringReplace(url, '\', '', [rfReplaceAll, rfIgnoreCase]);
  185.       Edit3.Text := url;
  186.       StatusBar1.Panels[0].Text := '[+] Done';
  187.       Form1.StatusBar1.Update;
  188.     end
  189.     else
  190.     begin
  191.       StatusBar1.Panels[0].Text := '[-] Error uploading';
  192.       Form1.StatusBar1.Update;
  193.     end;
  194.   end;
  195.  
  196.   if (CheckBox3.Checked) then
  197.   begin
  198.     if (CheckBox1.Checked) then
  199.     begin
  200.       ShellExecute(Handle, 'open', Pchar(Edit1.Text), nil, nil, SW_SHOWNORMAL);
  201.     end
  202.     else
  203.     begin
  204.       ShellExecute(Handle, 'open', Pchar(nombrefecha), nil, nil, SW_SHOWNORMAL);
  205.     end;
  206.   end;
  207. end;
  208.  
  209. procedure TForm1.Button2Click(Sender: TObject);
  210. begin
  211.   Edit3.SelectAll;
  212.   Edit3.CopyToClipboard;
  213. end;
  214.  
  215. procedure TForm1.Button3Click(Sender: TObject);
  216. begin
  217.   Form2.Show;
  218. end;
  219.  
  220. procedure TForm1.Button4Click(Sender: TObject);
  221. begin
  222.   Form1.Close();
  223.   Form2.Close();
  224. end;
  225.  
  226. end.
  227.  
  228. // The End ?
  229.  

Si quieren bajar el programa lo pueden hacer de aca.

Desconectado Flemon

  • *
  • Underc0der
  • Mensajes: 235
  • Actividad:
    0%
  • Reputación 0
  • NO HAY FORMA DE DETENERME!!
    • Ver Perfil
    • Email
« Respuesta #1 en: Mayo 10, 2014, 01:45:37 pm »
Como siempre Doddy excelente trabajo, me has echo querer aprender Delphi, es mas, me voy a poner esta misma tarde a leer algo de pascal...
No intentes pararme, trata de defenderte, trata de matarme, pero de cualqueir forma TE SUPERARE

 

¿Te gustó el post? COMPARTILO!



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

Iniciado por ANTRAX

Respuestas: 0
Vistas: 2041
Ú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: 3245
Ú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: 3474
Último mensaje Febrero 24, 2010, 04:34:48 pm
por ANTRAX
Poner splash screen con progress bar en delphi

Iniciado por ANTRAX

Respuestas: 0
Vistas: 2968
Último mensaje Febrero 24, 2010, 04:54:23 pm
por ANTRAX
[Delphi] Project Spartacus 1.0 (Regalo de Navidad)

Iniciado por BigBear

Respuestas: 2
Vistas: 1673
Último mensaje Diciembre 26, 2014, 11:54:34 pm
por n4pst3r