unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ComCtrls, ExtDlgs;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    OpenPictureDialog1: TOpenPictureDialog;
    OpenDialog1: TOpenDialog;
    RadioGroup1: TRadioGroup;
    GroupBox1: TGroupBox;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    CheckBox3: TCheckBox;
    CheckBox4: TCheckBox;
    CheckBox5: TCheckBox;
    CheckBox6: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure RadioGroup1Click(Sender: TObject);
  private
    { Private 宣言 }
    InitDir      : String;
    FileFullPath : String;
    BmpTThumnail : TBitmap;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses plImageExtract, FileCtrl, ShlObj, JPeg;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  InitDir := '';

  if CheckWin32Version(6, 0) then begin
    //Windows 7の特大アイコンと同じサイズ
    RadioGroup1.ItemIndex := 3;
    GroupBox1.Visible := False;
  end else begin
    RadioGroup1.ItemIndex := 2;
    //IEIFLAG_ASPECT or IEIFLAG_OFFLINE
    GroupBox1.Enabled := True;
    CheckBox1.Checked := True;
    CheckBox2.Checked := True;
  end;

  BmpTThumnail := TBitmap.Create;
  BmpTThumnail.PixelFormat := pf32bit;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if Assigned(BmpTThumnail) then FreeAndNil(BmpTThumnail);
end;

//=============================================================================
//  Button1のOnClickとButton2のOnClick共有イベント
//  サムネイル画像を取得してTImageに表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  ImageWidth  : Integer;
  ImageHeight : Integer;
  Flags       : Cardinal;
begin
  if InitDir = '' then InitDir := ExtractFileDir(Application.ExeName);

  //ファイル名またはフォルダ名選択ダイアログを表示して選択
  //Windows XPでは画像以外のファイルのサムネイルは取得できない
  if Sender <> nil then begin
    if Sender = Button1 then begin
      if CheckWin32Version(6, 0) then begin
        OpenDialog1.InitialDir := InitDir;
        if OpenDialog1.Execute then begin
          FileFullPath := OpenDialog1.FileName;
        end else begin
          exit;
        end;
      end else begin
        OpenPictureDialog1.InitialDir := InitDir;
        if OpenPictureDialog1.Execute then begin
          FileFullPath := OpenPictureDialog1.FileName;
        end else begin
          exit;
        end;
      end;
      InitDir := ExtractFileDir(FileFullPath);
    end else begin
      if SelectDirectory('フォルダ指定', '', InitDir) then begin
        FileFullPath := ExcludeTrailingPathDelimiter(InitDir);
        InitDir      := ExcludeTrailingPathDelimiter(FileFullPath);
      end else begin
        exit;
      end;
    end;
  end;

  //取得するサムネイル画像のサイズを指定
  //フラグの指定によっては，必ずしもこの値で取得できるわけではない
  case RadioGroup1.ItemIndex of
    0:
    begin
      ImageWidth  := 96;
      ImageHeight := 96;
    end;
    1:
    begin
      ImageWidth  := 128;
      ImageHeight := 128;
    end;
    2:
    begin
      ImageWidth  := 192;
      ImageHeight := 192;
    end;
    3:
    begin
      ImageWidth  := 256;
      ImageHeight := 256;
    end;
    4:
    begin
      ImageWidth  := 320;
      ImageHeight := 320;
    end;
    5:
    begin
      ImageWidth  := 512;
      ImageHeight := 512;
    end;
    6:
    begin
      ImageWidth  := 256;
      ImageHeight := 120;
    end;
    7:
    begin
      ImageWidth  := 120;
      ImageHeight := 256;
    end;
  else
    ImageWidth  := 128;
    ImageHeight := 128;
  end;


  //サムネイル画像取得のフラグ
  //以下の定数値の使用にはusesにShlObjが必要

  //Windows Vista以降の場合
  if CheckWin32Version(6, 0) then begin
    Flags := SIIGBF_RESIZETOFIT;
  end else begin
    Flags := 0;
    if CheckBox1.Checked then Flags := Flags or IEIFLAG_ASPECT;
    if CheckBox2.Checked then Flags := Flags or IEIFLAG_OFFLINE;
    if CheckBox3.Checked then Flags := Flags or IEIFLAG_ORIGSIZE;
    if CheckBox4.Checked then Flags := Flags or IEIFLAG_QUALITY;
    if CheckBox5.Checked then Flags := Flags or IEIFLAG_REFRESH;
    if CheckBox6.Checked then Flags := Flags or IEIFLAG_SCREEN;
  end;

  //サムネイル画像をBmpThamnailに取得してTImageに表示
  //添付のplImageExtract.pas内の関数を使用
  if ExtractImage(FileFullPath,
                  BmpTThumnail,
                  ImageWidth,
                  ImageHeight,
                  Flags) then begin
    if CheckWin32Version(6, 0) then begin
      //SetAlphaColorはplImageExtract.pas内の関数
      //これを実行しないと，TListViewでは透明部分が黒で表示される
      SetAlphaColor(BmpTThumnail, clWhite);
    end else begin
      BmpTThumnail.Transparent := True;
    end;

    //Delphi2009以上
    {$IF CompilerVersion >= 20.9}
    BmpTThumnail.AlphaFormat := afDefined;
    {$IFEND}

    Image1.Picture.Assign(BmpTThumnail);

    //フォームのCaptionに取得したビットマップのサイズとファイル名を表示
    Caption := IntToStr(Image1.Picture.Bitmap.Width)  + ' X ' +
               IntToStr(Image1.Picture.Bitmap.Height) + '   ' +
               ExtractFileName(FileFullPath);
  end else begin
    Image1.Picture.Assign(nil);
  end;
end;

//=============================================================================
//  RadioGroup1のOnClickイベント
//  RadioGroup1と他のチェックボックスの全てのOnClick共有イベント
//
//  RadioGroup1とTCheckBoxのチェックを変更したらサムネイル画像を再読み込み
//=============================================================================
procedure TForm1.RadioGroup1Click(Sender: TObject);
begin
  if FileFullPath = '' then exit;
  Button1Click(nil);
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, ImgList, 
  plImageExtract, plThumImgList;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    ListView1: TListView;
    Button1: TButton;
    StatusBar1: TStatusBar;
    ImageList1: TImageList;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure ListView1Data(Sender: TObject; Item: TListItem);
    procedure ListView1Resize(Sender: TObject);
    procedure ListView1DataHint(Sender: TObject; StartIndex, EndIndex: Integer);
  private
    { Private 宣言 }
    InitDir     : String;
    FThumbList  : TplThumbnailList;
    ImageWidth  : Integer;
    ImageHeight : Integer;
    procedure SetThumbnailList(AFolder: String);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses CommCtrl, FileCtrl, ShlObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//
