unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    Label1: TLabel;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure ListBox1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  Registry,
  ShellAPI;

{$R *.DFM}

//=============================================================================
//  レジストリからShellコマンドのリストを取得
//  usesにRegistryが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LRegistry : TRegistry;
  LRegKey   : string;
  LRegItem  : string;
  LItemList : TStringList;
  i         : Integer;
begin
  Edit1.Text := '';

  LItemList         := TStringList.Create;
  LRegistry         := TRegistry.Create;
  LRegistry.Access  := KEY_READ;
  LRegistry.RootKey := HKEY_LOCAL_MACHINE;
  LRegKey := 'SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\FolderDescriptions';

  try
    //FolderDescriptions階層下のキー名(GUID)を列挙
    if LRegistry.OpenKey(LRegKey, False) then begin
      LRegistry.GetKeyNames(LItemList);
    end;
    LRegistry.CloseKey;

    //列挙したキーのName項目の値を取得してTListBoxに追加
    ListBox1.Sorted := True;
    ListBox1.Items.Clear;
    ListBox1.Items.BeginUpdate;
    for i := 0 to LItemList.Count - 1 do begin
      try
        if LRegistry.OpenKey(LRegKey + PathDelim + LItemList[i], False) then begin
          if not LRegistry.ValueExists('Name') then Continue;
          LRegItem := LRegistry.ReadString('Name');
          if LRegItem <> '' then begin
            ListBox1.Items.Add('shell:' + LRegItem);
          end;
        end;
      finally
        LRegistry.CloseKey;
      end;
    end;
    ListBox1.Items.EndUpdate;
    Label1.Caption := IntToStr(ListBox1.Items.Count);
  finally
    FreeAndNil(LRegistry);
    FreeAndNil(LItemList);
  end;
end;

//=============================================================================
//  ListBox1のOnDblClickイベント処理
//  TListBoxの選択中のShellコマンドを実行
//
//  64ビットWindowsでの実行
//  32ビットのEXEでは，コントロールパネル関係の一部のダイアログは表示できない
//  64ビットのEXEを作成して実行すれば表示可能　
//
//  usesにShellAPIが必要
//=============================================================================
procedure TForm1.ListBox1DblClick(Sender: TObject);
var
  LShellCmd : string;
  LRetCode  : Cardinal;
begin
  if ListBox1.ItemIndex < 0 then exit;

  LShellCmd := ListBox1.Items[ListBox1.ItemIndex];
  LRetCode  := ShellExecute(Handle, '', PChar(LShellCmd), nil, nil, SW_SHOW);

  if LRetCode <= 32 then begin
    MessageBox(Handle, PChar(SysErrorMessage(LRetCode)), '情報', MB_OK);
  end;
end;

//=============================================================================
//  ListBox1のOnClickイベント処理
//  Edit1にコマンド文字列を表示する(コピー用)
//=============================================================================
procedure TForm1.ListBox1Click(Sender: TObject);
begin
  if ListBox1.ItemIndex < 0 then exit;

  Edit1.Text := ListBox1.Items[ListBox1.ItemIndex];
end;

