[Delphi] Sex Icons 0.1

Iniciado por BigBear, Agosto 09, 2013, 12:59:12 PM

Tema anterior - Siguiente tema

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

Un simple programa para buscar y extraer iconos.

Una imagen :



El codigo :

Código: delphi

// Sex Icons 0.1
// Coded By Doddy H

unit sex;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, jpeg, ExtCtrls, ComCtrls, StdCtrls, ShellAPI, ImgList;

type
  TForm1 = class(TForm)
    Image1: TImage;
    GroupBox1: TGroupBox;
    Label1: TLabel;
    Edit1: TEdit;
    ListView1: TListView;
    Button1: TButton;
    GroupBox2: TGroupBox;
    Button2: TButton;
    ImageList1: TImageList;
    GroupBox3: TGroupBox;
    Image2: TImage;

    Image3: TImage;
    SaveDialog1: TSaveDialog;
    procedure Button1Click(Sender: TObject);
    procedure ListView1DblClick(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  buscar: TSearchRec;
  Icon: TIcon;
  listate: TListItem;
  getdata: SHFILEINFO;
  dirnow: string;

begin

  dirnow := Edit1.Text;

  ListView1.Items.Clear;
  Icon := TIcon.Create;
  ListView1.Items.BeginUpdate;

  if FindFirst(dirnow + '*.*', faAnyFile, buscar) = 0 then
  begin
    repeat
      if (buscar.Attr <> faDirectory) then
      begin

        with ListView1 do
        begin

          listate := ListView1.Items.Add;

          SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata, SizeOf(getdata)
              , SHGFI_DISPLAYNAME);
          listate.Caption := buscar.Name;

          SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata, SizeOf(getdata)
              , SHGFI_TYPENAME);
          listate.SubItems.Add(getdata.szTypeName);

          SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata, SizeOf(getdata)
              , SHGFI_ICON or SHGFI_SMALLICON);
          Icon.Handle := getdata.hIcon;
          listate.ImageIndex := ImageList1.AddIcon(Icon);

          DestroyIcon(getdata.hIcon);

        end;

      end

      until FindNext(buscar) <> 0;
      FindClose(buscar);
    end;

    ListView1.Items.EndUpdate;

  end;

  procedure TForm1.Button2Click(Sender: TObject);
  begin

    if SaveDialog1.Execute then
    begin
      Image2.Picture.Icon.SaveToFile(SaveDialog1.FileName);
      ShowMessage('Icon Extracted');
    end;

  end;

  procedure TForm1.FormCreate(Sender: TObject);
  begin

    SaveDialog1.Title := 'Save your Icon';
    SaveDialog1.InitialDir := GetCurrentDir;
    SaveDialog1.DefaultExt := 'ico';

  end;

  procedure TForm1.ListView1DblClick(Sender: TObject);

  var
    acanow: TIcon;
    archivo: string;
    bajar: TSHFileInfo;

  begin

    archivo := Edit1.Text + ListView1.Selected.Caption;
    if FileExists(archivo) then
    begin
      acanow := TIcon.Create;
      SHGetFileInfo(PChar(archivo), 0, bajar, SizeOf(bajar), SHGFI_ICON);
      acanow.Handle := bajar.hIcon;
      Image2.Picture.Icon := acanow;
      acanow.Free;
    end;
  end;

end.

// The End ?


Si quieren bajarlo 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

Muy buen aporte!

Lo checaré, me vendrá fenomenal ;)


Saludos