unitformextractico.pas

图象处理的一些相关内容 不是很难的,实现简单,希望对大家有帮助

unit UnitFormExtractIco;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, ImgList, ComCtrls,shellapi;

type
  TFormExtractIco = class(TForm)
    ListView1: TListView;
    ImageList1: TImageList;
    SaveDialog1: TSaveDialog;
    PopupMenu1: TPopupMenu;
    PopMenuSaveAs: TMenuItem;
    procedure PopMenuSaveAsClick(Sender: TObject);
    procedure ListView1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    procedure ExtractAndShowIco(FileName:string;AProgressBar:TProgressBar);

    { Public declarations }
  end;

var
  FormExtractIco: TFormExtractIco;

implementation

{$R *.dfm}

procedure TFormExtractIco.ExtractAndShowIco(FileName: string;
  AProgressBar: TProgressBar);
var
  Icons:Integer;
  i:Integer;
  Dummy:integer;
  //t:THandle;
  Icon:TIcon;
  //d:Hicon;
  hIcon:LongWord;
  bmp:Tbitmap;
  pFileName:Pchar;
begin
  pFileName:=pchar(FileName);
  Dummy:=-1;
  Icons:= ExtractIcon(application.Handle,pFileName,Dummy);

  ListView1.Items.Clear;
  ImageList1.Clear;

  bmp:=Tbitmap.Create;
  bmp.Height:=32;
  bmp.Width:=32;

  AProgressBar.Visible:=true;
  AProgressBar.Max:=Icons;
  for i := 0 To Icons - 1 do
  begin
    hIcon:=ExtractIcon(application.Handle,pFileName,i);
    Bmp.Canvas.Brush.Color :=clwhite;
    Bmp.Canvas.FillRect(Bmp.Canvas.ClipRect);
    DrawIcon(bmp.Canvas.Handle,0,0,hIcon);
    DestroyIcon(hIcon);

    ImageList1.Add(bmp,nil);
    with ListView1.Items.Add do
    begin
      ImageIndex:=i;
      caption:=inttostr(i);
    end;
    AProgressBar.Position:=i;
  end;

  AProgressBar.Visible:=false;
  bmp.Free;
end;


procedure TFormExtractIco.PopMenuSaveAsClick(Sender: TObject);
var
  Icon:TIcon;
begin
  Icon:=TIcon.Create;

  ImageList1.GetIcon(listview1.Selected.Index,Icon);


  if SaveDialog1.Execute then
  begin
    if (LowerCase(ExtractFileExt(SaveDialog1.FileName))='.ico') then
      begin
        if FileExists(SaveDialog1.FileName) then
          if MessageDlg('文件：'+SaveDialog1.FileName+'已经存在，是否覆盖？',mtInformation,[mbYes,MbNo],0)=mrYes then
            icon.SaveToFile(SaveDialog1.FileName)
          else
            exit
        else
          icon.SaveToFile(SaveDialog1.FileName);
      end
      else
        if FileExists(SaveDialog1.FileName+'.ico') then
          if MessageDlg('文件：'+SaveDialog1.FileName+'.ico'+'已经存在，是否覆盖？',mtInformation,[mbYes,MbNo],0)=mrYes then
            icon.SaveToFile(SaveDialog1.FileName+'.ico')
          else
            exit
        else
          icon.SaveToFile(SaveDialog1.FileName+'.ico');

  end;
  icon.Free;
end;

procedure TFormExtractIco.ListView1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  ScreenPoint:TPoint;
begin
  if (button=mbRight) and (listview1.SelCount>0) then
  begin
    ScreenPoint:=listview1.ClientToScreen(Point(x,y));

    PopupMenu1.Popup(ScreenPoint.x,ScreenPoint.y);

  end;

end;

end.