Получить иконку файла по ярлыку

Советы » ICO » Получить иконку файла по ярлыку

{ 
  Comment: 
  The procedure GetAssociatedIcon, trys via Registry to get the 
  icon(should work for small and big icons) that is associated with 
  the files shown in the explorer. 

  This is not my work. But I want to distribute it to you, because 
  it was really hard to find a corresonding document. 
  Thanks SuperTrax. 
}


 { 
  Kommentar: 
  Die Prozedure GetAssociatedIcon versucht uber die Registrierung 
  das Icon der Datei, wie im Explorer angezeigt, herauszubekommen. 
  (Sollte fur grosse und kleine funktionieren) 

  Dies ist nicht mein Werk. Ich mochte es nur fur andere zuganglich 
  machen, weil ich sehr lange gebraucht habe, um ein entsprechendes 
  Dokument zu finden. 
}

 unit

AIconos; interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, FileCtrl; type

TForm1 = class

(TForm) Button1: TButton; Image1: TImage; Image2: TImage; OpenDialog1: TOpenDialog; procedure

Button1Click(Sender: TObject); private

{ Private declarations } public

{ Public declarations } end

; type

PHICON = ^HICON; var

Form1: TForm1; PLargeIcon, PSmallIcon: phicon; implementation

uses

shellapi, registry; {$R *.DFM} procedure

GetAssociatedIcon(FileName: TFilename; PLargeIcon, PSmallIcon: PHICON); var

IconIndex: SmallInt; // Position of the icon in the file Icono: PHICON; // The LargeIcon parameter of ExtractIconEx FileExt, FileType: string

; Reg: TRegistry; p: Integer; p1, p2: PChar; buffer: array

[0..255] of

Char; Label

noassoc, NoSHELL; // ugly! but I use it, to not modify to much the original code :( begin

IconIndex := 0; Icono := nil

; // ;Get the extension of the file FileExt := UpperCase(ExtractFileExt(FileName)); if

((FileExt '.EXE') and

(FileExt '.ICO')) or

not

FileExists(FileName) then

begin

// If the file is an EXE or ICO and exists, then we can // extract the icon from that file. Otherwise here we try // to find the icon in the Windows Registry. Reg := nil

; try

Reg := TRegistry.Create; Reg.RootKey := HKEY_CLASSES_ROOT; if

FileExt = '.EXE' then

FileExt := '.COM'; if

Reg.OpenKeyReadOnly(FileExt) then

try

FileType := Reg.ReadString(''); finally

Reg.CloseKey; end

; if

(FileType <> '') and

Reg.OpenKeyReadOnly(FileType + 'DefaultIcon') then

try

FileName := Reg.ReadString(''); finally

Reg.CloseKey; end

; finally

Reg.Free; end

; // If there is not association then lets try to // get the default icon if

FileName = '' then

goto

noassoc; // Get file name and icon index from the association // ('"FileName",IconIndex') p1 := PChar(FileName); p2 := StrRScan(p1, ','); if

p2 nil

then

begin

p := p2 - p1 + 1; // Position de la coma IconIndex := StrToInt(Copy(FileName, p + 1, Length(FileName) - p)); SetLength(FileName, p - 1); end

; end

; //if ((FileExt '.EX ... // Try to extract the small icon if

ExtractIconEx(PChar(FileName), IconIndex, Icono^, PSmallIcon^, 1) <> 1 then

begin

noassoc: // That code is executed only if the ExtractIconEx return a value but 1 // There is not associated icon // try to get the default icon from SHELL32.DLL FileName := 'C:WindowsSystemSHELL32.DLL'; if

not

FileExists(FileName) then

begin

//If SHELL32.DLL is not in WindowsSystem then GetWindowsDirectory(buffer, SizeOf(buffer)); //Search in the current directory and in the windows directory FileName := FileSearch('SHELL32.DLL', GetCurrentDir + ';' + buffer); if

FileName = '' then

goto

NoSHELL; //the file SHELL32.DLL is not in the system end

; // Determine the default icon for the file extension if

(FileExt = '.DOC') then

IconIndex := 1 else

if

(FileExt = '.EXE') or

(FileExt = '.COM') then

IconIndex := 2 else

if

(FileExt = '.HLP') then

IconIndex := 23 else

if

(FileExt = '.INI') or

(FileExt = '.INF') then

IconIndex := 63 else

if

(FileExt = '.TXT') then

IconIndex := 64 else

if

(FileExt = '.BAT') then

IconIndex := 65 else

if

(FileExt = '.DLL') or

(FileExt = '.SYS') or

(FileExt = '.VBX') or

(FileExt = '.OCX') or

(FileExt = '.VXD') then

IconIndex := 66 else

if

(FileExt = '.FON') then

IconIndex := 67 else

if

(FileExt = '.TTF') then

IconIndex := 68 else

if

(FileExt = '.FOT') then

IconIndex := 69 else

IconIndex := 0; // Try to extract the small icon if

ExtractIconEx(PChar(FileName), IconIndex, Icono^, PSmallIcon^, 1) <> 1 then

begin

//That code is executed only if the ExtractIconEx return a value but 1 // Fallo encontrar el icono. Solo "regresar" ceros. NoSHELL: if

PLargeIcon nil

then

PLargeIcon^ := 0; if

PSmallIcon nil

then

PSmallIcon^ := 0; end

; end

; //if ExtractIconEx if

PSmallIcon^ 0 then

begin

//If there is an small icon then extract the large icon. PLargeIcon^ := ExtractIcon(Application.Handle, PChar(FileName), IconIndex); if

PLargeIcon^ = Null then

PLargeIcon^ := 0; end

; end

; procedure

TForm1.Button1Click(Sender: TObject); var

SmallIcon, LargeIcon: HIcon; Icon: TIcon; begin

if

not

(OpenDialog1.Execute) then

Exit; Icon := TIcon.Create; try

GetAssociatedIcon(OpenDialog1.FileName, @LargeIcon, @SmallIcon); if

LargeIcon <> 0 then

begin

Icon.Handle := LargeIcon; Image2.Picture.icon := Icon; end

; if

SmallIcon <> 0 then

begin

Icon.Handle := SmallIcon; Image1.Picture.icon := Icon; end

; finally

Icon.Destroy; end

; end

; end

.

Другое по теме:

Категории

Статьи

Советы

Copyright © 2022 - All Rights Reserved - www.delphirus.com