//  使用しているTListViewは，AliginプロパティをalClientにしている以外はデフォ
//  ルトの設定のままで，このOnCreateで設定している
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  W : Integer;
  H : Integer;
begin
  InitDir := '';

  //画像サイズの設定
  //Windows Vista以降では256(特大アイコンサイズ)とする
  if CheckWin32Version(6, 0) then begin
    ImageWidth  := 256;
  end else begin
    ImageWidth  := 128;
  end;
  ImageHeight           := ImageWidth;
  ImageList1.Width      := ImageWidth;
  ImageList1.Height     := ImageHeight;
  ListView1.LargeImages := ImageList1;

  //チラつき防止
  ListView1.DoubleBuffered := True;
  //仮想リストビューにする設定等
  ListView1.ViewStyle := vsIcon;
  ListView1.OwnerData := True;
  ListView1.OwnerDraw := False;

  //画像間のスペースの設定
  W := ImageWidth  + 30;
  H := ImageHeight + 30;
  ListView_SetIconSpacing(ListView1.Handle, W, H);

  //リスト管理用のリストを作成
  //TplThumbnailListは別ユニットで提供
  FThumbList := TplThumbnailList.Create(True);
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  FThumbList.Free;
end;

//=============================================================================
//  取得先のフォルダー指定
//  SelectDirectoryにはusesにFileCtrlが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if FileCtrl.SelectDirectory('フォルダ指定',  '', InitDir) then begin
    InitDir := IncludeTrailingPathDelimiter(InitDir);
    SetThumbnailList(InitDir);
  end;
end;

//=============================================================================
//  フォルダ内のファイルを検索してファイル名をリストにセット
//  縮小画像はOnDataHintイベントで取得する
//=============================================================================
procedure TForm1.SetThumbnailList(AFolder: String);
var
  SearchRec : TSearchRec;
  AItem     : TplThumbnailItem;
begin
  StatusBar1.Panels[0].Text := '';

  ListView1.Items.Clear;
  ImageList1.Clear;
  ListView1.Items.Clear;
  FThumbList.Clear;
  ListView1.Update;
  ListView1.Items.BeginUpdate;

  //まずフォルダAFolder内の全てのファイルのリストを作成
  AFolder := IncludeTrailingPathDelimiter(AFolder);
  if FindFirst(AFolder + '*', faDirectory, SearchRec) = 0 then begin
    repeat
      if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then begin
        AItem                := TplThumbnailItem.Create(Self);
        AItem.ImageIndex     := -1;
        AItem.Bitmap         := nil;
        AItem.FileName       := ExtractFileName(SearchRec.Name);
        FThumbList.Add(AItem);
      end;
      Application.ProcessMessages;
    until FindNext(SearchRec) <> 0;
    FindClose(SearchRec);
  end;

  ListView1.Items.EndUpdate;

  ListView1.Items.Count := FThumbList.Count;
  ListView1.Items[0].MakeVisible(False);

  ListView1.Refresh;
  StatusBar1.Panels[0].Text := '   ' + IntToStr(FThumbList.Count);
end;

//=============================================================================
//  TListViewのOnDaDataイベント処理
//  Itemの描画が必要になった時に，描画前に1回発生する
//  TListViewの各ITemのImageIndexプロパティにImageのインデックスを代入
//
//  OnDataイベントはTListViewのOwnerDataがTrueの場合にのみ発生する
//=============================================================================
procedure TForm1.ListView1Data(Sender: TObject; Item: TListItem);
var
  AIndex : Integer;
begin
  AIndex := Item.Index;
  if AIndex > (FThumbList.Count - 1) then exit;

  //縮小画像が取得済みの時だけ実行
  if FThumbList.Items[AIndex].ImageIndex >= 0 then begin
    Item.ImageIndex := FThumbList.Items[AIndex].ImageIndex;
    Item.Caption    := FThumbList.Items[AIndex].FileName;
  end;
end;

//=============================================================================
//  TListViewのOnDataHintイベント処理
//  TImageListに格納するビットマップを作成して格納
//
//  OnDataHintイベントはTListViewのOwnerDataがTrueの場合にのみ発生する
//=============================================================================
procedure TForm1.ListView1DataHint(Sender: TObject; StartIndex,
  EndIndex: Integer);
var
  AIndex    : Integer;
  AFileName : String;
  Bmp       : TBitmap;
  ImgBmp    : TBitmap;
  Flags     : Cardinal;
  StartX    : Integer;
  StartY    : Integer;
begin
  for AIndex := EndIndex downto StartIndex do begin
    //[リストのインデックスが範囲を超えています]に対する対策
    if AIndex > (FThumbList.Count - 1) then exit;

    AFileName := FThumbList.Items[AIndex].FileName;
    //縮小画像が未取得の時だけ取得
    if FThumbList.Items[AIndex].ImageIndex = -1 then begin
      Bmp    := TBitmap.Create;
      ImgBmp := TBitmap.Create;
      ImgBmp.Width  := ImageWidth;
      ImgBmp.Height := ImageHeight;
      try
        //Windows Vista以降
        if CheckWin32Version(6, 0) then begin
          Flags := SIIGBF_RESIZETOFIT;
        end else begin
          Flags := IEIFLAG_ASPECT or IEIFLAG_CACHE or IEIFLAG_QUALITY;
        end;

        //サムネイル画像(縮小表示画像)のビットマップを取得
        //この取得に時間がかかる
        if ExtractImage(InitDir + AFileName,
                        Bmp,
                        ImageWidth,
                        ImageHeight,
                        Flags) then begin

          //上下左右の中央に表示するために表示開始位置を計算
          StartX := 0;
          StartY := 0;
          if ImageWidth >= Bmp.Width then begin
            if ImageHeight > Bmp.Height then begin
              StartY := (ImageHeight - Bmp.Height) div 2;
            end;
          end else begin
            if ImageHeight > Bmp.Width then begin
              StartX := (ImageWidth - Bmp.Width) div 2;
            end;
          end;

          ImgBmp.Canvas.Draw(StartX, StartY, Bmp);
          //Windows Vista以降ではアルファーチャンネル処理
          //SetAlphaColorはplImageExtract.pas内の関数
          //これを実行しないと，TListViewでは透明部分が黒で表示される
          if CheckWin32Version(6, 0) then begin
            SetAlphaColor(ImgBmp, clNone);
          end;
          ImageList1.Add(ImgBmp, nil);

          //TImageListの順番は取得した順番となる
          FThumbList.Items[AIndex].ImageIndex := ImageList1.Count - 1;
        end else begin
          //画像がない項目は削除
          FThumbList.Delete(AIndex);
          TListView(Sender).Items.Count := FThumbList.Count;
          StatusBar1.Panels[0].Text := '   ' + IntToStr(FThumbList.Count);
        end;
      finally
        FreeAndNil(Bmp);
        FreeAndNil(ImgBmp);
      end;
    end;
  end;
