【delphi开源代码栏目提醒】:网学会员,鉴于大家对delphi开源代码十分关注,论文会员在此为大家搜集整理了“frm_GetIcon.pas”一文,供大家参考学习!
unit frm_GetIcon;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, XPMan;
type ThIconArray = array[0..0] of hIcon;
type PhIconArray = ^ThIconArray;
type
TFrmGetIcon = class(TForm)
BtnListIcon: TButton;
Opend: TOpenDialog;
GBxIconList: TGroupBox;
Scroll: TScrollBox;
PaintX: TPaintBox;
BtnClose: TButton;
XPManifest1: TXPManifest;
procedure BtnListIconClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure PaintXPaint(Sender: TObject);
procedure BtnCloseClick(Sender: TObject);
private
bitmap:TBitMap;
procedure GetIconFromExe(ACanvas:TCanvas;ExeName:string;Wit:integer);
{ Private declarations }
public
{ Public declarations }
end;
var
FrmGetIcon: TFrmGetIcon;
implementation
{$R *.dfm}
function ExtractIconExA(lpszFile: PAnsiChar;
nIconIndex: Integer;
phiconLarge : PhIconArray;
phiconSmall: PhIconArray;
nIcons: UINT): UINT; stdcall;
external 'shell32.dll' name 'ExtractIconExA';
function ExtractIconExW(lpszFile: PWideChar;
nIconIndex: Integer;
phiconLarge: PhIconArray;
phiconSmall: PhIconArray;
nIcons: UINT): UINT; stdcall;
external 'shell32.dll' name 'ExtractIconExW';
function ExtractIconEx(lpszFile: PAnsiChar;
nIconIndex: Integer;
phiconLarge : PhIconArray;
phiconSmall: PhIconArray;
nIcons: UINT): UINT; stdcall;
external 'shell32.dll' name 'ExtractIconExA';
procedure TFrmGetIcon.GetIconFromExe(ACanvas:TCanvas;ExeName:string;Wit:integer);
var
NumIcons : integer;
pTheLargeIcons : phIconArray;
pTheSmallIcons : phIconArray;
LargeIconWidth,LargeIconHeight : integer;
SmallIconWidth : integer;
SmallIconHeight : integer;
i,x,y : integer;
TheIcon : TIcon;
TheBitmap : TBitmap;
begin
x:=0;
y:=0;
NumIcons := ExtractIconEx(pchar(ExeName),-1,
nil,nil,0);
if NumIcons > 0 then
begin
LargeIconWidth := GetSystemMetrics(SM_CXICON);
LargeIconHeight:= GetSystemMetrics(SM_CYICON);
SmallIconWidth := GetSystemMetrics(SM_CXSMICON);
SmallIconHeight := GetSystemMetrics(SM_CYSMICON);
GetMem(pTheLargeIcons, NumIcons * sizeof(hIcon));
GetMem(pTheSmallIcons, NumIcons * sizeof(hIcon));
FillChar(pTheLargeIcons^, NumIcons * sizeof(hIcon), #0);
FillChar(pTheSmallIcons^, NumIcons * sizeof(hIcon), #0);
ExtractIconEx(Pchar(ExeName),0,pTheLargeIcons,
pTheSmallIcons,numIcons);
{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}
for i := 0 to (NumIcons - 1) do
begin
DrawIcon(ACanvas.Handle,x * LargeIconWidth,
y*LargeIconWidth,pTheLargeIcons^[i]);
inc(X);
if (x+1)*LargeIconWidth > wit then
begin
x:=0;
inc(y);
end;
{TheIcon := TIcon. Create;
TheBitmap := TBitmap.Create;
TheIcon.Handle := pTheSmallIcons^[i];
TheBitmap.Width := TheIcon.Width;
TheBitmap.Height := TheIcon.Height;
TheBitmap.Canvas.Draw(0, 0, TheIcon);
TheIcon.Free;
Form1.Canvas.StretchDraw(Rect(i * SmallIconWidth,100,
(i + 1) * SmallIconWidth,100 + SmallIconHeight),TheBitmap);
TheBitmap.Free; }
end;
{$IFDEF CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
FreeMem(pTheLargeIcons, NumIcons * sizeof(hIcon));
FreeMem(pTheSmallIcons, NumIcons * sizeof(hIcon));
end;
end;
procedure TFrmGetIcon.BtnListIconClick(Sender: TObject);
begin
if OpenD.Execute then
begin
Bitmap.Canvas.FillRect(Bitmap.Canvas.ClipRect);
GetIconFromExe(Bitmap.Canvas,OpenD.FileName,Bitmap.Width);
Paintx.Canvas.Draw(0,0,Bitmap);
end;
end;
procedure TFrmGetIcon.FormCreate(Sender: TObject);
begin
bitmap:=TBitMap.Create;
Bitmap.Width:=Paintx.Width;
bitmap.Height:=Paintx.Height;
end;
procedure TFrmGetIcon.FormDestroy(Sender: TObject);
begin
Bitmap.Free;
end;
procedure TFrmGetIcon.PaintXPaint(Sender: TObject);
begin
Paintx.Canvas.Draw(0,0,Bitmap);
end;
procedure TFrmGetIcon.BtnCloseClick(Sender: TObject);
begin
Close;
end;
end.