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
  • 2360 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 No tienes permisos para ver links. Registrate o Entra con tu cuenta.

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!



Eliminar acentos y otros agregados de un caracter/cadena Delphi 2009

Iniciado por ANTRAX

Respuestas: 0
Vistas: 3126
Último mensaje Febrero 24, 2010, 04:57:14 pm
por ANTRAX
[Sintaxis general de Delphi] By: Geek Lord Venezuela [R00t] Team

Iniciado por ANTRAX

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

Iniciado por ANTRAX

Respuestas: 0
Vistas: 3254
Ú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: 1410
Ú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: 2574
Último mensaje Diciembre 28, 2015, 10:27:44 am
por BigBear