end;

//=============================================================================
//  TListViewのOnResizeイベント処理
//  ランタイムテーマ(Delphi 7 ではusesにXPManがある場合)
//  リサイズすると描画されない部分があるのでRefresh
//=============================================================================
procedure TForm1.ListView1Resize(Sender: TObject);
begin
  ListView1.Repaint;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, ImgList,
  plImageExtract, plThumImgList;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    ListView1: TListView;
    Button1: TButton;
    StatusBar1: TStatusBar;
    ImageList1: TImageList;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure ListView1CustomDrawItem(Sender: TCustomListView; Item: TListItem;
      State: TCustomDrawState; var DefaultDraw: Boolean);
    procedure ListView1DataHint(Sender: TObject; StartIndex, EndIndex: Integer);
    procedure ListView1Resize(Sender: TObject);
  private
    { Private 宣言 }
    InitDir     : String;
    FThumbList  : TplThumbnailList;
    ImageWidth  : Integer;
    ImageHeight : Integer;
    procedure SetThumbnailList(AFolder: String);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses CommCtrl, FileCtrl, ShlObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//
//  使用しているTListViewは，AliginプロパティをalClientにしている以外はデフォ
//  ルトの設定のままで，このOnCreateで設定している
//
//  TImageListは画像サイズの設定に使用しているたけで，画像は代入しない
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  W : Integer;
  H : Integer;
begin
  InitDir := '';

  //画像サイズの設定
  //Windows Vista以降では256(特大アイコンサイズ)とする
  if CheckWin32Version(6, 0) then begin
    ImageWidth  := 256;
  end else begin
    ImageWidth  := 128;
  end;
  ImageHeight           := ImageWidth;
  ImageList1.Width      := ImageWidth;
  ImageList1.Height     := ImageHeight;
  ListView1.LargeImages := ImageList1;

  //チラつき防止
  ListView1.DoubleBuffered := True;
  //仮想リストビューにする設定等
  ListView1.ViewStyle := vsIcon;
  ListView1.OwnerData := True;
  ListView1.OwnerDraw := False;

  //画像間のスペースの設定
  W := ImageWidth  + 30;
  H := ImageHeight + 30;
  ListView_SetIconSpacing(ListView1.Handle, W, H);

  //リスト管理用のリストを作成
  //TplThumbnailListは別ユニットで提供
  FThumbList := TplThumbnailList.Create(True);
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  FThumbList.Free;
end;

//=============================================================================
//  取得先のフォルダー指定
//  SelectDirectoryにはusesにFileCtrlが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if FileCtrl.SelectDirectory('フォルダ指定',  '', InitDir) then begin
    InitDir := IncludeTrailingPathDelimiter(InitDir);
    SetThumbnailList(InitDir);
  end;
end;

//=============================================================================
//  フォルダ内のファイルを検索してファイル名をリストにセット
//  縮小画像はOnDataHintイベントで取得する
//=============================================================================
procedure TForm1.SetThumbnailList(AFolder: String);
var
  SearchRec : TSearchRec;
  AItem     : TplThumbnailItem;
begin
  StatusBar1.Panels[0].Text := '';

  ListView1.Items.Clear;
  FThumbList.Clear;
  ListView1.Update;
  ListView1.Items.BeginUpdate;

  //まずフォルダAFolder内の全てのファイルのリストを作成
  AFolder := IncludeTrailingPathDelimiter(AFolder);
  if FindFirst(AFolder + '*', faDirectory, SearchRec) = 0 then begin
    repeat
      if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then begin
        AItem                := TplThumbnailItem.Create(Self);
        AItem.ImageIndex     := -1;
        AItem.FileName       := ExtractFileName(SearchRec.Name);
        FThumbList.Add(AItem);
      end;
      Application.ProcessMessages;
    until FindNext(SearchRec) <> 0;
    FindClose(SearchRec);
  end;

  ListView1.Items.EndUpdate;

  ListView1.Items.Count := FThumbList.Count;
  ListView1.Items[0].MakeVisible(False);

  //描画直後に右下の画像が描画されないXPManのバグ(?)対策
  ListView1.Refresh;
  StatusBar1.Panels[0].Text := '   ' + IntToStr(FThumbList.Count);
end;

//=============================================================================
//  TListViewのOnCustomDrawItemイベント処理
//  取得したビットマップを描画して，Captionの文字列を描画する
//=============================================================================
procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
var
  AWidth    : Integer;
  AHeight   : Integer;
  ImgBmp    : TBitmap;
  RectImg   : TRect;
  RectText  : TRect;
  FileName  : String;
  StartX    : Integer;
  StartY    : Integer;
  BackColor : TColor;
begin
  //本サンプルの場合はTrueにしてもデフォルトの描画は行われない
  DefaultDraw := False;

  //画像の表示領域を求める
  RectImg := Item.DisplayRect(drIcon);
  AWidth  := RectImg.Right  - RectImg.Left;
  AHeight := RectImg.Bottom - RectImg.Top;
  InflateRect(RectImg, -(AWidth - ImageWidth)  div 2, -(AHeight - ImageHeight) div 2);

  //縮小画像をリストから読出して表示
  ImgBmp := TBitmap.Create;

  try
    ImgBmp.Assign(FThumbList.Items[Item.Index].Bitmap);

    //画像の表示領域の上下左右の中央に表示
    if ImgBmp <> nil then begin
      StartX := RectImg.Left;
      StartY := RectImg.Top;
      if AWidth >= ImgBmp.Width then begin
        if AHeight > ImgBmp.Height then begin
          StartY := StartY + (AHeight - ImgBmp.Height) div 2;
        end;
      end else begin
        if AWidth > ImgBmp.Width then begin
          StartX := StartX + (AWidth - ImgBmp.Width) div 2;
        end;
      end;

      BackColor := GetSysColor(COLOR_WINDOW);
      //背景の塗り潰し
      TListView(Sender).Canvas.Brush.Style := bsSolid;
      TListView(Sender).Canvas.Brush.Color := BackColor;
      TListView(Sender).Canvas.FillRect(RectImg);

      //Windows Vista以降ではアルファーチャンネル処理
      //SetAlphaColorはplImageExtract.pas内の関数
      //これを実行しないと，TListViewでは透明部分が黒で表示される
      if CheckWin32Version(6, 0) then begin
        //色の指定を背景と同じにする
        SetAlphaColor(ImgBmp, BackColor);
      end else begin
        ImgBmp.Transparent := True;
      end;

      //TListViewのCanvasにビットマップを描画
      TListView(Sender).Canvas.Draw(StartX, StartY, ImgBmp);
    end else begin
      //何も表示しない
    end;
  finally
    FreeAndNil(ImgBmp);
  end;

  with TListView(Sender) do begin
    //Caption文字列描画領域の背景塗り潰し
    Canvas.Brush.Style := bsSolid;
    Canvas.Brush.Color := BackColor;
    Canvas.FillRect(RectText);

    //Captionの描画
    //Caption文字列の背景はそのままとする(OPAQUEなら塗り潰し)
    SetBkMode(Canvas.Handle, TRANSPARENT);
    FileName := FThumbList.Items[Item.Index].FileName;
    RectText := Item.DisplayRect(drLabel);
    DrawText(Canvas.Handle, PChar(FileName), -1, RectText, DT_CENTER);

    //選択状態を示す四角を描画
    if cdsSelected in State then begin
      Canvas.Pen.Color := clHighlight;
      Canvas.Pen.Width := 3;
      Canvas.MoveTo(RectImg.Left,     RectImg.Top);
      Canvas.LineTo(RectImg.Left,     RectImg.Bottom - 1);
      Canvas.LineTo(RectImg.Right -1, RectImg.Bottom - 1);
      Canvas.LineTo(RectImg.Right -1, RectImg.Top);
      Canvas.LineTo(RectImg.Left,     RectImg.Top);
    end;
  end;
