Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2007年11月23日] [更新 2012年08月18日] Delphi サンプルプログラム集
   
792_エクスプーラの縮小表示機能を使用した画像のサムネイル表示
動作確認等 Windows 7 U64(SP1) + Delphi XE(UP1) Pro
792_ExplThumbnail.zip [2,658 KB] 2012年08月18日版(EXE同梱)



  • 2012年08月12日
  • サムネイル取得とリスト管理用のコードを別ユニットにした
  • Windows Vista, 7 の特大アイコン表示に相当するサイズにも対応
  • Windows Vista, 7 で透明部分(アルファチャンネル)の描画が行われない)現象への対応
  • Windows Vista, 7 で保存したサムネイル画像の上下が反転する現象への対策
  • Delphi 6, 7, 2007, 2009, 2010, XE (全て Pro 版) で動作確認
  • スレッドを使用するサンプルを削除
  • 2012年08月17日
  • [1] Delphi 7 で初回,画像が表示されないので, PixelFormat の値をpf32bitとした
  • [2] [リストのインデックスが範囲を超えています] に対する対策コードを追加
  • [3] [リストのインデックスが範囲を超えています] に対する対策コードを追加
  • [4] サムネイルの取得を降順にしていたのを,[キャンセル] した場合に,[キャンセル] までの分を保存するために昇順処理に変更




エクスプローラの縮小表示機能を使用した画像のサムネイル表示


エクスプローラの [表示] で [縮小版] (Windows XP) あるいは,[特大アイコン] (Vista以降) にすると,縮小された画像が表示されます.ここでは,これを「サムネイル」または「サムネイル画像」と呼ぶことにします.

Windows API に,このサムネイル画像を取得する関数があります.以下のサンプルは,この機能を利用してサムネイル画像を取得して表示するものです.サムネイルの画像は,元の画像の形式とは関係なしに,全てビットマップ形式です.
サムネイル取得用のコードは,nana さんという方が提供していましたが,今回,Windows Vista 以降には専用の関数が用意されましたので,Vista 以降では,この関数を使用するコードに変更しました.

1つの画像のサムネイルだけを表示する時はあまり問題とはならないと思いますが,複数の画像をリスト形式で表示すると時間がかかります.サムネイルを取得する画数の実行,つまり,サムネイル画像のの取得には,表示よりも時間がかかります.
筆者がローカルディスク内の画像ファイルでテストした結果では,ストレスをあまり感じないで表示できるのは,せいぜい 100 〜 150 程度ではないでしょうか.データベースによる管理のサンプルではありません.画像管理というジャンルで使用するには工夫が必要でしょう.

アプリケーションで,あまり多くない画像を一覧表示する用途には利用可能かも知れません.一度に表示する画像の数を制限して,[次頁] [前頁] や,指定ページに移動する等のボタンで表示画像を移動するようにする方法も考えられます.

画像の表示に Timage,TListView を使用する必然性はありません.サードパーティあるいはネットで入手可能な画像表示を伴うアプリにはいろいろな方式があります.TDrawGrid や TScrollBox を使用したものあるようです.つまり,画像が表示できさえすれば,何でも使用できます.
また,画像のサムネイル表示という意味では,実際の画像ファイルから縮小した画像を取得し,それをサムネイル画像として処理することも考えられます.本ページのサンプルの方式にこだわる必然性は全くありません.



[備考]
パフォーマンスオプションの [アイコンの代わりに縮小版を表示する] のチェックを外すと,エクスプローラの画像の縮小表示機能は無効になります.
また,ローカルグループポリシーのツリー項目,[管理用テンプレート] [Windowsコンポーネント] [エクスプローラ] の右ペインのリストにある [非表示の thumbs.db ファイルで縮小表示のキャッシュを無効にする] と [縮小画像のキャッシュをオフにする] を有効にすると,縮小画像のキャッシュ機能が無効になります.




01_単一画像のサムネイル表示


特定の画像ファイルのサムネイル画像を取得するテストです.
[フォルダ] ボタンでは,フォルダのサムネイル画像を表示します.該当フォルダ内に,サムネイルが取得可能なファイルがある場合にのみ,フォルダのサムネイル画像が取得できます.

サムネイル画像取得用の API では,縦横のサイズ,ビットマップ色数(16 bit とか 32 bit),その他の指定(ここでは単にフラグ)を指定して取得できます.そのテストも兼ねています.

添付の plImageExtract.pas に,Vista 以降専用の SetAlphaColor という関数があります.これは,透明色部分の処理用ですが,この関数を使用すると,32 bit のビットマップに変換するようになっています.これは,32 bit でないと,透明部分であるアルファチャンネルの処理ができないために,この仕様としています.