//=============================================================================
//  ListBox1のOnKeyDownイベント処理
//=============================================================================
procedure TForm1.ListBox1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if ListBox1.ItemIndex < 0 then exit;

  if Key = VK_RETURN then begin
    ListBox1DblClick(nil);
    Key := 0;
  end;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Buttons;

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    Label1: TLabel;
    Edit1: TEdit;
    SpeedButton1: TSpeedButton;
    procedure Button1Click(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ListBox1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure SpeedButton1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  Registry,
  ShellAPI,
  ShlObj,
  ActiveX;

{$R *.DFM}

//=============================================================================
//  フォーム破棄時の処理
//  ListBox1のオブジェクトを破棄
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
var
  i : Integer;
begin
  for i := 0 to ListBox1.Items.Count-1 do begin
    Dispose(PString(ListBox1.Items.Objects[i]));
  end;
end;

//=============================================================================
//  レジストリからShellコマンドのリストを取得
//  usesにRegistryが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);

  //---------------------------------------------------------------------------
  //  ListBox1に文字列と実行用のParsingName名をセット
  //---------------------------------------------------------------------------
  procedure AddItem(ACaption, APath: String);
  var
    pAddStr : PString;
  begin
    New(pAddStr);
    pAddStr^ := APath;
    ListBox1.AddItem(ACaption, TObject(pAddStr));
  end;
//-----------------------------------------------------------------------------

var
  LRegistry : TRegistry;
  LRegKey   : string;
  LRegItemName  : string;
  LRegItemPars  : string;
  LItemList : TStringList;
  i         : Integer;
begin
  Edit1.Text := '';

  LItemList         := TStringList.Create;
  LRegistry         := TRegistry.Create;
  LRegistry.Access  := KEY_READ;
  LRegistry.RootKey := HKEY_LOCAL_MACHINE;
  LRegKey := 'SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\FolderDescriptions';

  try
    //FolderDescriptions階層下のキー名(GUID)を列挙
    if LRegistry.OpenKey(LRegKey, False) then begin
      LRegistry.GetKeyNames(LItemList);
    end;
    LRegistry.CloseKey;

    //列挙したキーのName項目の値を取得してTListBoxに追加
    ListBox1.Sorted := True;
    ListBox1.Items.Clear;
    ListBox1.Items.BeginUpdate;
    for i := 0 to LItemList.Count - 1 do begin
      try
        if LRegistry.OpenKey(LRegKey + PathDelim + LItemList[i], False) then begin
          if not LRegistry.ValueExists('Name') then Continue;
          LRegItemName := LRegistry.ReadString('Name');
          if not LRegistry.ValueExists('ParsingName') then begin
            LRegItemPars := '';
          end else begin
            LRegItemPars := LRegistry.Readstring('ParsingName');
          end;

          if LRegItemName <> '' then begin
            AddItem('shell:' + LRegItemName, LRegItemPars);
          end;
        end;
      finally
        LRegistry.CloseKey;
      end;
    end;
    ListBox1.Items.EndUpdate;
    Label1.Caption := IntToStr(ListBox1.Items.Count);
  finally
    FreeAndNil(LRegistry);
    FreeAndNil(LItemList);
  end;
end;

//=============================================================================
//  ListBox1のOnDblClickイベント処理
//
//  TListBoxの選択中のShellコマンドを実行
//
//  64ビットWindowsでの実行
//  32ビットのEXEでは，コントロールパネル関係の一部のダイアログは表示できない
//  64ビットのEXEを作成して実行すれば表示可能　
//
//  usesにShellAPIが必要
//=============================================================================
procedure TForm1.ListBox1DblClick(Sender: TObject);
var
  LShellCmd : string;
  LRetCode  : Cardinal;
begin
  if ListBox1.ItemIndex < 0 then exit;

  if Edit1.Text <> '' then begin
    LShellCmd := Edit1.Text;
  end else begin
    LShellCmd := ListBox1.Items[ListBox1.ItemIndex];
  end;
  if LShellCmd <> '' then begin
    LRetCode  := ShellExecute(Handle, '', PChar(LShellCmd), nil, nil, SW_SHOW);

    if LRetCode <= 32 then begin
      MessageBox(Handle, PChar(SysErrorMessage(LRetCode)), '情報', MB_OK);
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  相対項目識別子からフォルダまたはファイル名を求める
//  仮想フォルダはGUID文字列として求まる
//
//  第1引数  対象の項目識別子を取得する際に使用したシェルフォルダオブジェクト
//  第2引数  対象の項目識別子．ShFolder階層下の相対値
//  第3引数  フルパスを取得する場合は，SHGDN_FORPARSING
//           ファイル名だけ取得する場合は，SHGDN_NORMALまたはSHGDN_INFOLDER
//-----------------------------------------------------------------------------
function GetDispNameFromPItemID(ShFolder: IShellFolder; ItemID:
  PItemIDList;Flag: DWORD=SHGDN_NORMAL): String;
var
  StrRet : TStrRet;
begin
  Result := '';
  if ShFolder = nil then exit;
  if ItemID = nil then exit;

  FillChar(StrRet, SizeOf(StrRet), 0);
  if NOERROR = ShFolder.GetDisplayNameOf(ItemID, Flag, StrRet) then begin
    Result := StrRet.pOleStr;
  end;
end;

//=============================================================================
//  ListBox1のOnClickイベント処理
//  Edit1にコマンド文字列の実パス名ディレクトリ名)を表示
//  仮想フォルダとコントロールパネル関係はGUID文字列となる
//
//  項目識別子から実パスを取得するSHGetPathFromIDList関数がある
//  SHGetPathFromIDListは仮想フォルダ等が取得できないので自前の関数を使用
//
//  usesにShlObj,Activeが必要
//=============================================================================
procedure TForm1.ListBox1Click(Sender: TObject);
var
  LPathBuff : array [0..MAX_PATH - 1] of Char;
  LShellCmd : string;
  LPItemID  : PItemIDList;
  LpDesktop : IShellFolder;
begin
  SpeedButton1.Visible := False;
  Edit1.Text := '';
  if ListBox1.ItemIndex < 0 then exit;

  //項目識別子を取得
  LShellCmd := ListBox1.Items[ListBox1.ItemIndex];
  LPItemID  := ILCreateFromPath(PChar(LShellCmd));

  //項目識別子からパス名を取得
  if LPItemID <> nil then begin
    FillChar(LPathBuff, SizeOF(LPathBuff), #0);
    SHGetPathFromIDList(LPItemID, LPathBuff);
    Edit1.Text := LPathBuff;

    if Edit1.Text = '' then begin
      //[デスクトップ]のシェルフォルダオブジェクトを取得
      SHGetDesktopFolder(LpDesktop);
      //デスクトップフォルダオブジェクトの項目識別子としてパス名を取得
      Edit1.Text := GetDispNameFromPItemID(LpDesktop, LPItemID, SHGDN_FORPARSING);
    end;

    CoTaskMemFree(LPItemID);
  end;

  if Edit1.Text = '' then begin
    Edit1.Text :=  PString(ListBox1.Items.Objects[ListBox1.ItemIndex])^;
  end;
  SpeedButton1.Visible := Edit1.Text <> '';
end;

//=============================================================================
//  ListBox1のOnKeyDownイベント処理
//=============================================================================
procedure TForm1.ListBox1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if ListBox1.ItemIndex < 0 then exit;

  if Key = VK_RETURN then begin
    ListBox1DblClick(nil);
    Key := 0;
  end;
end;

end.

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  LpDesktop   : IShellFolder;
  LStringList : TStringList;
  LPItemID    : PItemIDList;
  LText       : string;
  LPathText   : string;
  i           : Integer;
begin
  if Edit1.Text = '' then exit;

  SHGetDesktopFolder(LpDesktop);

  LStringList := TStringList.Create;
  try
    LStringList.Delimiter       := PathDelim;
    LStringList.StrictDelimiter := True;
    LStringList.DelimitedText   := Edit1.Text;

    LText     := '';
    LPathText := '';
    for i := 0 to LStringList.Count - 1 do begin

      LText    := LText + LStringList[i];
      LPItemID := ILCreateFromPath(PChar(LText));
      if i = 0 then begin
        LPathText := GetDispNameFromPItemID(LpDesktop, LPItemID, SHGDN_NORMAL);
      end else begin
        LPathText := LPathText + sLineBreak
                   + GetDispNameFromPItemID(LpDesktop, LPItemID, SHGDN_NORMAL);
      end;

      if i < LStringList.Count - 1 then begin
        LText := LText + PathDelim;
      end;
    end;
    CoTaskMemFree(LPItemID);

    MessageBox(Handle, PChar(LPathText), 'パスリスト', MB_ICONINFORMATION);
  finally
    FreeAndNil(LStringList);
  end;
end;

//-----------------------------------------------------------------------------
//  コントロールパネルの[表示方法]
//  レジストの[表示方法]の[大きいアイコン]または[小さいアイコン]の設定
//
//  AValue = -1 の時は現在の設定値の読み出し
//  AValue = 0 の時は大きいアイコン
//  AValue = 1 の時は小さいアイコン
//
//  戻り値は現在の設定値
//  対象の項目がない場合は-1を返す
//  書き込みに失敗した場合も-1を返す
//-----------------------------------------------------------------------------
function TForm1.IconReadWriteValue_Registry(AValue: Integer): Integer;
var
  LRegistry     : TRegistry;
  LRegKey       : String;
  LRegistryItem : string;
begin
  Result := -1;
  LRegistryItem  := 'AllItemsIconView';


  LRegistry := TRegistry.Create;
  try
    LRegistry.Access  := KEY_WRITE or KEY_READ;
    LRegistry.RootKey := HKEY_CURRENT_USER;
    LRegKey           := 'Software\Microsoft\Windows\CurrentVersion\Explorer\'
                       + 'ControlPanel';

    if LRegistry.OpenKey(LRegKey, False) then begin
      try
        try
          Result := LRegistry.ReadInteger(LRegistryItem);
          if (Result >= 0) and (AValue >= 0) then begin
            LRegistry.WriteInteger(LRegistryItem, AValue);
          end;
        except
          Result := -1;
        end;
      finally
        LRegistry.CloseKey;
      end;
    end;
  finally
    FreeAndNil(LRegistry);
  end;
end;

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    Label1: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure ListBox1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

  function SHLoadIndirectString(pszSource, psuOutBuf: PWideChar; const ccOutBuf:
     UINT; var ppvReserved: Pointer): HRESULT; stdcall; external 'ShLwApi.dll';

var
  Form1: TForm1;

implementation

uses
  Registry,
  ShellAPI;

{$R *.DFM}

//=============================================================================
//  フォーム破棄時の処理
//  ListBox1のオブジェクトを破棄
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
var
  i : Integer;
begin
  for i := 0 to ListBox1.Items.Count-1 do begin
    Dispose(PString(ListBox1.Items.Objects[i]));
  end;
end;

//-----------------------------------------------------------------------------
//  レジストリの項目に以下のようなリソースのデータの記述がある
//  @%SystemRoot%\system32\shell32.dll,-31361
//  この値を元にしてDLLから文字列リソースを取り出す
//  取得できなかった場合は空文字を返す
//-----------------------------------------------------------------------------
function ReadStrResourceFromRegItemValue(ARegItem: string): string;
var
  LBuffer  : array [0..4095] of WideChar;
  LPointer : Pointer;
begin
  Result := '';
  FillChar(LBuffer[0], SizeOf(LBuffer), #0);
  if SHLoadIndirectString(PWideChar(ARegItem),
                          LBuffer,
                          Length(Lbuffer),
                          LPointer) = S_OK then begin
    Result := Lbuffer;
  end;
end;

//=============================================================================
//  コントロールパネル関係とシステム関係ダイアログ関係のCLSID(GUID)値を取得
//  ダイアログの説明文はDLLのリソースから取得
//
//  usesにRegistry,HTTPAppが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);

  //---------------------------------------------------------------------------
  //  ListBox1の項目とObjectsプロパティに値をセット
  //---------------------------------------------------------------------------
  procedure AddItem(ACaption, APath: String);
  var
    pAddStr : PString;
  begin
    New(pAddStr);
    pAddStr^ := APath;
    ListBox1.AddItem(ACaption, TObject(pAddStr));
  end;
  //---------------------------------------------------------------------------

var
  LRegistry   : TRegistry;
  LRegKey     : string;
  LRegItem    : string;
  LItemList   : TStringList;
  i           : Integer;
begin
  Edit1.Text := '';
  Edit2.Text := '';
  Edit3.Text := '';
  Edit1.Update;
  Edit2.Update;
  Edit3.Update;

  LItemList         := TStringList.Create;
  LRegistry         := TRegistry.Create;
  LRegistry.Access  := KEY_READ;
  LRegistry.RootKey := HKEY_LOCAL_MACHINE;
  LRegKey           := 'SOFTWARE\Classes\CLSID';

  try
    //CLSIDの値を列挙
    if LRegistry.OpenKey(LRegKey, False) then begin
      LRegistry.GetKeyNames(LItemList);
    end;
    LRegistry.CloseKey;

    ListBox1.Items.Clear;
    ListBox1.Items.BeginUpdate;
    for i := 0 to LItemList.Count - 1 do begin
      try
        if LRegistry.OpenKey(LRegKey + PathDelim + LItemList[i], False) then begin
          if not LRegistry.ValueExists('InfoTip') then Continue;

          LRegItem := LRegistry.ReadString('InfoTip');
          //レジストリのデータから文字列リソースを取得
          LRegItem := ReadStrResourceFromRegItemValue(LRegItem);
          if LRegItem <> '' then begin
            AddItem('shell:::' + LItemList[i], LRegItem);
          end;
        end;
      finally
        LRegistry.CloseKey;
      end;
    end;
    ListBox1.Items.EndUpdate;
    Label1.Caption := IntToStr(ListBox1.Items.Count);
  finally
    FreeAndNil(LRegistry);
    FreeAndNil(LItemList);
  end;
end;

//=============================================================================
//  ListBox1のOnDblClickイベント処理
//  TListBoxの選択中のShellコマンドを実行
//
//  64ビットWindowsでの実行
//  32ビットのEXEでは，コントロールパネル関係の一部のダイアログは表示できない
//  64ビットのEXEを作成して実行すれば表示可能　
//
//  usesにShellAPIが必要
//=============================================================================
procedure TForm1.ListBox1DblClick(Sender: TObject);
var
  LShellCmd : string;
  LRetCode  : Cardinal;
begin
  if ListBox1.ItemIndex < 0 then exit;

  LShellCmd := ListBox1.Items[ListBox1.ItemIndex];
  LRetCode  := ShellExecute(Handle, '', PChar(LShellCmd), nil, nil, SW_SHOW);

  if LRetCode <= 32 then begin
    MessageBox(Handle, PChar(SysErrorMessage(LRetCode)), '情報', MB_OK);
  end;
end;

//=============================================================================
//  ListBox1のOnClickイベント処理
//  Edit1にコマンド文字列を表示する
//=============================================================================
procedure TForm1.ListBox1Click(Sender: TObject);
var
  LItemText : string;
  LRegistry : TRegistry;
  LRegKey   : string;
  LRegItem  : string;
begin
  if ListBox1.ItemIndex < 0 then exit;

  LItemText  := ListBox1.Items[ListBox1.ItemIndex];
  Edit1.Text := LItemText;
  Edit3.Text := PString(ListBox1.Items.Objects[ListBox1.ItemIndex])^;

  //参考としてLocalizedStringの値を取得して表示
  LRegistry         := TRegistry.Create;
  LRegistry.Access  := KEY_READ;
  LRegistry.RootKey := HKEY_LOCAL_MACHINE;
  LItemText := StringReplace(LItemText,  'shell:::', '', []);
  LRegKey   := 'SOFTWARE\Classes\CLSID' + PathDelim + LItemText;
  try
    if LRegistry.OpenKey(LRegKey, False) then begin
      if LRegistry.ValueExists('LocalizedString') then begin
        LRegItem := LRegistry.ReadString('LocalizedString');
        //レジストリのデータから文字列リソースを取得
        LRegItem := ReadStrResourceFromRegItemValue(LRegItem);
        if LRegItem <> '' then begin
          Edit2.Text := LRegItem;
        end;
      end;
      LRegistry.CloseKey;
    end;
  finally
    FreeAndNil(LRegistry);
  end;
end;

//=============================================================================
//  ListBox1のOnKeyDownイベント処理
//=============================================================================
procedure TForm1.ListBox1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if ListBox1.ItemIndex < 0 then exit;

  if Key = VK_RETURN then begin
    ListBox1DblClick(nil);
    Key := 0;
  end;
end;

end.