end;

//=============================================================================
//  TListViewのOnDataHintイベント処理
//  Itemの描画が必要になった時に，その前に1回発生する
//
//  このイベント内でサムネイルのビットマップを取得する
//  OnDataHintイベントはTListViewのOwnerDataがTrueの場合にのみ発生する
//=============================================================================
procedure TForm1.ListView1DataHint(Sender: TObject; StartIndex,
  EndIndex: Integer);
var
  AIndex    : Integer;
  AFileName : String;
  Bmp       : TBitmap;
  Flags     : Cardinal;
begin
  for AIndex := EndIndex downto StartIndex do begin
    //[リストのインデックスが範囲を超えています]に対する対策
    if AIndex > (FThumbList.Count - 1) then exit;

    AFileName := FThumbList.Items[AIndex].FileName;

    //縮小画像が未取得の時だけ取得
    if FThumbList.Items[AIndex].ImageIndex = -1 then begin
      Bmp := TBitmap.Create;
      try
        //Windows Vista以降
        if CheckWin32Version(6, 0) then begin
          Flags := SIIGBF_RESIZETOFIT;
        end else begin
          Flags := IEIFLAG_ASPECT or IEIFLAG_CACHE or IEIFLAG_QUALITY;
        end;

        //サムネイル画像の取得
        //この取得に時間がかかる
        if ExtractImage(InitDir + AFileName,
                        Bmp,
                        ImageWidth,
                        ImageHeight,
                        Flags) then begin

          FThumbList.Items[AIndex].Bitmap := Bmp;
          FThumbList.Items[AIndex].ImageIndex := AIndex;
        end else begin
          //画像がない項目は削除
          FThumbList.Delete(AIndex);
          TListView(Sender).Items.Count := FThumbList.Count;
          StatusBar1.Panels[0].Text := '   ' + IntToStr(FThumbList.Count);
        end;
      finally
        FreeAndNil(Bmp);
      end;
    end;
  end;
end;

//=============================================================================
//  TListViewのOnResizeイベント処理
//  ランタイムテーマ(Delphi 7 ではusesにXPManがある場合)
//  リサイズすると描画されない部分があるのでRefresh
//=============================================================================
procedure TForm1.ListView1Resize(Sender: TObject);
begin
  ListView1.Repaint;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, ImgList,
  plImageExtract, plThumImgList;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    ListView1: TListView;
    Button1: TButton;
    Button2: TButton;
    StatusBar1: TStatusBar;
    ImageList1: TImageList;
    ProgressBar1: TProgressBar;
    Button3: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure ListView1CustomDrawItem(Sender: TCustomListView; Item: TListItem;
      State: TCustomDrawState; var DefaultDraw: Boolean);
    procedure ListView1Resize(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private 宣言 }
    InitDir          : String;
    FThumbList       : TplThumbnailList;
    ImageWidth       : Integer;
    ImageHeight      : Integer;
    SaveFileFullPath : String;
    CancelFlag       : Boolean;
    procedure GetThumbnailListAndSave(AFolder :String);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses CommCtrl, FileCtrl, ShlObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//
//  使用しているTListViewは，AliginプロパティをalClientにしている以外はデフォ
//  ルトの設定のままで，このOnCreateで設定している
//
//  TImageListは画像サイズの設定に使用しているだけで，画像は代入しない
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  W : Integer;
  H : Integer;
begin
  Button2.Enabled := False;
  Button3.Enabled := False;
  InitDir := '';

  //画像サイズの設定
  //Windows Vista以降では256(特大アイコンサイズ)とする
  if CheckWin32Version(6, 0) then begin
    ImageWidth  := 256;
  end else begin
    ImageWidth  := 128;
  end;
  ImageHeight           := ImageWidth;
  ImageList1.Width      := ImageWidth;
  ImageList1.Height     := ImageHeight;
  ListView1.LargeImages := ImageList1;

  //チラつき防止
  ListView1.DoubleBuffered := True;
  //仮想リストビューにする設定等
  ListView1.ViewStyle := vsIcon;
  ListView1.OwnerData := True;
  ListView1.OwnerDraw := False;

  //画像間のスペースの設定
  W := ImageWidth  + 30;
  H := ImageHeight + 30;
  ListView_SetIconSpacing(ListView1.Handle, W, H);

  //リスト管理用のリストを作成
  //TplThumbnailListは別ユニットで提供
  FThumbList := TplThumbnailList.Create(True);

  ProgressBar1.Anchors := ProgressBar1.Anchors + [akLeft, akRight, akBottom];
  ProgressBar1.Anchors := ProgressBar1.Anchors - [akTop];
  ProgressBar1.Visible := False;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  FThumbList.Free;
end;

//=============================================================================
//  [フォルダ]ボタン
//  取得先のフォルダー指定
//  SelectDirectoryにはusesにFileCtrlが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if FileCtrl.SelectDirectory('フォルダ指定',  '', InitDir) then begin
    InitDir := IncludeTrailingPathDelimiter(InitDir);

    StatusBar1.Panels[0].Text := '';
    //サムネイル画像の保存先は，サムネイル画像を取得するフォルダ内
    SaveFileFullPath := InitDir + '001.ImgThumb';

    //サムネイル画像を保存したファイルが存在する場合
    if FileExists(SaveFileFullPath) then begin
      Button1.Enabled := False;
      Button2.Enabled := False;
      Button3.Enabled := False;
      Screen.Cursor := crHourGlass;

      ListView1.Items.Clear;
      FThumbList.Clear;
      ListView1.Update;

      //読み込み
      //ファイルサイズが大きいと時間がかかる
      try
        FThumbList.LoadFromFile(SaveFileFullPath);
        //仮想リストビューではTListViewのItemsのCountプロパティの値をセットすると
        //実際の描画が開始される(再設定の場合は再描画)
