Türkiye'nin ilk Oyun Forumlarından olan Oyunsiteniz 17 Yasinda

OyunSiteniz ARŞİV Bölümü => GERİ DÖNÜŞÜM KUTUSU => Konuyu başlatan: nadir_pıero - 04 Aralık 2006, 08:53:55

Başlık: Programın/Dosyanın windows Default ikonunu bulup göstermek
Gönderen: nadir_pıero - 04 Aralık 2006, 08:53:55

{
orijinal kod
http://www.swissdelphicenter.ch/en/showcode.php?id=218
adresinden alınmıştır.
Fakat kod tam çalışmıyordu. Biraz değişiklik yaptım şuanda bütün dosyaların
ilişkili ikonlarını gösteriyor
}

unit Unit1;

interface

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

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;
  Icono: PHICON;
  FileExt, FileType: string;
  Reg: TRegistry;
  p: Integer;
  p1, p2: PChar;
  buffer: array [0..255] of Char;

Label
  noassoc, NoSHELL;
  IconIndex := 0;
  Icono := nil;
  // ;Get the extension of the file
  FileExt := UpperCase(ExtractFileExt(FileName));
  //Eğer uzantı EXE veya ICO ise dosyadan alabiliriz
  // aksi takdirde registry den almamız gerekiyor
 
  if ((FileExt<>'.EXE') and (FileExt<>'.ICO')) and FileExists(FileName) then
  begin
    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
        else
        if (FileType <> '') and Reg.OpenKeyReadOnly(FileType + '\Shell\Open\command') then
        try
          // bu kısım benim tarafımdan eklendir
          // eğer default icon yok ise o dosyayı açan programın iconunu gösteriyor
           FileName := Reg.ReadString('');
           delete(filename,pos('"',filename),1);
           if pos('"',filename)>0 then filename:=copy(filename,1,pos('"',filename)-1);
           if pos('%1',filename)>0 then filename:=copy(filename,1,pos('%1',filename)-1);
        finally
             Reg.CloseKey;
        end;

    finally
      Reg.Free;
    end;

    if FileName = '' then goto noassoc;
    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 ExtractIconEx(PChar(FileName), IconIndex, Icono^, PSmallIcon^, 1) <> 1 then
  begin
    noassoc:

    FileName := 'C:\Windows\System\SHELL32.DLL';
    if not FileExists(FileName) then
    begin
      GetWindowsDirectory(buffer, SizeOf(buffer));
      FileName := FileSearch('SHELL32.DLL', GetCurrentDir + ';' + buffer);
      if FileName = '' then
        goto NoSHELL;
    end;


    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;

    if ExtractIconEx(PChar(FileName), IconIndex, Icono^, PSmallIcon^, 1) <> 1 then
    begin
      NoSHELL:
      if PLargeIcon=nil then PLargeIcon^ := 0;
      if PSmallIcon=nil then PSmallIcon^ := 0;
    end;
  end;

  if PSmallIcon^<>0 then
  begin
    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.

Başlık: Programın/Dosyanın windows Default ikonunu bulup göstermek
Gönderen: LeGeND-MæN - 03 Mart 2007, 14:36:30

emeğine sağlık..

Başlık: Programın/Dosyanın windows Default ikonunu bulup göstermek
Gönderen: YuRY - 04 Mart 2007, 07:30:05

SAOL NADİR REP+

Başlık: Programın/Dosyanın windows Default ikonunu bulup göstermek
Gönderen: N0RM - 06 Nisan 2007, 21:39:03

paylaşım için saol