お知らせ

電子会議

ライブラリ

パレット

Delphi FAQ検索

Delphi FAQ一覧

サンプル蔵





FDelphi FAQ
１６番会議室「玉石混淆みんなで作るSample蔵」に寄せられたサンプル

"PopupMenuにデスクトップ項目を列挙1" 


この発言に対し以下のコメントが寄せられています

#01282　Wacky           さん　RE:PopupMenuにデスクトップ項目を列挙1








Wacky と申します。
ポップアップメニューにデスクトップ項目を列挙するサンプルです。
すべての仮想フォルダをメニューから開くことができます。再帰処理
していますが、パスとして表現できるフォルダまでたどり着いたら、
それ以上は掘り進まないようになっています。ランチャーなどへの応
用が可能かと思います。

長いのですが全文掲載します。次の発言と合わせてユニットに貼り付
けてください。

◇動作確認
　Delphi5 Professional / Windows 2000、Windows Me

◇実行
　フォームに ImageList と PopupMenu を配置してください。

◇謝辞
　以下の４つの関数は、Fermion さん(KHF03264@nifty.ne.jp)にご提供いただき
　ました。丁寧にご指導くださった Fermion さんはじめ、FDELPHI の皆さんに
　心より御礼申し上げます。

    function GetNextItem( const PIDL: PItemIDList ): PItemIDList;
    function GetSize( PIDL: PItemIDList ): Cardinal;
    function Copy( const PIDL: PItemIDList ): PItemIDList;
    function Concatenate( const PIDL1, PIDL2: PItemIDList ): PItemIDList;

//------------------------------------------------------------------------
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, ShellAPI, ShlObj, ActiveX, ComObj, ImgList, StdCtrls;

type
  TForm1 = class(TForm)
    ImageList1: TImageList;
    PopupMenu1: TPopupMenu;
    procedure GetDesktopItems(var MenuItem: TMenuItem);
    procedure GetSubItems(ShellFolder: IShellFolder; itemIDList,
        itemIDList_Full: PItemIDList; var SubMenuItem: TMenuItem);
    procedure InsertParentFolder(var MenuItem: TMenuItem);
    procedure FileExec(strFileName: String);
    procedure FileExecEx(pidl: PItemIDList);
    procedure OpenProperty(pPath: PChar; isFile: Boolean);
    procedure PopupMenuClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  end;

var
  Form1: TForm1;
  IDlist: TList;

implementation

{$R *.DFM}

var
  Malloc: IMalloc;
  DesktopShellFolder: IShellFolder;