　      ListView1.Items.Count := FThumbList.Count;
      except
        //読み込み失敗
        FThumbList.Clear;
      end;

      Button1.Enabled := True;
      Button2.Enabled := False;
      Button3.Enabled := True;
      Screen.Cursor := crDefault;

      ListView1.Items.Count := FThumbList.Count;

      StatusBar1.Panels[0].Text := '    ' + IntTostr(FThumbList.Count);
      ListView1.Items[0].MakeVisible(False);
    end else begin
      GetThumbnailListAndSave(InitDir);
    end;
  end;
end;

//=============================================================================
//  [キャンセル]ボタン
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  CancelFlag := True;
end;

//=============================================================================
//  [保存ファイル削除]ボタン
//  テスト用
//  サムネイル画像を保存したファイルを削除
//  取得にどのくらい時間がかかるかを再調査するため
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  if FileExists(SaveFileFullPath) then begin
    DeleteFile(SaveFileFullPath);
  end;
end;

//=============================================================================
//  指定したフォルダ内のファイルのサムネイルの画像を取得してリストを作成
//=============================================================================
procedure TForm1.GetThumbnailListAndSave(AFolder: String);
var
  AItem       : TplThumbnailItem;
  SearchRec   : TSearchRec;
  i           : Integer;
  AFileName   : String;
  Bmp         : TBitmap;
  Flags       : Cardinal;
  AIndex      : Integer;
  ACount      : Integer;
  ACountTotal : Integer;
begin
  StatusBar1.Panels[0].Text := '';

  ProgressBar1.Visible := True;
  Button1.Enabled := False;
  Button2.Enabled := True;
  Button3.Enabled := False;
  CancelFlag      := False;

  ListView1.Items.Clear;
  FThumbList.Clear;
  ListView1.Update;
  ListView1.Cursor := crHourGlass;
  ListView1.Items.BeginUpdate;

  //まずフォルダAFolder内の全てのファイル名を取得してリストに格納
  AFolder := IncludeTrailingPathDelimiter(AFolder);
  if FindFirst(AFolder + '*', faDirectory, SearchRec) = 0 then begin
    repeat
      if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then begin
        AItem                := TplThumbnailItem.Create(Self);
        AItem.ImageIndex     := -1;
        AItem.FileName       := ExtractFileName(SearchRec.Name);
        FThumbList.Add(AItem);
      end;
      Application.ProcessMessages;
      if CancelFlag then break;
    until FindNext(SearchRec) <> 0;
    FindClose(SearchRec);
  end;

  if not CancelFlag then begin
    ProgressBar1.Min      := 0;
    ProgressBar1.Max      := FThumbList.Count - 1;
    ProgressBar1.Position := 0;

    //順番にサムネイル画像を取得
    //[キャンセル]前の文だけは保存するために昇順に処理
    AIndex      := 0;      //リストのItem番号
    ACount      := 0;      //実際に処理した数
    ACountTotal := FThumbList.Count;

    while True do begin
      if AIndex >= FThumbList.Count then break;

      if FThumbList.Items[AIndex].ImageIndex = -1 then begin

        AFileName := FThumbList.Items[AIndex].FileName;
        Bmp := TBitmap.Create;
        try
          //Windows Vista以降
          if CheckWin32Version(6, 0) then begin
            Flags := SIIGBF_RESIZETOFIT;
          end else begin
            Flags := IEIFLAG_ASPECT or IEIFLAG_CACHE or IEIFLAG_QUALITY;
          end;

          //サムネイル画像の取得
          //この取得に時間がかかる
          if ExtractImage(AFolder + AFileName,
                          Bmp,
                          ImageWidth,
                          ImageHeight,
                          Flags) then begin

            FThumbList.Items[AIndex].FileName   := AFileName;
            FThumbList.Items[AIndex].Bitmap     := Bmp;
            FThumbList.Items[AIndex].ImageIndex := AIndex;
            AIndex := AIndex + 1;
          end else begin
            //画像がない項目は削除
            FThumbList.Delete(AIndex);
          end;
        finally
          FreeAndNil(Bmp);
        end;
      end;

      ACount := ACount + 1;
      ProgressBar1.Position := ACount;

      if CancelFlag then begin
        //取得できなかった分は削除
        for i := FThumbList.Count - 1 downto 0 do begin
          if FThumbList.Items[i].ImageIndex = -1 then begin
            FThumbList.Delete(i);
          end;
        end;
        break;
      end;

      StatusBar1.Panels[0].Text := '    ' +
                                   IntToStr(ACount) + ' / ' +
                                   IntTostr(ACountTotal);
      Application.ProcessMessages;
    end;
  end;

  ListView1.Items.EndUpdate;

  //TListViewのItem数を指定すると実際の描画が開始される
  ListView1.Items.Count := FThumbList.Count;
  ListView1.Items[0].MakeVisible(False);

  //サムネイル画像をファイルに保存
  //大量だとサイズも大きく，時間がかかる
  if FThumbList.Count > 0 then begin
    try
      FThumbList.SaveToFile(SaveFileFullPath);
    except
      //保存失敗
      if FileExists(SaveFileFullPath) then begin
        DeleteFile(SaveFileFullPath);
      end;
    end;
  end;

  StatusBar1.Panels[0].Text := '    ' + IntTostr(FThumbList.Count);

  ListView1.Cursor := crDefault;
  Button1.Enabled  := True;
  Button2.Enabled  := False;
  Button3.Enabled  := True;
  Sleep(600);
  ProgressBar1.Visible := False;
end;

//=============================================================================
//  TListViewのOnDataHintイベント処理
//  リストからビットマップを取り出して描画し，Captionの文字列を描画する
//=============================================================================
procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
var
  AWidth    : Integer;
  AHeight   : Integer;
  ImgBmp    : TBitmap;
  RectImg   : TRect;
  RectText  : TRect;
  FileName  : String;
  StartX    : Integer;
  StartY    : Integer;
  BackColor : TColor;

