[delphi-users:2466] SHGetFileInfoをTThreadから利用するには？
tetupei
タイトル通り、SHGetFileInfoを用いて32*32アイコンをスレッド経由で取得していま
す。
すると時々アイコンイメージが取得できません。
Synchronizeすれば問題ないのですが、できればSynchronizeしないで取得したいと
思っています。
同じような症状をネットで見つけたのですが、どうもよくわかりません。
「SHGetFileInfoを副スレッドで実行するとIE系のアイコンが取得できません」
http://social.msdn.microsoft.com/Forums/ja-JP/csharpgeneralja/thread/e41b485
f-c807-457b-87e6-11b1e4691697/
CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
をスレッドの頭に入れたりなどは試したのですが、結果は変わりません。
それともやはりメインスレッド以外からの使用はできないのでしょうか？
宜しくお願いします。
赤尾鉄平
再現ソースです
なるべく簡単な再現コードをつくろうとしたのですが、少々長めになりました、です
が、
Form1にコピペして、
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
をオブジェクトインスペクタで追加していただければ動作します。
SHGetFileInfoを頻数送りたい為に簡易エクスプローラを作成しています。
procedure TIconThread.Execute;
begin
inherited;
Synchronize(GetIcon);
//GetIcon; //スレッドセーフにしたいです。
end;
の部分を切り替えると時々黒いアイコンが作成されます。
//--------------------------------------------------------------------------
-----------------------
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.
Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.ImgList, ShellAPI,
ActiveX;
type
TRequestState = (rsNone,rsExtProcess,rsExt);
TFileItem = class(TObject)
public
sr:TSearchRec;
ImageIndex:Integer;
RequestState : TRequestState;
constructor Create;
end;
TFileList = class(TList)
private
fDirectory: string;
procedure SetDirectory(const Value: string);
function GetFileItem(Index: Integer): TFileItem;
public
procedure Clear; override;
property Directory:string read fDirectory write SetDirectory;
property FileItem[Index:Integer]:TFileItem read GetFileItem;
end;
TIconItem = class(TObject)
public
Path:string;
sr:TSearchRec;
Bmp:TBitmap;
constructor Create;
destructor Destroy; override;
end;
TIconItemList = class(TList)
private
function GetIconItem(Index: Integer): TIconItem;
public
procedure Clear; override;
procedure AddIconItem(var aIconItem:TIconItem);
property IconItem[Index:Integer]:TIconItem read GetIconItem;
end;
TIconThread = class(TThread)
private
procedure GetIcon;
public
IconItem:TIconItem;
constructor Create;
destructor Destroy; override;
procedure Execute; override;
end;
TIMGetIconEvent = procedure(Sender: TObject; var aIconItem:TIconItem) of
object;
TIconManager = class(TObject)
private
fThreadStop :Boolean;
fIconItemList: TIconItemList;
fThreadWorking :Boolean;
fOnGetIcon: TIMGetIconEvent;
procedure GetIconThread;
procedure IconThreadOnTerminate(Sender:TObject);
public
constructor Create;
destructor Destroy; override;
procedure GetIcon(aIconItem:TIconItem);
property OnGetIcon:TIMGetIconEvent read fOnGetIcon write fOnGetIcon;
end;
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private 宣言 }
FileList:TFileList;
IconManager:TIconManager;
ListView:TListview;
ImageList:TImageList;
procedure ListViewData(Sender: TObject; Item: TListItem);
procedure ListViewDblClick(Sender: TObject);
procedure SetDirectory(const Value: string);
procedure IconManagerOnGetIcon(Sender: TObject; var
aIconItem:TIconItem);
public
{ Public 宣言 }
property Directory:string write SetDirectory;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function IsFolder(sr:TSearchRec):Boolean;
begin
Result := ((sr.Attr or faDirectory)=sr.Attr);
end;
function GetExtFileIconHandle(aPath: string):HICON;
var
aExt:string;
SHFinfo: TSHFileinfo;
begin
aExt := '*'+ExtractFileExt(aPath);
SHGetFileInfo(PChar(aExt), FILE_ATTRIBUTE_NORMAL, SHFinfo,
SizeOf(SHFinfo),
SHGFI_ICON or
SHGFI_SYSICONINDEX or
SHGFI_USEFILEATTRIBUTES);
Result := SHFinfo.HICON;
end;
function GetDirIconHandle(aPath: string):HICON;
var
SHFinfo: TSHFileinfo;
begin
SHGetFileInfo(PChar(aPath), FILE_ATTRIBUTE_DIRECTORY, SHFinfo,
SizeOf(SHFinfo),
SHGFI_ICON);
Result := SHFinfo.HICON;
end;
{ TFileItem }
constructor TFileItem.Create;
begin
ImageIndex := -1;
RequestState := rsNone;
end;
{ TFileList }
procedure TFileList.Clear;
var
i:Integer;
begin
for i:=0 to Count-1 do
TFileItem(Items[i]).Free;
inherited;
end;
function TFileList.GetFileItem(Index: Integer): TFileItem;
begin
Result := TFileItem(Items[Index]);
end;
procedure TFileList.SetDirectory(const Value: string);
var
sr:TSearchRec;
aItem:TFileItem;
begin
fDirectory := Value;
Clear;
if FindFirst(IncludeTrailingPathDelimiter(fDirectory)+'*.*' ,faDirectory ,
sr) = 0 then
begin
repeat
aItem := TFileItem.Create;
aItem.sr := sr;
Add(aItem);
until FindNext(sr) <> 0;
FindClose(sr);
end;
end;
{ TIconItem }
constructor TIconItem.Create;
begin
Bmp := TBitmap.Create;
Bmp.PixelFormat:=pf32bit;
Bmp.AlphaFormat := afDefined;
Bmp.Canvas.Brush.Color := $00000000;
Bmp.SetSize(32, 32);
end;
destructor TIconItem.Destroy;
begin
Bmp.Free;
inherited;
end;
{ TIconItemList }
procedure TIconItemList.AddIconItem(var aIconItem: TIconItem);
begin
Add(aIconItem)
end;
procedure TIconItemList.Clear;
var
i: Integer;
begin
for i := 0 to Count-1 do
IconItem[i].Free;
inherited;
end;
function TIconItemList.GetIconItem(Index: Integer): TIconItem;
begin
Result := TIconItem(Items[Index]);
end;
{ TIconThread }
constructor TIconThread.Create;
begin
CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
inherited Create(True);
end;
destructor TIconThread.Destroy;
begin
CoUninitialize();
FreeAndNil(IconItem);
inherited;
end;
procedure TIconThread.Execute;
begin
inherited;
Synchronize(GetIcon);
//GetIcon; //スレッドセーフにしたいです。
end;
procedure TIconThread.GetIcon;
var
HICO: HICON;
begin
if IsFolder(IconItem.sr) then
HICO := GetDirIconHandle(IconItem.Path) else
HICO := GetExtFileIconHandle(IconItem.Path);
DrawIcon(IconItem.Bmp.Canvas.Handle,0,0,HICO);
DestroyIcon(HICO);
end;
{ TIconManager }
constructor TIconManager.Create;
begin
fIconItemList := TIconItemList.Create;
end;
destructor TIconManager.Destroy;
begin
fThreadStop := True;
repeat
Application.ProcessMessages;
until fThreadWorking = False;
fIconItemList.Clear;
fIconItemList.Free;
inherited;
end;
procedure TIconManager.GetIcon(aIconItem: TIconItem);
begin
fThreadStop := False;
fIconItemList.AddIconItem(aIconItem);
GetIconThread;
end;
procedure TIconManager.GetIconThread;
var
aIconThread: TIconThread;
aIconItem : TIconItem;
i:Integer;
begin
if fThreadStop then Exit;
if fIconItemList.Count <= 0 then Exit;
if fThreadWorking then Exit;
fThreadWorking := True;
i := fIconItemList.Count-1;
aIconItem := fIconItemList.IconItem[i];
fIconItemList.Delete(i);
aIconThread := TIconThread.Create;
aIconThread.Priority := tpLowest;
aIconThread.FreeOnTerminate := True;
aIconThread.OnTerminate := IconThreadOnTerminate;
aIconThread.IconItem := aIconItem;
aIconThread.Start;
end;
procedure TIconManager.IconThreadOnTerminate(Sender: TObject);
begin
if Assigned(fOnGetIcon) then
fOnGetIcon(Self,TIconThread(Sender).IconItem);
fThreadWorking := False;
GetIconThread;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
DoubleBuffered := True;
ImageList := TImageList.Create(Self);
ImageList.ColorDepth := cd32bit;
ImageList.SetSize(32,32);
ListView := TListView.Create(Self);
ListView.Parent := Self;
ListView.Align := alClient;
ListView.LargeImages := ImageList;
ListView.OwnerData := True;
ListView.OnData := ListViewData;
ListView.OnDblClick := ListViewDblClick;
FileList := TFileList.Create;
IconManager := TIconManager.Create;
IconManager.OnGetIcon := IconManagerOnGetIcon;
Directory:= ExtractFileDir(Application.ExeName);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
IconManager.Free;
FileList.Free;
end;
procedure TForm1.IconManagerOnGetIcon(Sender: TObject;
var aIconItem: TIconItem);
var
i: Integer;
aFileItem:TFileItem;
begin
for i := 0 to FileList.Count-1 do
begin
aFileItem := FileList.FileItem[i];
if aFileItem.sr.Name = aIconItem.sr.Name then
begin
ImageList.Add(aIconItem.Bmp,nil);
aFileItem.ImageIndex := ImageList.Count-1;
aFileItem.RequestState := rsExt;
Exit;
end;
end;
end;
procedure TForm1.ListViewData(Sender: TObject; Item: TListItem);
var
aFileItem:TFileItem;
aIconItem:TIconItem;
begin
aFileItem := FileList.FileItem[Item.Index];
Item.Caption := aFileItem.sr.Name;
Item.ImageIndex := aFileItem.ImageIndex;
Caption := aFileItem.sr.Name + ' ' + IntToStr(GetTickCount);
if aFileItem.RequestState = rsNone then
begin
aFileItem.RequestState := rsExtProcess;
aIconItem := TIconItem.Create;
aIconItem.Path := IncludeTrailingPathDelimiter(FileList.Directory) +
aFileItem.sr.Name;
aIconItem.sr := aFileItem.sr;
IconManager.GetIcon(aIconItem);
end;
end;
procedure TForm1.ListViewDblClick(Sender: TObject);
var
aFileItem:TFileItem;
begin
if ListView.Selected=nil then Exit;
if ListView.Selected.Index < 0 then Exit;
aFileItem := FileList.FileItem[ListView.Selected.Index];
if IsFolder(aFileItem.sr) then
begin
if aFileItem.sr.Name = '..' then
Directory := ExtractFileDir(FileList.Directory) else
Directory :=
IncludeTrailingPathDelimiter(FileList.Directory)+aFileItem.sr.Name;
end;
end;
procedure TForm1.SetDirectory(const Value: string);
begin
FileList.Directory := Value;
ImageList.Clear;
ListView.Items.Count := FileList.Count;
ListView.Repaint;
end;
end.
MLホームページ: http://www.freeml.com/delphi-users
----------------------------------------------------------------------
メンバーで使える掲示板を活用しよう！
http://ad.freeml.com/cgi-bin/sa.cgi?id=hV9Ck
------------------------------------------------------[freeml byGMO]--