extractfrm.pas

图标提取器源码 非常管用．大家试试

unit ExtractFrm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, ImgList, ToolWin, ShellApi, ExtCtrls, FileCtrl;

type
  TExIconForm = class(TForm)
    LargeImage: TImageList;
    ListView1: TListView;
    SmallImage: TImageList;
    OpenDialog1: TOpenDialog;
    ProgressBar1: TProgressBar;
    Panel1: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure ExtractFromFile;
    procedure SaveIcon;
    procedure saveTobmp;
    procedure FormShow(Sender: TObject);
    procedure WMMove(var msg:tmessage);message WM_Move;
    procedure FormActivate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }

    procedure ExtractIconFromFile(FileName: PChar; IconNum: Integer);
   // function extractIconEx(lpsizefile:pansichar;niconindex:integer;phiconlarge:pIconArray;phIconsmall:piconarray;nicons:uint):uint;stdcall;external 'shell32.dll' name 'ExtracticonexA';
  end;

var
  ExIconForm: TExIconForm;
  IconTotalNum,Totol: integer;
  small:boolean;
implementation

uses UMain;



{$R *.DFM}

procedure TExIconForm.FormCreate(Sender: TObject);
begin
  left:=frmMain.left;
  top:=frmMain.top+frmMain.height;
  width:=frmMain.Width;
  small:=false;
  exiconform.ListView1.ViewStyle:=vsicon;
end;




procedure TExIconForm.ExtractIconFromFile(FileName: Pchar; IconNum: Integer);
var
  Icon: TIcon;
  i: integer;
  ListItem: TListItem;
  //pLargeIcons:Array of hicon;
begin
  Icon := TIcon.Create;

  for i := 0 to IconNum -1 do
  begin
    Inc(IconTotalNum);
    if IconTotalNum > 1000 then
    begin
      if Application.MessageBox('由于图标数量太多，请先保存已解出的图标。',
                                '消息框',
                                MB_OKCANCEL + MB_DEFBUTTON1 + MB_ICONINFORMATION) = IDOK then
        SaveIcon;
      IconTotalNum := 1;
      ListView1.Items.Clear;
      ListView1.Update;
      LargeImage.Clear;
      smallImage.Clear;
    end;
    Icon.Handle := ExtractIcon(hInstance,FileName,i);
    //icon.Handle:=extractIconEx(
    if small=true then smallimage.AddIcon(icon)
    else LargeImage.AddIcon(Icon);
    ListItem := Listview1.Items.Add;

    ListItem.Caption := IntToStr(IconTotalNum) + ':' + string(FileName) ;
    ListItem.ImageIndex := IconTotalNum - 1;
    Icon.ReleaseHandle;
  end;
  Icon.Free;
end;

procedure TExIconForm.ExtractFromFile;
var
  PFileName: PChar;
  IconNum,i: integer;
 // pLargeIcon:array of hicon;
 // psmallicon:array of hicon;
begin
  if OpenDialog1.Execute then
  begin
    ListView1.Items.Clear;
    smallImage.Clear;
    LargeImage.Clear;
    IconTotalNum := 0;
    Totol := 0;
    for i := 0 to OpenDialog1.Files.Count -1 do
    begin
      PFileName := PChar(OpenDialog1.Files[i]);
     IconNum := ExtractIcon(hInstance,PFileName,UINT(-1));
     // iconNum:=extracticonex(PFileName,1,nil,nil,Unit(1));
      ExtractIconFromFile(PFileName,IconNum);
    end;
  end;
end;



procedure TExIconForm.SaveIcon;
var
  i: integer;
  Icon: TIcon;
  SavePath: string;
begin
  if (LargeImage.Count=0) and (smallimage.Count=0) then
  begin
    Application.MessageBox('请解出图标!',
                           '消息框',
                            MB_OK + MB_DEFBUTTON1 + MB_ICONINFORMATION);
    Exit;
  end;
  SelectDirectory('请选择保存路径：','我的电脑',SavePath);
  if SavePath <> '' then
  begin
    if SavePath[Length(SavePath)] = '\' then
      SavePath := Copy(SavePath,1,Length(SavePath)-1);
    Icon := TIcon.Create;
    if small=false then
     for i := 0 to LargeImage.Count - 1 do
     begin
     largeimage.GetIcon(i,icon);
      Icon.SaveToFile(SavePath + '\' + IntToStr(i + 1) + '.ico');
     Icon.ReleaseHandle;
     end
    else
     for i := 0 to smallImage.Count - 1 do
     begin
      smallimage.GetIcon(i,icon);
      Icon.SaveToFile(SavePath + '\' + IntToStr(i + 1) + '.ico');
      Icon.ReleaseHandle;
     end;
   Icon.Free;
  end;
end;

procedure TExIconForm.saveTobmp;     //另存为bmp格式，但未能实现
var
  i:integer;
  bmp:tbitmap;
  ico:ticon;
  rect1,rect2:trect;
 // stream,stream2:Tstream;
  SavePath: string;
  canvas:tcanvas;
begin
  if LargeImage.Count = 0 then
  begin
    Application.MessageBox('请解出图标!',
                           '消息框',
                            MB_OK + MB_DEFBUTTON1 + MB_ICONINFORMATION);
    Exit;
  end;
  SelectDirectory('请选择保存路径：','我的电脑',SavePath);
  if SavePath <> '' then
  begin
    if SavePath[Length(SavePath)] = '\' then
      SavePath := Copy(SavePath,1,Length(SavePath)-1);

    canvas:=tcanvas.Create;
    bmp:=tbitmap.Create;
    ico:=ticon.Create;
    for i := 0 to LargeImage.Count - 1 do
    begin
     try
      LargeImage.GetIcon(i,Ico);
      //stream:=tstream.Create;
     // stream2:=tstream.Create;
     // ico.SaveToStream(stream);
      //canvas.Draw(0,0,ico);
       with rect1 do
       begin
        left:=0;
        top:=0;
        right:=ico.Width;
        bottom:=ico.Height;
       end;
        with rect2 do
       begin
        left:=0;
        top:=0;
        right:=ico.Width;
        bottom:=ico.Height;
       end;
      Canvas.Draw(0,0,ico);
       bmp.Canvas.Draw(0,0,ico);

     //  bmp.Canvas.CopyRect(rect2,canvas,rect1);
      //bmp.LoadFromStream(stream);
       bmp.SaveToFile(SavePath + '\' + IntToStr(i + 1) + '.bmp');
      Ico.ReleaseHandle;
     // stream.Free;
     except on e:exception do
      showmessage(e.Message);
     end;
    end;
   Ico.Free;
   bmp.Free;
 end;
end;

procedure TExIconForm.FormShow(Sender: TObject);
begin

   left:=frmmain.Left;
   top:=frmmain.Top+frmMain.Height;
   width:=frmMain.Width;
end;

procedure TExIconForm.WMMove(var msg: tmessage);
begin
  inherited;
  if (abs(left-frmMain.Left)<20) and (abs(top-frmMain.Top-frmMain.Height)<20) then
  begin
    left:=frmMain.left;
    top:=frmMain.top+frmMain.height;
    msg.Result:=0;      //消息已处理
  end;
end;

procedure TExIconForm.FormActivate(Sender: TObject);
begin
   left:=frmmain.Left;
   top:=frmmain.Top+frmMain.Height;
   width:=frmMain.Width;
end;

end.