begin
  //本サンプルの場合はTrueにしてもデフォルトの描画は行われない
  DefaultDraw := False;

 if FThumbList.Items[Item.Index].Bitmap <> nil then begin
    //画像の表示領域を求める
    RectImg := Item.DisplayRect(drIcon);
    AWidth  := RectImg.Right  - RectImg.Left;
    AHeight := RectImg.Bottom - RectImg.Top;
    InflateRect(RectImg, -(AWidth - ImageWidth)  div 2, -(AHeight - ImageHeight) div 2);

    //縮小画像をリストから読出して表示
    ImgBmp := TBitmap.Create;

    try
      ImgBmp.Assign(FThumbList.Items[Item.Index].Bitmap);

      //画像の表示領域の上下左右の中央に表示
      if ImgBmp <> nil then begin
        StartX := RectImg.Left;
        StartY := RectImg.Top;
        if AWidth >= ImgBmp.Width then begin
          if AHeight > ImgBmp.Height then begin
            StartY := StartY + (AHeight - ImgBmp.Height) div 2;
          end;
        end else begin
          if AWidth > ImgBmp.Width then begin
            StartX := StartX + (AWidth - ImgBmp.Width) div 2;
          end;
        end;

        BackColor := GetSysColor(COLOR_WINDOW);
        //背景の塗り潰し
        TListView(Sender).Canvas.Brush.Style := bsSolid;
        TListView(Sender).Canvas.Brush.Color := BackColor;
        TListView(Sender).Canvas.FillRect(RectImg);

        //Windows Vista以降ではアルファーチャンネル処理
        //SetAlphaColorはplImageExtract.pas内の関数
        //これを実行しないと，TListViewでは透明部分が黒で表示される
        if CheckWin32Version(6, 0) then begin
          SetAlphaColor(ImgBmp, BackColor);
        end else begin
          ImgBmp.Transparent := True;
        end;

        //TListViewのCanvasにビットマップを描画
        TListView(Sender).Canvas.Draw(StartX, StartY, ImgBmp);
      end else begin
        //何も表示しない
      end;
    finally
      FreeAndNil(ImgBmp);
    end;

    with TListView(Sender) do begin
      //Caption文字列描画領域の背景塗り潰し
      Canvas.Brush.Style := bsSolid;
      Canvas.Brush.Color := BackColor;
      Canvas.FillRect(RectText);

      //Captionの描画
      //Caption文字列の背景はそのままとする(OPAQUEなら塗り潰し)
      SetBkMode(Canvas.Handle, TRANSPARENT);
      FileName := FThumbList.Items[Item.Index].FileName;
      RectText := Item.DisplayRect(drLabel);
      DrawText(Canvas.Handle, PChar(FileName), -1, RectText, DT_CENTER);

      //選択状態を示す四角を描画
      if cdsSelected in State then begin
        Canvas.Pen.Color := clHighlight;
        Canvas.Pen.Width := 3;
        Canvas.MoveTo(RectImg.Left,     RectImg.Top);
        Canvas.LineTo(RectImg.Left,     RectImg.Bottom - 1);
        Canvas.LineTo(RectImg.Right -1, RectImg.Bottom - 1);
        Canvas.LineTo(RectImg.Right -1, RectImg.Top);
        Canvas.LineTo(RectImg.Left,     RectImg.Top);
      end;
    end;
  end;
end;

//=============================================================================
//  TListViewのOnResizeイベント処理
//  ランタイムテーマ(Delphi 7 ではusesにXPManがある場合)
//  リサイズすると描画されない部分があるのでRefresh
//=============================================================================
procedure TForm1.ListView1Resize(Sender: TObject);
begin
  ListView1.Repaint;
end;

end.

unit plImageExtract;

interface

uses Windows, Graphics, SysUtils, ShellApi, ShlObj, ActiveX, ComObj;

//-----------------------------------------------------------------------------
//  外部から使用する関数類
//-----------------------------------------------------------------------------
function ExtractImage(AFileFullPath: String; ABitmap: TBitmap; AWidth: Integer;
  AHeight: Integer; pdwFlags: Cardinal = 0): Boolean;
procedure SetAlphaColor(ABitmap: TBitmap; AColor: TColor);


//-----------------------------------------------------------------------------
//  Delphi2009以前用のコード
{$IF CompilerVersion < 21.0}
const
  //定数名と値，インターフェイスの定義はWindows SDKによるもの
  IEIFLAG_ASYNC       =   $001;
  IEIFLAG_CACHE       =   $002;
  IEIFLAG_ASPECT      =   $004;
  IEIFLAG_OFFLINE     =   $008;
  IEIFLAG_GLEAM       =   $010;
  IEIFLAG_SCREEN      =   $020;
  IEIFLAG_ORIGSIZE    =   $040;
  IEIFLAG_NOSTAMP     =   $080;
  IEIFLAG_NOBORDER    =   $100;
  IEIFLAG_QUALITY     =   $200;
  IEIFLAG_REFRESH     =   $400;

  SIIGBF_RESIZETOFIT  = $00000000;
  SIIGBF_BIGGERSIZEOK = $00000001;
  SIIGBF_MEMORYONLY   = $00000002;
  SIIGBF_ICONONLY     = $00000004;
  SIIGBF_THUMBNAILONL = $00000008;
  SIIGBF_INCACHEONL   = $00000010;

  {$EXTERNALSYM IID_IExtractImage}
  SID_IExtractImage        = '{BB2E617C-0920-11D1-9A0B-00C04FC2D6C1}';
  IID_IExtractImage: TGUID = SID_IExtractImage;

  {$EXTERNALSYM IID_IShellItemImageFactory}
  SID_IShellItemImageFactory        = '{BCC18B79-BA16-442F-80C4-8A59C30C463B}';
  IID_IShellItemImageFactory: TGUID = SID_IShellItemImageFactory;

type
  {$EXTERNALSYM IExtractImage}
  IExtractImage = interface(IUnknown)
    [SID_IExtractImage]
    function GetLocation(pszPathBuffer: LPWSTR; cch: DWORD; var pdwPriority: DWORD;
      var prgSize: TSize; dwRecClrDepth: DWORD;
      var pdwFlags: DWORD): HRESULT; stdcall;
    function Extract(var phBmpThumbnail: HBITMAP): HRESULT; stdcall;
  end;

  SIIGBF = Integer; 
  {$EXTERNALSYM SIIGBF}
  TSIIGBF = SIIGBF;

  {$EXTERNALSYM IShellItemImageFactory}
  IShellItemImageFactory = interface(IUnknown)
    [SID_IShellItemImageFactory]
    function GetImage(size: TSize; flags: TSIIGBF;
      var phbm: HBITMAP): HRESULT; stdcall;
  end;

type
  TSHCreateItemFromParsingName = function (pszPath: LPCWSTR; const pbc: IBindCtx;
    const riid: TIID; out ppv): HResult; stdcall;

{$IFEND}
//----------- delphi 2009以前用のコード終了 -----------------------------------

implementation