const
  CPIDL_TERMINATOR_SIZE = SizeOf( WORD );
{*************************************************************************
   PIDL 中の次の Item へのポインタを返す
   ・次が存在しない場合は nil を返す。
   ・次が存在しないという判定は mkid.cb = 0 で判断する。
//***********************************************************************}
function GetNextItem( const PIDL: PItemIDList ): PItemIDList;
var
  Len: Cardinal;
begin
  Result := nil;
  if not Assigned( PIDL ) then Exit;
  Len := PIDL^.mkid.cb;
  if Len <> 0 then
    Result := PItemIDList( PChar( PIDL ) + Len );
end;
{*************************************************************************
   PIDL のサイズを求める
//***********************************************************************}
function GetSize( PIDL: PItemIDList ): Cardinal;
begin
  Result := 0;
  if not Assigned( PIDL ) then Exit;
  Inc( Result, PIDL^.mkid.cb + CPIDL_TERMINATOR_SIZE );
  PIDL := GetNextItem( PIDL );
  while Assigned( PIDL ) do begin
    Inc( Result, PIDL^.mkid.cb );
    PIDL := GetNextItem( PIDL );
  end;{while Assigned( PIDL ) do}
end;
{*************************************************************************
   新たに PItemIDList を生成し PIDL をコピーする
//***********************************************************************}
function Copy( const PIDL: PItemIDList ): PItemIDList;
var
  cb: Cardinal;
begin
  Result := nil;
  if not Assigned( PIDL ) then Exit;
  cb     := GetSize( PIDL );
  Result := Malloc.Alloc( cb );
  if Assigned( Result ) then
    begin
      FillChar( Result^, cb, 0 );
      Move( PIDL^, Result^, cb );
    end;
end;
{*************************************************************************
   PIDL1 に PIDL2 を連結した PIDL を生成
//***********************************************************************}
function Concatenate( const PIDL1, PIDL2: PItemIDList ): PItemIDList;
var
  cb1, cb2, TotalSize: Cardinal;
begin
  Result := nil;
  if ( not Assigned( PIDL1 )) and ( not Assigned( PIDL2 )) then Exit;
  if not Assigned( PIDL1 ) then
    begin
      Result := Copy( PIDL2 );
      Exit;
    end;{if not Assigned( PIDL1 ) then}
  if not Assigned( PIDL2 ) then
    begin
      Result := Copy( PIDL1 );
      Exit;
    end;{if not Assigned( PIDL2 ) then}
  cb1 := GetSize( PIDL1 ) - CPIDL_TERMINATOR_SIZE;
  cb2 := GetSize( PIDL2 );
  TotalSize := cb1 + cb2;
  Result := Malloc.Alloc( TotalSize );
  if Assigned( Result ) then
    begin
      FillChar( Result^, TotalSize, 0 );
      Move( PIDL1^, Result^, cb1 );
      Move( PIDL2^, Pointer( Cardinal( Result ) + cb1 )^, cb2 );
    end;{if Assigned( Result ) then}
end;
//------------------------------------------------------------------------
//  デスクトップ直下のアイテムを列挙する
//------------------------------------------------------------------------
procedure TForm1.GetDesktopItems(var MenuItem: TMenuItem);
var
  enumIDList: IEnumIDList;
  celt: ULONG;
  itemIDList: PItemIDList;
  pceltFetched: ULONG;
  sfi: TSHFileInfo;
  Icon: TIcon;
  NewMenuItem: TMenuItem;
  NewImageIndex: integer;
begin
  Icon := TIcon.Create;
  try
    // IEnumIDList インターフェースを取得
    OleCheck(DesktopShellFolder.EnumObjects(Self.Handle,
        SHCONTF_FOLDERS or SHCONTF_NONFOLDERS, enumIDList));
    // 列挙されたそれぞれのアイテムについて
    celt:= ULONG(1);
    pceltFetched:= ULONG(0);
    while enumIDList.Next(celt, itemIDList, pceltFetched) = NOERROR do
    begin
      // アイコンと表示名を取得
      SHGetFileInfo(PChar(itemIDList), 0, sfi, SizeOf(TSHFileInfo),
          SHGFI_PIDL or SHGFI_ICON or SHGFI_SMALLICON or SHGFI_DISPLAYNAME);
      Icon.Handle := sfi.hIcon;
      NewImageIndex := ImageList1.AddIcon(Icon);
      // メニュー項目を作成し、アイコン・キャプション・PItemIDListを保存
      NewMenuItem := TMenuItem.Create(Self);
      with NewMenuItem do begin
        ImageIndex := NewImageIndex;
        Caption := String(sfi.szDisplayName);
        Tag := IDlist.Add(itemIDList);
      end;
      // 下位階層のアイテムを取得
      GetSubItems(DesktopShellFolder, itemIDList, itemIDList, NewMenuItem);
      // 下位階層にアイテムがなければクリックイベントを設定
      if NewMenuItem.Count = 0 then begin
        NewMenuItem.OnClick := PopupMenuClick;
      end;
      MenuItem.Add(NewMenuItem);
    end;
    // デスクトップ自体を開くメニューを挿入
    InsertParentFolder(MenuItem);
  finally
    Icon.ReleaseHandle;
    Icon.Free;
    Malloc._Release();
  end;
end;
//------------------------------------------------------------------------
//  サブフォルダを取得する(再帰呼び出し)
//------------------------------------------------------------------------
procedure TForm1.GetSubItems(ShellFolder: IShellFolder; itemIDList,
        itemIDList_Full: PItemIDList; var SubMenuItem: TMenuItem);
var
  ShellFolder_Sub: IShellFolder;
  enumIDList_Sub: IEnumIDList;
  itemIDList_Sub: PItemIDList;
  celt: ULONG;
  pceltFetched: ULONG;
  sfi: TSHFileInfo;
  Icon: TIcon;
  NewSubMenuItem: TMenuItem;
  NewSubImageIndex: Integer;
  IconCaption: String;
  Name: TSTRRET;
  Path : array [0..MAX_PATH] of Char;
  HasRealPath: Boolean;
begin
  Icon := TIcon.Create;
  try
    // フォルダの IShellFolder を取得
    if ShellFolder.BindToObject(itemIDList, nil,
        IID_ISHELLFOLDER, ShellFolder_Sub) = NOERROR then
    begin
      // フォルダの中身を列挙する
      if ShellFolder_Sub.EnumObjects(Self.Handle, SHCONTF_FOLDERS or
          SHCONTF_NONFOLDERS, enumIDList_Sub) = NOERROR then
      begin
        // それぞれのアイテムについて
        celt:= ULONG(1);
        pceltFetched := ULONG(0);
        while enumIDList_Sub.Next(celt,
            itemIDList_Sub, pceltFetched) = NOERROR do
        begin
          // 表示名と
          Name.uType := STRRET_CSTR;
          if ShellFolder_Sub.GetDisplayNameOf(itemIDList_Sub,
              SHGDN_NORMAL, Name) = NOERROR then
          begin
            case Name.uType of
              STRRET_CSTR: IconCaption := Name.cStr;
              STRRET_OFFSET: IconCaption := PChar(itemIDList_Sub) +
                  Name.uOffset;
              STRRET_WSTR: IconCaption := Name.pOleStr;
            end;
          end;
          // アイコンを取得
          SHGetFileInfo(PChar(Concatenate(itemIDList_Full, itemIDList_Sub)),
              0, sfi, SizeOf(TSHFileInfo), SHGFI_PIDL or SHGFI_ICON or
              SHGFI_SMALLICON or SHGFI_DISPLAYNAME);
          Icon.Handle := sfi.hIcon;
          NewSubImageIndex := ImageList1.AddIcon(Icon);
          // メニュー項目を作成し、アイコン・キャプション・PItemIDListを保存
          NewSubMenuItem := TMenuItem.Create(Self);
          with NewSubMenuItem do begin
            ImageIndex := NewSubImageIndex;
            Caption := IconCaption;
            Tag := IDlist.Add(Concatenate(itemIDList_Full, itemIDList_Sub));
          end;
          // 仮想フォルダならばサブフォルダを取得
          HasRealPath := SHGetPathFromIDList(
              Concatenate(itemIDList_Full, itemIDList_Sub), Path);
          if HasRealPath = False then
          begin
            GetSubItems(ShellFolder_Sub, itemIDList_Sub,
                Concatenate(itemIDList_Full, itemIDList_Sub), NewSubMenuItem);
          end;
          // 下位階層にアイテムがなければクリックイベントを設定
          if NewSubMenuItem.Count = 0 then begin
            NewSubMenuItem.OnClick := PopupMenuClick;
          end;
          SubMenuItem.Add(NewSubMenuItem);
        end;
      end;
      // フォルダの中身があったら、フォルダ自体を開くメニューを挿入
      if SubMenuItem.Count > 0 then begin
        InsertParentFolder(SubMenuItem);
      end;
    end;
  finally
    Icon.ReleaseHandle;
    Icon.Free;
  end;
end;

 


Original document by Wacky           氏 ID:(HQL05475)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。
Copyright 1996-2002 Delphi Users' Forum