[AlexSku]

Пример из книги "Delphi для чайников":

Код:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ShellAPI, StdCtrls, Grids, ExtCtrls;

type
  TForm1 = class(TForm)
    Bevel1: TBevel;
    StringGrid1: TStringGrid;
    OpenDialog1: TOpenDialog;
    Button1: TButton;
    SaveDialog1: TSaveDialog;
    Button2: TButton;
    procedure Button2Click(Sender: TObject);
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  pName : Array[0..255] of Char;
  fName : String[13];
  N : Word;
  IcoH : hIcon;
  CurItem : LongInt;
begin
  with OpenDialog1 do
    begin
      if not Execute then exit;
      fName := ExtractFilename(Filename);
      StrPCopy(pName, Filename);
    end;
    CurItem := 0;
    N := 0;
with StringGrid1 do
  repeat
    IcoH := ExtractIcon(hInstance, pName, N);
    if IcoH <= 1 then Break;
    Col := CurItem mod ColCount;
    if (CurItem div ColCount) >= RowCount then
      RowCount := RowCount + 1;
    Row := CurItem div ColCount;
    Cells[Col,Row] := fName + ' #' + IntToStr(N);
    Objects[Col, Row] := TIcon.Create;
    with Objects[Col, Row] as TIcon do
      Handle := IcoH;
      CurItem := CurItem + 1;
    N := N + 1;
  until False;
end;
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
if StringGrid1.Objects[ACol, ARow] is TIcon then
  StringGrid1.Canvas.Draw(Rect.Left+56, Rect.Top+24,
    TIcon(StringGrid1.Objects[ACol, ARow]));
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if SaveDialog1.Execute then
  with StringGrid1 do
    with Objects[Col,Row] as TIcon do
      SaveToFile(SaveDialog1.Filename);
end;

end.

Код:

object Form1: TForm1
  Left = 279
  Top = 246
  Width = 610
  Height = 345
  Caption = 'Коллекционер значков'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Bevel1: TBevel
    Left = 0
    Top = 0
    Width = 602
    Height = 50
    Align = alTop
    Shape = bsFrame
  end
  object StringGrid1: TStringGrid
    Left = 0
    Top = 50
    Width = 602
    Height = 268
    Align = alClient
    ColCount = 4
    DefaultColWidth = 144
    DefaultRowHeight = 64
    FixedCols = 0
    RowCount = 4
    FixedRows = 0
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine]
    ParentFont = False
    TabOrder = 0
    OnDrawCell = StringGrid1DrawCell
  end
  object Button1: TButton
    Left = 8
    Top = 8
    Width = 113
    Height = 25
    Caption = '&Собрать значки...'
    TabOrder = 1
    OnClick = Button1Click
  end
  object Button2: TButton
    Left = 480
    Top = 8
    Width = 113
    Height = 25
    Caption = 'Со&хранить значок...'
    TabOrder = 2
    OnClick = Button2Click
  end
  object OpenDialog1: TOpenDialog
    DefaultExt = 'ICO'
    Filter = 'Все файлы значков|*.ICO;*.EXE;*.DLL|Все файлы|*.*'
    InitialDir = 'C:\WINDOWS'
    Options = [ofHideReadOnly, ofFileMustExist, ofEnableSizing]
    Title = 'Открыть файл значка'
    Left = 544
    Top = 208
  end
  object SaveDialog1: TSaveDialog
    DefaultExt = 'ICO'
    Options = [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofEnableSizing]
    Title = 'Сохранить файл значка'
    Left = 504
    Top = 208
  end
end