図1
設計時画面
  • 取得したサムネイル画像 (ビットマップ) 表示用の TImage を配置
  • 以下の設定での取得テスト
  • 取得ビットマップサイズ指定
  • 取得のフラグの設定
図2
画像のサムネイル
図3
フォルダのサムネイル
  • Windows 7 の場合
  • 画像は,このプロジェクトのフォルダのもの


Windows XP では,取得するサムネイル画像の品質を指定できます.そのテストです.
フラグに IEIFLAG_QUALITY を含めると高品質になります.下の図では,画像のサイズを大きめにしてこのフラグの動作結果を確認しています.


図4
高品質でない場合
図5
高品質の場合
  • 文字が鮮明に表示されている
  • Windows Vista 以降は常にこの高品質のビットマップ取得となる


Windows XP の初期のバージョンでは,下図のように,画像以外のファイルのサムネイルも表示する機能がありました.最近のバージョンではできません.
レジストリを操作すれば可能なようですが,筆者は確認していません.Windows Vista, 7 では画像以外のファイルのサムネイルを取得できますが,ファイルの種類を意味する「特大のアイコン」のビットマップを取得する仕様になっています.



図6
画像以外のサムネイル
  • Windows XP の古いバージョンでサムネイルのリストを取得した結果

リスト1
エクスプローラの縮小表示機能を使ってサムネイル画像を取得
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.




02_フォルダ内の画像を一覧表示  -  TImageList に画像を代入


上のサンプルで,サムネイル画像の取得テストは終了です.
と言うのでは味気ないので,指定フォルダ内の画像をリスト,TListView に一覧表示してみることにします.サムネイル画像取得の Windows API の実行には時間がかかります.
TListView では,一般には,TImageList に表示したい画像を格納しますが,サネイル画像を取得する度に画像を格納していくと,全ての画像が格納されるまで表示を開始してくれません.非常に時間がかかります.そこで,仮想リストビューという方式を使うことにします.

仮想リストビューとは,必要な情報を全てあらかじめ取得しておき,表示が必要となった時点で Item に情報を格納していくやり方です.

  • (1) TListView の OwnerData プロパティを True にして仮想リストビュー形式とする
  • (2) TListView の OnDataHint イベント内で,表示 Item 部分だけサムネイルを取得し,
    TImageList に位置とサイズを調整して格納
  • (3) TListView の OnData イベントで,TListView の Caption と ImageIndex を設定 
という手順で実行します.サムネイル画像が取得できていない領域のスクロール動作が緩慢となりますが,全てのサムネイル画像が取得できればスムースなスクロールとなります.

Delphi 2009 から TImageList もアルファチャンネルが使えます.TImageList で表示する画像の透明部分を有効にするには,TImageList に画像を追加する前に ColorDepth プロパティを cd32bit に設定します.この指定をしないと,透明部分が描画されず,黒く表示されます.
今回のこのサンプルでは使用していません.背景の塗り潰しにも対応するために専用の関数を作成してビットマップ側で処理するようにしています.



図7
設計時画面
  • 取得したビットマップ格納用の TImageList を配置
図8
実行例
  • 画像が多いと,スクロールがもたつく
  • 一度でも全てスクロール表示すればスムースになる

リスト2
フォルダ内の画像を一覧表示 - TImageList に画像を代入
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.




03_フォルダ内の画像を一覧表示 - カスタム描画


上のサンプルでは,TImageList に取得したムネイル画像を格納しています.
今度は,TImageList を画像サイズの設定だけに使用して,実際の画像は,TListView の Canvas に描画してみます.描画は,OnCustomDrawItem イベントで実行します.つまりカスタム描画です.

カスタム描画をすれば,選択状態の時の表示仕様,画像とファイル名の描画位置等の調整が可能です.ただし,描画コードを全てコーディングしなければならない手間はあります.
背景色を指定するコードは参考のために書いてあります.実際にはほとんどシステムの既定値と同じになっています.必要がなければ削除してください.


図9
設計時画面
  • TImageList は画像のサイズ設定用で,ビットマップは格納しない
図10
実行例
  • 画像が多いと,スクロールがもたつく
  • 一度全てスクロールすればスムースになる

リスト3
フォルダ内の画像を一覧表示 - カスタム描画
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.




04_サムネイル画像リストの保存と読出し


サムネイル画像を全て取得してから表示開始するようにしたものです.
そうすると,当然サムネイル画像を全て取得してからでないと表示は行われません.ファイル数が多いと時間がかかりますが,描画を開始すればスクロールは滑らかとなります.

このサンプルでは,サムネイル画像のリスト(他の情報も含めて)をファイルに保存して,次回からはこのファイルに格納したサムネイルのビットマップ画像を読出して表示します.したがって,次回からは高速に表示できます.
画像の更新状態が必要であれば,保存したサムネイルを読み出す際に,ファイルの存在をチェックしたり,ファイルのタイムスタンプ(更新日時)等をチェックすることでも可能でしょう.