//=============================================================================
//  サムネイル(縮小表示)画像を取得する関数
//
//  ABitmap  : このTBitmapにサムネイル画像が出力される
//             TBitmapは，この関数の呼出し側で生成し，使い終わったら解放する
//  AWidht   : 出力するサムネイルの幅を，この関数の呼出し側で指定する
//  AHeight  : 出力するサムネイルの高さ，この関数の呼出し側で指定する
//             幅，高さは，pdwFlagsの値によって変わることがある
//  pdwFlags : 取得するサムネイル画像に関する指定
//             Windows XP の場合はEIFLAG_ASPECT等の定数
//             Windows Vista以降ではSIIGBF_RESIZETOFIT等の定数
//
//  戻り値 サムネイル画像取得に成功すればTrue，失敗すればFalse
//=============================================================================
function ExtractImage(AFileFullPath: String; ABitmap: TBitmap; AWidth: Integer;
  AHeight: Integer; pdwFlags: Cardinal = 0): Boolean;
var
  Res            : HResult;
  ShellItemImage : IShellItemImageFactory;
  FileName       : String;
  ImageSize      : SIZE;
  hBmp           : HBITMAP;

  Malloc         : IMalloc;
  DesktopFolder  : IShellFolder;
  ItemIDList     : PItemIDList;
  IDList         : PItemIDList;
  Folder         : IShellFolder;
  plfgOut        : Pointer;
  Eaten          : Cardinal;
  Attribute      : Cardinal;
  Unknown        : IUnknown;
  ExtractImage   : IExtractImage;
  PathBuffer     : PWideChar;
  Priority       : Cardinal;
  RecClrDepth    : DWORD;
  bmp            : TBitmap;
  {$IF CompilerVersion < 21.0}
  dllHandle : THandle;
  SHfunc    : TSHCreateItemFromParsingName;
  {$IFEND}
begin
  Result := False;
  ABitmap.Canvas.Lock;

  //Windows Vista以降
  if CheckWin32Version(6, 0) then begin

    {$IF CompilerVersion < 21.0}
    dllHandle := LoadLibrary('shell32.dll');
    {$IFEND}
    try
      {$IF CompilerVersion < 21.0}
      SHfunc := GetProcAddress(dllHandle, 'SHCreateItemFromParsingName');
      Res := SHfunc(PWideChar(WideString(AFileFullPath)),
                    nil,
                    IShellItemImageFactory,
                    ShellItemImage);
      {$ELSE}
      Res := SHCreateItemFromParsingName(
               PWideChar(AFileFullPath),
               nil,
               IShellItemImageFactory,
               ShellItemImage);
      {$IFEND}

      if Succeeded(Res) then begin
        ImageSize.cx := AWidth;
        ImageSize.cy := AHeight;

        Res := ShellItemImage.GetImage(ImageSize, pdwFlags, hBmp);
        if Succeeded(Res) then begin
          bmp := TBitmap.Create;
          try
            //Windows Vista,7で，ストリームに保存すると上下が反転しまう現象対策
            bmp.Handle     := hBmp;
            ABitmap.Width  := bmp.Width;
            ABitmap.Height := bmp.Height;
            ABitmap.Canvas.Draw(0, 0, bmp);
          finally
            FreeAndNil(bmp);
          end;
          Result := True;
        end;
      end;
    finally
      {$IF CompilerVersion < 21.0}
      if dllHandle <> 0 then FreeLibrary(dllHandle);
      {$IFEND}
    end;

  end else begin
    SHGetMalloc(Malloc);
    ItemIDList := nil;
    IDList     := nil;
    try
      //デスクトップのIShellFolderを取得
      SHGetDesktopFolder(DesktopFolder);
      //ファイルのあるフォルダの項目識別子ItemIDListを求める
      FileName := ExtractFilePath(AFileFullPath);
      if Length(FileName) <> 0 then begin;
        DesktopFolder.ParseDisplayName(0, nil, StringToOleStr(FileName), Eaten,
                                       ItemIDList, Attribute);
        //デスクトップにバインドする
        DesktopFolder.BindToObject(ItemIDList, nil, IID_IShellFolder,
                                   Pointer(Folder));
        //バインドしたフォルダ内のファイル名の項目識別子IDListを取得
        FileName := ExtractFileName(AFileFullPath);
        Folder.ParseDisplayName(0, nil, StringToOleStr(FileName), Eaten, IDList,
                                Attribute);

        //以下，IExtractImageインターフェイスのGetLoacationとExtractで縮小画像を取得
        plfgOut := nil;
        Res := Folder.GetUIObjectOf(0, 1, IDList, IID_IExtractImage, plfgOut, Unknown);
        if Succeeded(Res) then begin
          ExtractImage := Unknown as IExtractImage;
          if ExtractImage <> nil then begin
            case ABitmap.PixelFormat of
              pfDevice : RecClrDepth := 24;
              pf1bit   : RecClrDepth := 1;
              pf4bit   : RecClrDepth := 4;
              pf8bit   : RecClrDepth := 8;
              pf15bit  : RecClrDepth := 16;
              pf16bit  : RecClrDepth := 16;
              pf24bit  : RecClrDepth := 24;
              pf32bit  : RecClrDepth := 32;
              pfCustom : RecClrDepth := 24;
              else RecClrDepth := 24;
            end;

            //プライオリティはデフォルトとする
            Priority     := 0;
            //取得するサイズを設定
            ImageSize.cx := AWidth;
            ImageSize.cy := AHeight;

            PathBuffer := AllocMem(MAX_PATH);
            try
              ExtractImage.GetLocation(PathBuffer,
                                       MAX_PATH,
                                       Priority,
                                       ImageSize,
                                       RecClrDepth,
                                       pdwFlags);
              Res := ExtractImage.Extract(hBmp);
              if Succeeded(Res) then begin
                ABitmap.Handle := hBmp;
                Result         := True;
              end;
            finally
              FreeMem(PathBuffer);
            end;
          end;
        end;
      end;
    finally
      if ItemIDList <> nil then Malloc.Free(ItemIDList);
      if IDList     <> nil then Malloc.Free(IDList);
      DesktopFolder := nil;
      Folder        := nil;
      Malloc        := nil;
    end;
  end;
  ABitmap.Canvas.UnLock;
end;

//=============================================================================
//  引数のビットマップのアルファチャンネルの透明部分の色指定
//  アルファチャネルが使用できるのは32bitのビットマップに限る
//  Windows Vista以降用
//
//  ABitmap : 対象のビットマップ．処理後のビットマップが返ってくる
//  AColor  : 色の指定
//
//  この関数の処理をしないで，TImageで透明部分を透明表示するには，
//     ABitmap.AlphaFormat := afDefined;
//  とする(Delphi 2009以降)
//=============================================================================
procedure SetAlphaColor(ABitmap: TBitmap; AColor: TColor);

