Foro de elhacker.net

Programación => Programación General => Mensaje iniciado por: BigBear en 9 Agosto 2013, 17:59 pm


Título: [Delphi] Sex Icons 0.1
Publicado por: BigBear en 9 Agosto 2013, 17:59 pm
Un simple programa para buscar y extraer iconos.

Una imagen :

(http://doddyhackman.webcindario.com/images/sexdelphi.jpg)

El codigo :

Código
  1. // Sex Icons 0.1
  2. // Coded By Doddy H
  3.  
  4. unit sex;
  5.  
  6. interface
  7.  
  8. uses
  9.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  10.   Dialogs, jpeg, ExtCtrls, ComCtrls, StdCtrls, ShellAPI, ImgList;
  11.  
  12. type
  13.   TForm1 = class(TForm)
  14.     Image1: TImage;
  15.     GroupBox1: TGroupBox;
  16.     Label1: TLabel;
  17.     Edit1: TEdit;
  18.     ListView1: TListView;
  19.     Button1: TButton;
  20.     GroupBox2: TGroupBox;
  21.     Button2: TButton;
  22.     ImageList1: TImageList;
  23.     GroupBox3: TGroupBox;
  24.     Image2: TImage;
  25.  
  26.     Image3: TImage;
  27.     SaveDialog1: TSaveDialog;
  28.     procedure Button1Click(Sender: TObject);
  29.     procedure ListView1DblClick(Sender: TObject);
  30.     procedure Button2Click(Sender: TObject);
  31.     procedure FormCreate(Sender: TObject);
  32.   private
  33.     { Private declarations }
  34.   public
  35.     { Public declarations }
  36.   end;
  37.  
  38. var
  39.   Form1: TForm1;
  40.  
  41. implementation
  42.  
  43. {$R *.dfm}
  44.  
  45. procedure TForm1.Button1Click(Sender: TObject);
  46. var
  47.   buscar: TSearchRec;
  48.   Icon: TIcon;
  49.   listate: TListItem;
  50.   getdata: SHFILEINFO;
  51.   dirnow: string;
  52.  
  53. begin
  54.  
  55.   dirnow := Edit1.Text;
  56.  
  57.   ListView1.Items.Clear;
  58.   Icon := TIcon.Create;
  59.   ListView1.Items.BeginUpdate;
  60.  
  61.   if FindFirst(dirnow + '*.*', faAnyFile, buscar) = 0 then
  62.   begin
  63.     repeat
  64.       if (buscar.Attr <> faDirectory) then
  65.       begin
  66.  
  67.         with ListView1 do
  68.         begin
  69.  
  70.           listate := ListView1.Items.Add;
  71.  
  72.           SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata, SizeOf(getdata)
  73.               , SHGFI_DISPLAYNAME);
  74.           listate.Caption := buscar.Name;
  75.  
  76.           SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata, SizeOf(getdata)
  77.               , SHGFI_TYPENAME);
  78.           listate.SubItems.Add(getdata.szTypeName);
  79.  
  80.           SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata, SizeOf(getdata)
  81.               , SHGFI_ICON or SHGFI_SMALLICON);
  82.           Icon.Handle := getdata.hIcon;
  83.           listate.ImageIndex := ImageList1.AddIcon(Icon);
  84.  
  85.           DestroyIcon(getdata.hIcon);
  86.  
  87.         end;
  88.  
  89.       end
  90.  
  91.       until FindNext(buscar) <> 0;
  92.       FindClose(buscar);
  93.     end;
  94.  
  95.     ListView1.Items.EndUpdate;
  96.  
  97.   end;
  98.  
  99.   procedure TForm1.Button2Click(Sender: TObject);
  100.   begin
  101.  
  102.     if SaveDialog1.Execute then
  103.     begin
  104.       Image2.Picture.Icon.SaveToFile(SaveDialog1.FileName);
  105.       ShowMessage('Icon Extracted');
  106.     end;
  107.  
  108.   end;
  109.  
  110.   procedure TForm1.FormCreate(Sender: TObject);
  111.   begin
  112.  
  113.     SaveDialog1.Title := 'Save your Icon';
  114.     SaveDialog1.InitialDir := GetCurrentDir;
  115.     SaveDialog1.DefaultExt := 'ico';
  116.  
  117.   end;
  118.  
  119.   procedure TForm1.ListView1DblClick(Sender: TObject);
  120.  
  121.   var
  122.     acanow: TIcon;
  123.     archivo: string;
  124.     bajar: TSHFileInfo;
  125.  
  126.   begin
  127.  
  128.     archivo := Edit1.Text + ListView1.Selected.Caption;
  129.     if FileExists(archivo) then
  130.     begin
  131.       acanow := TIcon.Create;
  132.       SHGetFileInfo(PChar(archivo), 0, bajar, SizeOf(bajar), SHGFI_ICON);
  133.       acanow.Handle := bajar.hIcon;
  134.       Image2.Picture.Icon := acanow;
  135.       acanow.Free;
  136.     end;
  137.   end;
  138.  
  139. end.
  140.  
  141. // The End ?
  142.  

Si quieren bajarlo lo pueden hacer de aca (https://sourceforge.net/projects/sexicons/)


Powered by SMF 1.1.21 | SMF © 2006-2008, Simple Machines