ビットマップの描画は,上のサンプルと同じカスタム描画にしています.背景色を指定するコードは参考のために書いてあります.実際にはほとんどシステムの既定値と同じになっています.必要がなければ削除してください.


[備考]
保存したサムネイル画像のサイズと,表示するサムネイル画像のサイズのチェックコードは書いてありません.必要に応じて追加してください.StretchDraw 等の使用も考えてもいいかも知れません.


図11
設計時画面
図12
サムネイル作成中
  • 全てのサムネイルを取得するまでは表示しない
図13
サムネイル取得終了

リスト4
サムネイル画像リストの保存と読出し
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.




05_サムネイル画像取得用ユニットのコード


元々は nana さんという方がネットで提供していたものですが,今回,Windows Vista 以降対応のコードを追加しています.
Windows XP でサムネイル画像を取得する関数の引数に,該当ファイルの項目識別子が必要です.この項目識別子は,[818_シェル名前空間と項目識別子] で説明しているような方法で取得します.
この関数は,Windows Vista 以降でも使用できますが,このユニットでは,Vista 以降の専用の関数である IShellItemImageFactory インターフェイスの GetImage 関数を使用しています.

下の表は,これらの関数で使用する引数の「フラグ」の一覧です.説明はかなり省略しています.詳細につていは,MSDN の記事等で確認してください.

エクスプローラで縮小表示をすると,そのフォルダに Thumbs.db というサムネイルを収めたファイルができます.IThumbnailCache インターフェイスとIShellImageStore インターフェイスは,このファイルからサムネイル画像を取得するためのインターフェイスです.
IThumbnailCache は Windows Vista 以降用,IShellImageStore は Windows 2000, XP 用となっています.今回はこれらのインターフェイスは使用していません.




表1
GetLocation 関数の引数のフラグ (Windows XP)

IEIFLAG_ASPECT 元の画像のアスペクト比を保ったサムネイルを取得
IEIFLAG_SCREEN と同時に使用できない
IEIFLAG_ASYNC 使用されていない
サムネイルは常にバックグラウンド スレッドで抽出される
IEIFLAG_CACHE サポートされていない
IEIFLAG_GLEAM サポートされていない
IEIFLAG_NOBORDER サポートされていない
IEIFLAG_NOSTAMP サポートされていない
IEIFLAG_OFFLINE ローカルコンテンツのみのレンダリングに使用する
IEIFLAG_ORIGSIZE 取得したサムネイルビットマップをオリジナルサイズにトリミング
IEIFLAG_QUALITY 高品質のイメージを要求する
指定がない場合は IExtractImage の埋め込みサムネイルを取得するため,指定したサイズで取得できない場合がある
IEIFLAG_REFRESH サムネイルの更新に相当
IEIFLAG_SCREEN レンダリングするオブジェクトを指定するために使用(?)
IEIFLAG_ASPECT と同時に使用できない


表2
IShellItemImageFactory インターフェイスの GetImage 関数の引数のフラグ (Windows Vista, 7)
Windows 8 ではこれ以外にも追加のフラグがある

SIIGBF_RESIZETOFIT 元の画像のアスペクト比を維持して取得
SIIGBF_BIGGERSIZEOK サムネイルに大きなサイズが存在する場合,そのサイズで取得
取得希望のサイズで取得するにはストレッチ描画が必要
本サンプルでは,このフラグを考慮していないので要注意
SIIGBF_MEMORYONLY キャッシャされたメモリ内のサムネイルを取得
SIIGBF_ICONONLY アイコンのみのサムネイル取得
SIIGBF_THUMBNAILONLY サムネイルのみの取得
SIIGBF_INCACHEONLY キャッシュされた項目のみの取得
キャッシュされたサムネイルがない場合はアイコンとなる


リスト5
サムネイル画像取得用ユニットのコード
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.




06_画像リスト管理用のユニットのコード


TListView を仮想リストビューとして使用するために,取得したサムネイル画像関係の情報を格納しておくリストが必要です.そのためのコードを収めたユニットです.

TObject でもいいのですが,操作が便利なので TComponent を使用しています.また,クラスをキャストして使用しなくても済むように,専用のクラスとして定義しました.このようなクラス定義で保存可能なのは,published なプロパティだけです.言い方を変えれば,published なプロパティにできる型であれば何でも保存できることになります.
このクラスの定義は,他のリスト管理にも応用できます.

Delphi 2007 以降であれば,リストの管理の部分にジェネリックスが使用できます.




リスト6
画像リスト管理用のユニットのコード
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.