type
  PRGB32 = ^TRGB32;
  TRGB32 = record
    B, G, R, A : Byte;
  end;

  PPixel32 = ^TPixel32;
  TPixel32 = array [0 .. 0] of TRGB32;
var
  Row    : PPixel32;
  X      : Integer;
  Y      : Integer;
  ScanMain : Integer;
  SCanSize : Integer;
  R      : Byte;
  G      : Byte;
  B      : Byte;
begin
  ABitmap.Canvas.Lock;
  ABitmap.PixelFormat := pf32bit;

  R := GetRValue(AColor);
  G := GetGValue(AColor);
  B := GetBValue(AColor);

  ScanMain := Integer(ABitmap.ScanLine[0]);
  SCanSize := Integer(ABitmap.ScanLine[1]) - ScanMain;

  for Y := 0 to ABitmap.Height - 1 do begin
    Row := PPixel32(ScanMain);
    for X := 0 to ABitmap.Width - 1 do begin
      Row[X].R := Row[X].A * (Row[X].R - R) shr 8 + R;
      Row[X].G := Row[X].A * (Row[X].G - G) shr 8 + G;
      Row[X].B := Row[X].A * (Row[X].B - B) shr 8 + B;
    end;
    ScanMain := ScanMain + SCanSize;
  end;
  ABitmap.Canvas.UnLock;
end;

end.

unit plThumImgList;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Forms, Contnrs;

type
  //各サムネイルのItem(情報)
  TplThumbnailItem = class (TComponent)
  private
    FBitmap     : TBitmap;
    FImageIndex : Integer;
    FFileName   : String;
    FText       : String;
    procedure SetBitmap(const Value: TBitmap);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property ImageIndex : Integer read FImageIndex write FImageIndex;
  published
    property Bitmap   : TBitmap read FBitmap   write SetBitmap;
    property FileName : String  read FFileName write FFileName;
    property Text     : String  read FText     write FText;
  end;

  //サムネイル格納用のリスト
  TplThumbnailList = class(TComponentList)
  protected
    function GetItem(Index: Integer): TplThumbnailItem;
    procedure SetItem(Index: Integer; AObject: TplThumbnailItem);
  public
    destructor Destroy; override;
    function Add(AObject: TplThumbnailItem): Integer;
    procedure Clear; override;
    function Remove(AObject: TplThumbnailItem): Integer;
    function IndexOf(AObject: TplThumbnailItem): Integer;
    procedure SaveToFile(AFilePath: String);
    procedure LoadFromFile(AFilePath: String);
    property Items[Index: Integer]: TplThumbnailItem read GetItem write SetItem;
  end;

implementation

{ TplThumbnailItem }

//-----------------------------------------------------------------------------
//  Create
//-----------------------------------------------------------------------------
constructor TplThumbnailItem.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FBitmap := TBitmap.Create;
  FImageIndex := -1;
end;

//-----------------------------------------------------------------------------
//  Destroy
//-----------------------------------------------------------------------------
destructor TplThumbnailItem.Destroy;
begin
  FreeAndNil(FBitmap);
  inherited Destroy;
end;

//-----------------------------------------------------------------------------
//  Bitmapプロパティの設定
//  オブジェクト型のプロパティは必ずSet...で設定する
//-----------------------------------------------------------------------------
procedure TplThumbnailItem.SetBitmap(const Value: TBitmap);
begin
  if Value = nil then begin
    FBitmap := nil;
  end else begin
    FBitmap.Assign(Value);
  end;
end;

{ TplThumbnailList }

//-----------------------------------------------------------------------------
//  本クラスの破棄
//-----------------------------------------------------------------------------
destructor TplThumbnailList.Destroy;
begin
  inherited Destroy;
end;

//-----------------------------------------------------------------------------
//  全てのItemのClser
//-----------------------------------------------------------------------------
procedure TplThumbnailList.Clear;
begin
  inherited Clear;
end;

//-----------------------------------------------------------------------------
//  Itemの追加
//-----------------------------------------------------------------------------
function TplThumbnailList.Add(AObject: TplThumbnailItem): Integer;
begin
  Result := inherited Add(AObject);
end;

//-----------------------------------------------------------------------------
//  Itemの設定(代入)
//-----------------------------------------------------------------------------
procedure TplThumbnailList.SetItem(Index: Integer; AObject: TplThumbnailItem);
begin
  inherited Items[Index] := AObject;
end;

//-----------------------------------------------------------------------------
//  指定IndexのItemの取得
//-----------------------------------------------------------------------------
function TplThumbnailList.GetItem(Index: Integer): TplThumbnailItem;
begin
  Result := TplThumbnailItem(inherited Items[Index]);
end;

//-----------------------------------------------------------------------------
//  指定Itemの削除
//-----------------------------------------------------------------------------
function TplThumbnailList.Remove(AObject: TplThumbnailItem): Integer;
begin
  Result := inherited Remove(AObject);
end;

//-----------------------------------------------------------------------------
//  Itemの検索
//-----------------------------------------------------------------------------
function TplThumbnailList.IndexOf(AObject: TplThumbnailItem): Integer;
begin
  Result := inherited IndexOf(AObject);
end;

//-----------------------------------------------------------------------------
//  サムネイル画像をファイルに保存
//  Vista以降では，保存ユーザー名，保存先，保存ファイル名等に注意(UAC関係)
//-----------------------------------------------------------------------------
procedure TplThumbnailList.SaveToFile(AFilePath: String);
var
  i       : Integer;
  AStream : TFileStream;
begin
  AStream := TFileStream.Create(AFilePath, fmCreate or fmOpenReadWrite);
  try
    for i := 0 to Count - 1 do begin
      AStream.WriteComponent(Items[i]);
      Application.ProcessMessages;
    end;
  finally
    AStream.Free;
  end;
end;

//-----------------------------------------------------------------------------
//  サムネイル画像をファイルから読出し
//-----------------------------------------------------------------------------
procedure TplThumbnailList.LoadFromFile(AFilePath: String);
var
  DI      : TplThumbnailItem;
  AStream : TFileStream;
begin
  //保存ファイルがなければ何もしない
  if not FileExists(AFilePath) then exit;

  AStream := TFileStream.Create(AFilePath, fmOpenRead);
  AStream.Position := 0;
  try
    if AStream.Size > 0 then begin
      Clear;
      while True do begin
        DI := TplThumbnailItem.Create(nil);
        AStream.ReadComponent(DI);
        Add(DI);
        if AStream.Position >= AStream.Size then break;
        Application.ProcessMessages;
      end;
    end;
  finally
    AStream.Free;
  end;
end;

end.