显示多个文件/目录的属性对话框

下面的代码可以实现这个要求，但是对于磁盘根目录还是有问题。

{ Copyright Kingron， 2005 }

uses ActiveX , ShlObj , ComObj ;

function SHMultiFileProperties ( pDataObj : IDataObject ; Flag : DWORD ): HRESULT ; stdcall ; external 'shell32.dll' ;

function GetFileListDataObject ( Files : TStrings ): IDataObject ;

type

 PArrayOfPItemIDList = ^ TArrayOfPItemIDList ;

 TArrayOfPItemIDList = array [ 0 .. 0 ] of PItemIDList ;

var

 Malloc : IMalloc ;

 Root : IShellFolder ;

 p : PArrayOfPItemIDList ;

 chEaten , dwAttributes : ULONG ;

 i , FileCount : Integer ;

begin

 Result := nil ;

 FileCount := Files . Count ;

  if FileCount = 0 then Exit ;

 OleCheck ( SHGetMalloc ( Malloc ));

 OleCheck ( SHGetDesktopFolder ( Root ));

 p := AllocMem ( SizeOf ( PItemIDList ) * FileCount );

  try

    for i := 0 to FileCount - 1 do

    try

      if not ( DirectoryExists ( Files [ i ]) or FileExists ( Files [ i ])) then Continue ;

     OleCheck ( Root . ParseDisplayName ( GetActiveWindow ,

                                    nil ,

                                    PWideChar ( WideString ( Files [ i ])),

                                    chEaten ,

                                    p ^[ i ],

                                    dwAttributes ));

    except

    end ;

   OleCheck ( Root . GetUIObjectOf ( GetActiveWindow ,

                               FileCount ,

                               p ^[ 0 ],

                               IDataObject ,

                                nil ,

                               Pointer ( Result )));

  finally

    for i := 0 to FileCount - 1 do

    begin

      if p ^[ i ] <> nil then Malloc . Free ( p ^[ i ]);

    end ;

   FreeMem ( p );

  end ;

end ;

procedure ShowFileProperties ( Files : TStrings ; aWnd : HWND );

var

 Data : IDataObject ;

begin

  if Files . Count = 0 then Exit ;

 Data := GetFileListDataObject ( Files );

 SHMultiFileProperties ( Data , 0 );

end ;

procedure TForm1 . Button1Click ( Sender : TObject );

begin

  if OpenDialog1 . Execute then

   Memo1 . Lines . AddStrings ( OpenDialog1 . Files );

end ;

procedure TForm1 . Button2Click ( Sender : TObject );

begin

 ShowFileProperties ( Memo1 . Lines , 0 );

end ;