unit RegistExtUnit;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    RegistFileExt : String;
    function SetResistryFileExt(RegistAppExePath, RegistAppParams, RegistFileExt,
      RegistAppReff, RegistAppText: String): Integer;
    function DeleteResistryFileExt(RegistFileExt: String): Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  Registry,
  ShlObj,
  plCommandRedirect;

{$R *.dfm}

//=============================================================================
//  拡張子の関連付けがされていればそのファイル(ここではwmf画像)を表示
//
//  サンプルプログラムのフォルダ内のE_frog.plXRAYの本来の拡張子はwmf
//  拡張子がTPictureが扱えるタイプではないのでTPicture.LoadFromFileは使用不可
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LFilePath : string;
  LMetaFile : TMetaFile;
begin
  Image1.Stretch := True;

  if ParamStr(1) <> '' then begin
    LMetaFile := TMetafile.Create;
    try
      try
        LFilePath := ParamStr(1);
        LMetaFile.LoadFromFile(LFilePath);
        Image1.Picture.Assign(LMetaFile);
      except
      end;
    finally
      FreeAndNil(LMetaFile);
    end;
  end;

  //登録する拡張子
  RegistFileExt := 'plXRAY';
end;

//=============================================================================
//  レジストリに新しい拡張子と関連付けを登録
//  管理者権限での実行が必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LAppPath       : String;
  LStrParams     : String;
  LRegistAppReff : String;
  LRegistAppText : String;
  LiRet          : Integer;
begin
  //拡張子に関連付けるアプリのEXEのフルパス
  //ここではこのサンプルプログラムとする
  LAppPath   := Application.ExeName;
  LStrParams := '%1';
  //参照名
  LRegistAppReff := 'plXRAYFile';
  //エクスプローラの種類名
  LRegistAppText := '特別画像ファイル';


  LiRet := SetResistryFileExt(LAppPath,
                              LStrParams,
                              RegistFileExt,
                              LRegistAppReff,
                              LRegistAppText);
  if LiRet = 1 then begin
    MessageBox(Handle, '拡張子を登録しました．', '情報', MB_ICONINFORMATION);
  end else
  if LiRet = 0 then begin
    MessageBox(Handle, '拡張子の登録に失敗しました．', '情報', MB_ICONWARNING);
  end else begin
    MessageBox(Handle, 'この拡張子は登録済です．', '情報', MB_ICONWARNING);
  end;
end;

//=============================================================================
//  レジストリから拡張子の情報を削除
//  管理者権限での実行が必要
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  if DeleteResistryFileExt(RegistFileExt) then begin
    MessageBox(Handle, '拡張子情報を削除しました．', '情報', MB_ICONINFORMATION);
  end else begin
    MessageBox(Handle, ' この拡張子は登録されていません．', '情報', MB_ICONWARNING);
  end;
end;

//=============================================================================
//  レジストリに新しい拡張子とアプリケーションの関連づけを登録
//  管理者権限での実行が必要
//
//  RegistAppExePath 起動するアプリケーションのフルパス
//  RegistAppParams  そのアプリの起動時パラメータ
//  RegistFileExt    そのアプリに関連付けする拡張子名(.は付けない)
//  RegistAppReff    参照名(適当に．レジストリから関連付けを削除する際に必要)
//  RegistAppText    エクスプローラで表示した時のファイルの説明用
//
//  TRegistryの使用にはusesにRegistryが必要
//  SH...の使用にはusesにはShlObjが必要
//=============================================================================
function TForm1.SetResistryFileExt(RegistAppExePath, RegistAppParams, RegistFileExt,
  RegistAppReff, RegistAppText: String): Integer;
var
 LRegistry : TRegistry;
begin
  LRegistry := TRegistry.Create(KEY_READ or KEY_WRITE);
  try
    LRegistry.RootKey := HKEY_CLASSES_ROOT;

    //登録済みの場合は何もしない
    if LRegistry.OpenKeyReadOnly('.' + RegistFileExt) then begin
      LRegistry.CloseKey;
      Result := -1;
    end else begin
      if (RegistFileExt = '') or (RegistFileExt = '.') or
          (RegistAppReff = '') then begin
        Result := 0;
      end else begin

        //パス名に空白文字が含まれる場合はダブルクォーテーションが必要
        //バス名に漢字が含まれる場合も必要なようである
        RegistAppExePath := AnsiQuotedStr(RegistAppExePath, '"');
        RegistAppParams  := AnsiQuotedStr(RegistAppParams, '"');

        //拡張子のキーを作成
        if LRegistry.OpenKey('\.' + RegistFileExt, True) then begin

          if (RegistFileExt = '') or (RegistFileExt = '.') or
               (RegistAppReff = '') then begin
            LRegistry.CloseKey;
            Result := 0;
          end else begin
            //参照名を登録
            LRegistry.WriteString('', RegistAppReff);

            //参照名のキーを作成
            if LRegistry.OpenKey('\' + RegistAppReff, True) then begin
              //エクスプローラに表示する説明用文字列の登録
              LRegistry.WriteString('', RegistAppText);

              //アイコンの参照キー指定
              //ここでは登録するアプリのアイコンとする
              LRegistry.OpenKey('\' + RegistAppReff + '\DefaultIcon', True);
              LRegistry.WriteString('', RegistAppExePath + ', 0');

              //アプリケーションのOpen\Commandキーを作成してEXEのパス名を記録
              LRegistry.OpenKey('\' + RegistAppReff + '\shell\open\command', True);
              if Trim(RegistAppParams) = '' then begin
                LRegistry.WriteString('', RegistAppExePath);
              end else begin
                LRegistry.WriteString('', RegistAppExePath + ' ' + RegistAppParams);
              end;
            end;

            //システムに変更を通知
            SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, nil, nil);
            Result := 1;
          end;
        end else begin
          Result := 0;
        end;
      end;
    end;
  finally
    FreeAndNil(LRegistry);
  end;
end;

//=============================================================================
//  登録した拡張子関係のキーをレジストリから削除
//  管理者権限での実行が必要
//
//  RegistFileExt 登録済みの拡張子名(.は付けない)
//
//  TRegistryの使用にはusesにRegistryが必要
//=============================================================================
function TForm1.DeleteResistryFileExt(RegistFileExt: String): Boolean;

  //---------------------------------------------------------------------------
  //  ファイルの拡張子からアプリケーションの参照名の値を取得する
  //  AppFileExe : ファイルの拡張子(.は付けない)
  //---------------------------------------------------------------------------
  function GetAppProgIDName(AppFileExt: String): String;
  var
    LRegistry : TRegistry;
  begin
    Result := '';
    LRegistry := TRegistry.Create(KEY_READ);
    try
      LRegistry.RootKey := HKEY_CLASSES_ROOT;

      //該当する拡張子が登録されていなければ取得できない
      if LRegistry.OpenKeyReadOnly('\.' + AppFileExt) then begin
        Result := LRegistry.ReadString('');
      end;
    finally
      FreeAndNil(LRegistry);
    end;
  end;
  //---------------------------------------------------------------------------

var
  LRegistAppReff  : string;
  LRegAppFileExt  : string;
  LRegAppProgID   : string;
  LRegExplorerExt : string;
  LCmdLine        : TplCommandRedirect;
  LCmdStr         : string;
begin
  LRegistAppReff := GetAppProgIDName(RegistFileExt);

  if (RegistFileExt = '') or (RegistFileExt = '.') or
      (LRegistAppReff = '') then begin
    Result := False;
  end else begin

    LRegAppFileExt  := 'HKEY_CLASSES_ROOT\' + '.' + RegistFileExt;
    LRegAppProgID   := 'HKEY_CLASSES_ROOT\' + LRegistAppReff;
    LRegExplorerExt := 'HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\'
                    + 'Explorer\FileExts\' + '.' + RegistFileExt;

    //対象のキーの有無に関わらず削除のコードを実行
    LCmdLine := TplCommandRedirect.Create;
    try
      //ここには記録されていない場合がある
      LCmdStr := 'Cmd.exe /k reg delete ' + LRegExplorerExt + ' /f';
      LCmdLine.GrabStdOutText(LCmdStr);

      LCmdStr := 'Cmd.exe /k reg delete ' + LRegAppProgID + ' /f';
      LCmdLine.GrabStdOutText(LCmdStr);

      LCmdStr := 'Cmd.exe /k reg delete ' + LRegAppFileExt + ' /f';
      LCmdLine.GrabStdOutText(LCmdStr);

      //システムに変更を通知
      SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, nil, nil);

      Result := True;
    finally
      FreeAndNil(LCmdLine);
    end;
  end;
end;

end.

procedure TForm1.Button1Click(Sender: TObject);
var
  LAppPath       : string;
  LStrParams     : string;
  LRegistAppReff : string;
  LRegistAppText : string;
  LiRet          : Integer;
begin
  //拡張子に関連付けるアプリのEXEのフルパス
  //ここではこのサンプルプログラムとする
  LAppPath   := 'C:\Windows\System32\mspaint.exe';
  LStrParams := '%1';
  //参照名
  LRegistAppReff := 'plXRAYFile';
  //エクスプローラの種類名
  LRegistAppText := '特別画像ファイル';

  //以下，省略

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  //登録する拡張子
  RegistFileExt := 'plDoc';
end;

//=============================================================================
//  レジストリに新しい拡張子と関連付けを登録
//  管理者権限での実行が必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LAppPath       : string;
  LStrParams     : string;
  LRegistAppReff : string;
  LRegistAppText : string;
  LiRet          : Integer;
begin
  //拡張子に関連付けるアプリのEXEのフルパス
  LAppPath   := ExtractFilePath(Application.ExeName) + 'TestApp\SimpleWord.exe';
  LStrParams := '%1';
  //参照名
  LRegistAppReff := 'plXWordExFile';
  //エクスプローラの種類名
  LRegistAppText := 'ワード操作フォームファイル';

  //以下，省略

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses plSIDUtilty;

{$R *.dfm}

//=============================================================================
//  ログインユーザのSIDを取得
//  文字列に変換して表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  StrText : String;
begin
  StrText := plSIDUtilty.GetCurrentUserSIDString;
  ShowMessage(StrText);
end;

//=============================================================================
//  ローカルコンピュータのSIDを取得
//  文字列に変換して表示
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  StrText : String;
begin
  StrText := plSIDUtilty.GetLocalComputerSIDString;
  ShowMessage(StrText);
end;

end.

unit plSIDUtilty;

interface

uses Windows, ShlObj;

function GetCurrentUserSID: PSID;
function GetCurrentUserSIDString: String;
function GetLocalComputerSID: PSID;
function GetLocalComputerSIDString: String;

implementation

function ConvertSidToStringSid(Sid: PSID; out StringSid: PChar): BOOL; stdcall;
  external 'ADVAPI32.DLL' name 'ConvertSidToStringSidW';

//-----------------------------------------------------------------------------
//  ローカルコンピュータ名を取得する関数
//-----------------------------------------------------------------------------
function GetLocalComputerName: String;
var
  Buff  : array [0..MAX_COMPUTERNAME_LENGTH-1] of Char;
  ASize : Cardinal;
begin
  ASize := SizeOf(Buff);
  if Windows.GetComputerName(Buff, ASize) then begin
    Result := String(Buff);
  end else begin
    Result := '';
  end;
end;

//-----------------------------------------------------------------------------
//  ログインユーザ名を取得する関数
//-----------------------------------------------------------------------------
function GetLoginUserName: String;
var
  Buff  : array [0..MAX_PATH-1] of Char;
  ASize : Cardinal;
begin
  ASize := SizeOf(Buff);
  if Windows.GetUserName(Buff, ASize) then begin
    Result := String(Buff);
  end else begin
    Result := '';
  end;
end;

//-----------------------------------------------------------------------------
//  ログインユーザまたはローカルコンピュータのSIDを取得する関数
//  IsUserSIDがTureの時はログインユーザのSIDを取得する
//-----------------------------------------------------------------------------
function GetCurrentUserOrComputerSID(IsUserSID: Boolean): PSID;
var
  lpSystemName  : String;
  lpAccountName : String;
  Sid           : PSID;
  cbSid         : Cardinal;
  RefDomainName : array[0..MAX_PATH-1] of char;
  cbDomainName  : Cardinal;
  peUse         : Cardinal;
begin
  lpSystemName:='';
  if IsUserSID then begin
    lpAccountName := GetLoginUserName;
  end else begin
    lpAccountName := GetLocalComputerName;
  end;


  Sid          := nil;
  cbSid        := 0;
  cbDomainName := SizeOf(RefDomainName);

  //SID情報取得に必要なバッファサイズを求める
  LookupAccountName(PChar(lpSystemName),
                    PChar(lpAccountName),
                    Sid,
                    cbSid,
                    nil,
                 　 cbDomainName,
                    peUse);

  //取得したバッファサイズを確保してSIDの値を取得
  Sid := GetMemory(cbSid);
  try
    LookupAccountName(PChar(lpSystemName),
                      PChar(lpAccountName),
                      Sid,
                      cbSid,
                      RefDomainName,
                      cbDomainName,
                      peUse);
    Result := Sid;
  finally
    FreeMemory(Sid);
  end;
end;

//=============================================================================
//  ログインユーザのSIDの取得
//=============================================================================
function GetCurrentUserSID: PSID;
begin
  Result := GetCurrentUserOrComputerSID(True);
end;

//=============================================================================
//  ログインユーザのSIDの値を文字列に変換
//=============================================================================
function GetCurrentUserSIDString: String;
var
  UserSID    : PSid;
  pStringSid : PChar;
begin
  UserSID := GetCurrentUserOrComputerSID(True);
  //SIDの値を文字列に変換
  ConvertSidToStringSid(UserSID, pStringSid);
  Result := String(pStringSid);
end;

//=============================================================================
//  ローカルコンピュータのSIDの取得
//=============================================================================
function GetLocalComputerSID: PSID;
begin
  Result := GetCurrentUserOrComputerSID(False);
end;

//=============================================================================
//  ローカルコンピュータのSIDの値を文字列に変換
//=============================================================================
function GetLocalComputerSIDString: String;
var
  ComputerSID : PSid;
  pStringSid  : PChar;
begin
  ComputerSID := GetCurrentUserOrComputerSID(False);
  //SIDの値を文字列に変換
  ConvertSidToStringSid(ComputerSID, pStringSid);
  Result := String(pStringSid);
end;

end.

uses ShellAPI;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  CmdStr  : String;
  ParaStr : String;
begin
  CmdStr  := 'control.exe';
  ParaStr := '/name Microsoft.DefaultPrograms /page pageFileAssoc';
  ShellExecute(Handle, nil, PChar(CmdStr), PChar(ParaStr), nil, SW_SHOW);
end;

uses
  StdActns;

{$R *.dfm}

//=============================================================================
//  TFileOpenWithを使用した[ファイルを開くプログラムの選択]ダイアログの表示
//  TFileOpenWithの使用にはusesにStdActnが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LFileOpen : TFileOpenWith;
begin
  LFileOpen := TFileOpenWith.Create(Self);
  try
    LFileOpen.Dialog.Filter := 'テキストファイル (*.txt)|*.txt';
    if LFileOpen.Execute then begin
      //ダイアログを閉じた時の処理
      //LFileOpen.Dialog.FileNameが選択ファイルのフルパス
      //選択しなかった時は空文字
    end;
  finally
    FreeAndNil(LFileOpen);
  end;
end;

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses ActiveX, ShlObj, ComObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text := 'Wordpad';
end;

//=============================================================================
//  アプリケーションに関連付けする拡張子を設定するダイアログを表示
//  IApplicationAssociationRegistrationUIインターフェイスを使用
//
//  設定可能なアプリケーションはレジストリの以下の場所に記録されいるものだけ
//  HKCU\Software\RegisteredApplications
//  HKLM\Software\RegisteredApplications
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  iAppAssocRegUI : IApplicationAssociationRegistrationUI;
  pszAppRegName  : String;
  iRet           : HRESULT;
begin
  //IApplicationAssociationRegistrationUIのインスタンスを生成
  iAppAssocRegUI := CreateComObject(CLSID_ApplicationAssociationRegistrationUI)
                    as IApplicationAssociationRegistrationUI;
  if iAppAssocRegUI = nil then exit;

  //アプリケーション名の指定
  //pszAppRegNameが無効な場合は表示しない
  pszAppRegName := Trim(Edit1.Text);
  iRet := iAppAssocRegUI.LaunchAdvancedAssociationUI(PChar(pszAppRegName));

  if iRet <> S_OK then begin
    MessageBox(Handle, '登録されていないアプリです', '情報', MB_ICONINFORMATION);
  end;
  iAppAssocRegUI := nil;
end;

end.

  if Failed(CoCreateInstance(CLSID_ApplicationAssociationRegistrationUI,
                             nil,
                             CLSCTX_INPROC_SERVER,
                             IApplicationAssociationRegistrationUI,
                             iAppAssocRegUI)) then exit;

  pszAppRegistryName := 'Wordpad';
  iAppAssocReg.SetAppAsDefaultAll(PChar(pszAppRegistryName));

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses ActiveX, ShlObj, ComObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  Edit1.Text := '.txt';
  Edit2.Text := 'Wordpad';
end;

//=============================================================================
//  登録済みの拡張子に指定アプリを関連付ける
//  IApplicationAssociationRegistrationインターフェイスを使用
//
//  設定可能なアプリケーションはレジストリの以下の場所に記録されいるものだけ
//  HKCU\Software\RegisteredApplications
//  HKLM\Software\RegisteredApplications
//
//  管理者権限で実行しなくても設定可能
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  iAppAssocReg       : IApplicationAssociationRegistration;
  pszQuery           : String;
  pszAppRegistryName : String;
  iRet               : HRESULT;
begin
  //IApplicationAssociationRegistrationのインスタンスを生成
  iAppAssocReg := CreateComObject(CLSID_ApplicationAssociationRegistration)
                  as IApplicationAssociationRegistration;
  if iAppAssocReg = nil then exit;


  pszQuery           := Trim(Edit1.Text);
  pszAppRegistryName := Trim(Edit2.Text);

  iRet := iAppAssocReg.SetAppAsDefault(PChar(pszAppRegistryName),
                                       PChar(pszQuery),
                                       AT_FILEEXTENSION);

  if iRet = S_OK then begin
    MessageBox(Handle, '関連付けに成功しました', '情報', MB_ICONINFORMATION);
  end else begin
    MessageBox(Handle, '関連付けに失敗しました', '情報', MB_ICONINFORMATION);
  end;
  iAppAssocReg := nil;
end;

end.

  if Failed(CoCreateInstance(CLSID_ApplicationAssociationRegistration,
                             nil,
                             CLSCTX_INPROC_SERVER,
                             IApplicationAssociationRegistration,
                             iAppAssocReg)) then exit;

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private 宣言 }
    OldFileExt        : string;
    OldExePath        : string;
    NewFileExt        : string;
    NewExePath        : string;
    OriginalAppProgID : string;
    MyAppProgID       : string;
    function CreateProgIDKey(ProgIDName, Description, ExeName: string): Boolean;
    function GetProgIDName(ExtName: string): string;
    function SetProgIDName(ExtName, ProgIDName: string): Boolean;
    function DeleteProgIDKey(ProgIDName: string): Boolean;
    function DeleteFileExts_UserChoice(AExt, AppExeName: string): Boolean;
  public
    { Public 宣言 }
  end;


var
  Form1: TForm1;

implementation

uses
  Registry,
  ShlObj,
  plPrivilegeUnit,
  plCommandRedirect,
  StrUtils;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  OldFileExt := '';
  OldExePath := '';
  //新しく作成する参照名の名前
  MyAppProgID := 'plApplicationEXE';

  //対象の拡張子
  Edit1.Text := '.pdf';
  //その拡張子に関連付けるプログラムのEXE名
  Edit2.Text := '"wordpad.exe" "%1"';
end;

//=============================================================================
//  フォームを閉じる時の処理
//  起動するプログラムを元に戻しておく
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  //参照名を元に戻す
  if GetProgIDName(OldFileExt) <> OriginalAppProgID then begin
    Button2Click(nil);
  end;
end;

//=============================================================================
//  指定拡張子のファイルをダブルクリックしたら新しいプログラム起動するようにする
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LflgRet : Boolean;
begin
  LflgRet := True;

  NewFileExt := Trim(Edit1.Text);
  NewExePath := Trim(Edit2.Text);

  //設定する拡張子が変更になった場合
  //参照名を元に戻して，新しい拡張子の参照名を取得しておく
  if (OldFileExt <> NewFileExt) then begin
    if (OldFileExt <>'') and (OriginalAppProgID <> '') then begin
      LflgRet := SetProgIDName(OldFileExt, OriginalAppProgID);
    end;
    if LflgRet then begin
      OldFileExt := NewFileExt;
      OriginalAppProgID := GetProgIDName(NewFileExt);
    end;
  end;

  if LflgRet then begin
    //既存の拡張子名のキーに新しく作成する参照名をセット
    LflgRet := SetProgIDName(NewFileExt, MyAppProgID);
    if LflgRet then begin
      //新しく作成した参照名のキーに起動するEXE名をセット
      if CreateProgIDKey(MyAppProgID, '自分専用', NewExePath) then begin
        OldExePath := NewExePath;
      end;
    end;
  end;


  if LflgRet then begin
    //既定のプログラムの設定を削除
    DeleteFileExts_UserChoice(NewFileExt, '');
    //システムに変更を通知
    SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, nil, nil);

    MessageBox(Handle, '関連付けアプリを変更しました．', '情報', MB_ICONINFORMATION);
  end else begin
    MessageBox(Handle, '関連付けの変更に失敗しました．', '情報', MB_ICONWARNING);
  end;
end;

//=============================================================================
//  指定拡張子のファイルをダブルクリックしたら元のプログラムが起動するようにする
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LflgRet : Boolean;
begin
  LflgRet := True;

  if GetProgIDName(OldFileExt) <> OriginalAppProgID then begin
    //参照名を元に戻す
    LflgRet := SetProgIDName(OldFileExt, OriginalAppProgID);
    //作成した参照名のキーを削除
    DeleteProgIDKey(MyAppProgID);
    //既定のプログラムの設定を削除
    DeleteFileExts_UserChoice(NewFileExt, NewExePath);
    //システムに変更を通知
    SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, nil, nil);
  end;


  if LflgRet then begin
    MessageBox(Handle, '関連付けを元に戻しました．', '情報', MB_ICONINFORMATION);
  end else begin
    MessageBox(Handle, '関連付けを戻すのに失敗しました．', '情報', MB_ICONWARNING);
  end;
end;

//-----------------------------------------------------------------------------
//  指定の独自の参照名のキーがなければを作成して\shell\open\commandに値をセット
//  作成済みであれば\shell\open\commandに値をセット
//-----------------------------------------------------------------------------
function TForm1.CreateProgIDKey(ProgIDName, Description, ExeName: String): Boolean;
var
  LRegistry : TRegistry;
begin
  Result := False;
  if (ProgIDName = '') or (ProgIDName = '.') or (ExeName = '') then exit;

  LRegistry := TRegistry.Create(KEY_READ or KEY_WRITE);
  try
    LRegistry.RootKey := HKEY_CLASSES_ROOT;

    if LRegistry.OpenKey('\' + ProgIDName, True) then begin
      //エクスプローラに表示する説明用文字列の登録
      if Description <> '' then begin
        LRegistry.WriteString('', Description);
      end;
      //Shell\Open\Commandキーを作成してEXEのパス名を登録
      LRegistry.OpenKey('\' + ProgIDName + '\shell\open\command', True);
      LRegistry.WriteString('', ExeName);
      Result := True;
    end;
  finally
    FreeAndNil(LRegistry);
  end;
end;

//-----------------------------------------------------------------------------
//  拡張子名のキーからその拡張子に関連付けされている参照名を取得
//-----------------------------------------------------------------------------
function TForm1.GetProgIDName(ExtName: String): String;
var
  LRegistry  : TRegistry;
begin
  Result := '';
  if (ExtName = '') or (ExtName = '.') then exit;

  LRegistry := TRegistry.Create(KEY_READ);
  try
    LRegistry.RootKey := HKEY_CLASSES_ROOT;
    if LRegistry.OpenKey('\' + ExtName, False) then begin
      Result := LRegistry.ReadString('');
    end;
  finally
    FreeAndNil(LRegistry);
  end;
end;

//-----------------------------------------------------------------------------
//  拡張子名のキーに参照名を書き込む
//-----------------------------------------------------------------------------
function TForm1.SetProgIDName(ExtName, ProgIDName: String): Boolean;
var
  LRegistry  : TRegistry;
begin
  Result := False;
  if (ExtName = '') or (ExtName = '.') or (ProgIDName = '') then exit;

  LRegistry  := TRegistry.Create(KEY_READ or KEY_WRITE);
  try
    LRegistry.RootKey := HKEY_CLASSES_ROOT;
    if LRegistry.OpenKey('\' + ExtName, False) then begin
      LRegistry.WriteString('', ProgIDName);
      Result := True;
    end;
  finally
    FreeAndNil(LRegistry);
  end;
end;

//-----------------------------------------------------------------------------
//  操作用に作成した参照名のキーをレジストリから削除
//-----------------------------------------------------------------------------
function TForm1.DeleteProgIDKey(ProgIDName: String): Boolean;
var
  LRegAppProgID : String;
  LCmdLine      : TplCommandRedirect;
  LCmdStr       : String;
begin
  Result := False;
  if (ProgIDName = '') then exit;

  LRegAppProgID := 'HKEY_CLASSES_ROOT\' + ProgIDName;

  //対象のキーの有無に関わらず削除のコードを実行
  LCmdLine := TplCommandRedirect.Create;
  try
    LCmdStr := 'Cmd.exe /k reg delete ' + LRegAppProgID + ' /f';
    LCmdLine.GrabStdOutText(LCmdStr);
    Result := True;
  finally
    FreeAndNil(LCmdLine);
  end;
end;

//-----------------------------------------------------------------------------
//  [既定のプログラム]を設定すると作成される[UserChoice]キーを削除する関数
//
//  このキーはレジストリの以下の場所の拡張子名のキーに作成される
//  HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts
//
//  このキーの削除には，レジストリのアクセスにREG_OPTION_BACKUP_RESTOREが必要
//  SE_SECURITY_NAMEの特権が必要
//-----------------------------------------------------------------------------
function TForm1.DeleteFileExts_UserChoice(AExt, AppExeName: String): Boolean;
var
  LRegistry    : TRegistry;
  LBaseKeyName : String;
  LKeyName     : String;
  LStrList     : TStringList;
  i            : Integer;
begin
  Result := False;
  if (AExt = '') or (AExt = '.') then exit;

  LBaseKeyName := '\Software\Microsoft\Windows\CurrentVersion\'
                + 'Explorer\FileExts\' + AExt;

  plPrivilegeUnit.SetPrivilege(SE_SECURITY_NAME, True);
  LRegistry := TRegistry.Create(REG_OPTION_BACKUP_RESTORE or KEY_READ or KEY_WRITE);
  try
    LRegistry.RootKey := HKEY_CURRENT_USER;

    LKeyName := LBaseKeyName + '\UserChoice';
    if LRegistry.KeyExists(LKeyName) then begin
      if LRegistry.OpenKey(LKeyName, False) then begin
        LRegistry.DeleteKey('');
        Result := True;
      end;
    end else begin
      Result := True;
    end;

    //[OpenWithList]から関連付けたアプリを削除してしまうことにする
    if AppExeName <> '' then begin
      LKeyName := LBaseKeyName + '\OpenWithList';
      if LRegistry.OpenKey(LKeyName, False) then begin
        LStrList := TStringList.Create;
        try
          LRegistry.GetValueNames(LStrList);
          for i := 0 to LStrList.Count - 1 do begin
            if ContainsText(AppExeName, LRegistry.ReadString(LStrList[i])) then begin
              LRegistry.DeleteValue(LStrList[i]);
              Break
            end;
          end;
        finally
          FreeAndNil(LStrList);
        end;
      end;
    end;
  finally
    plPrivilegeUnit.SetPrivilege(SE_SECURITY_NAME, False);
    FreeAndNil(LRegistry);
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Edit2KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  private
    { Private 宣言 }
    RegKeyInfoPath    : string;
    RegSavePathExt    : string;
    RegSavePathProgID : string;
    function BackUpProgIDKeyValues(ARootKey: Int64; AKeyName: string;
      ASaveFilePath: String): Boolean;
    function RestoreProgIDKeyValues(ARootKey: Int64; AKeyName: string;
      ASaveFilePath: String): Boolean;
    function GetAppProgIDName(ARootKey: Int64;AppFileExt: string): String;
    function GetHKEYKeyRoot(StrKeyName: string): Int64;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  Registry,
  ShlObj,
  plCommandRedirect;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LFilePath : string;
  LRegistry : TRegistry;
  LKeyList  : TStringList;
begin
  //レジストリのキー情報の保存先
  LFilePath         := ExtractFilePath(Application.ExeName);
  RegKeyInfoPath    := LFilePath + 'RegBackUpData\KeyInfoData.txt';
  RegSavePathExt    := LFilePath + 'RegBackUpData\RegSaveExt.hiv';
  RegSavePathProgID := LFilePath + 'RegBackUpData\RegSaveProgID.hiv';

  LRegistry := TRegistry.Create;
  try
    LRegistry.RootKey := HKEY_CLASSES_ROOT;

    //保存したデータがあれば読み出す
    if FileExists(RegKeyInfoPath) then begin
      LKeyList := TStringList.Create;
      try
        LKeyList.LoadFromFile(RegKeyInfoPath);
        LRegistry.RootKey := StrToInt64(LKeyList[0]);

        Edit1.Text := LRegistry.RootKeyName;
        Edit2.Text := LKeyList[1];
        Edit3.Text := LKeyList[2];
      finally
        FreeAndNil(LRegistry);
        FreeAndNil(LKeyList);
      end;
    end else begin
      Edit1.Text := LRegistry.RootKeyName;
      Edit2.Text := '.plXRAY';
      Edit3.Text := GetAppProgIDName(LRegistry.RootKey, Edit2.Text);
    end;
  finally
    FreeAndNil(LRegistry);
  end;
end;

//=============================================================================
//  指定のレジストリのキー情報を保存
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LRootKeyName : Int64;
  LKeyList     : TStringList;
  LStrText     : string;
begin
  LRootKeyName := GetHKEYKeyRoot(Trim(Edit1.Text));

  LKeyList := TStringList.Create;
  try
    LKeyList.Add(IntToStr(GetHKEYKeyRoot(Edit1.Text)));

    if (Edit2.Text <> '') and (Edit2.Text <> '.') then begin
      if BackUpProgIDKeyValues(LRootKeyName, Edit2.Text, RegSavePathExt) then begin
        LKeyList.Add(Edit2.Text);
        LStrText := '拡張子のキー情報を保存しました';
        MessageBox(Handle, PChar(LStrText), '情報', MB_ICONINFORMATION);
      end else begin
        LKeyList.Add('');
        LStrText := '拡張子のキー情報の保存に失敗しました';
        MessageBox(Handle, PChar(LStrText), '情報', MB_ICONERROR);
      end;
    end else begin
      LKeyList.Add('');
    end;

    if (Edit3.Text <> '') and (Edit3.Text <> '.') then begin
      if BackUpProgIDKeyValues(LRootKeyName, Edit3.Text, RegSavePathProgID) then begin
        LKeyList.Add(Edit3.Text);
        LStrText := '参照名のキー情報を保存しました';
        MessageBox(Handle, PChar(LStrText), '情報', MB_ICONINFORMATION);
      end else begin
        LKeyList.Add('');
        LStrText := '参照名のキー情報の保存に失敗しました';
        MessageBox(Handle, PChar(LStrText), '情報', MB_ICONERROR);
      end;
    end else begin
      LKeyList.Add('');
    end;

    ForceDirectories(ExtractFileDir(RegKeyInfoPath));
    LKeyList.SaveToFile(RegKeyInfoPath);
  finally
    FreeAndNil(LKeyList);
  end;
end;

//=============================================================================
//  退避したレジストリの該当キー情報を復元する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LRootKeyName : Int64;
  LStrText     : string;
begin
  LRootKeyName := GetHKEYKeyRoot(Trim(Edit1.Text));

  if (Edit2.Text <> '') and (Edit2.Text <> '.') then begin
    if RestoreProgIDKeyValues(LRootKeyName, Edit2.Text, RegSavePathExt) then begin
      LStrText := '拡張子のキー情報を復元しました';
      MessageBox(Handle, PChar(LStrText), '情報', MB_ICONINFORMATION);
    end else begin
      LStrText := '拡張子のキー情報の復元に失敗しました';
      MessageBox(Handle, PChar(LStrText), '情報', MB_ICONERROR);
    end;
  end;

  if (Edit3.Text <> '') and (Edit3.Text <> '.') then begin
    if RestoreProgIDKeyValues(LRootKeyName, Edit3.Text, RegSavePathProgID) then begin
      LStrText := '参照名のキー情報を復元しました';
      MessageBox(Handle, PChar(LStrText), '情報', MB_ICONINFORMATION);
    end else begin
      LStrText := '参照名のキー情報の復元に失敗しました';
      MessageBox(Handle, PChar(LStrText), '情報', MB_ICONERROR);
    end;
  end;
end;

//=============================================================================
//  Edit2のOnKeyDownイベント処理
//=============================================================================
procedure TForm1.Edit2KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_RETURN then begin
    Edit3.Text := GetAppProgIDName(GetHKEYKeyRoot(Edit1.Text), Edit2.Text);
  end;
end;

//-----------------------------------------------------------------------------
//  ルートキーの文字列を，該当するルートキーの値に変換する関数
//-----------------------------------------------------------------------------
function TForm1.GetHKEYKeyRoot(StrKeyName: String): Int64;
begin
  Result := 0;

  if StrKeyName = 'HKEY_CLASSES_ROOT'     then Result := HKEY_CLASSES_ROOT;
  if StrKeyName = 'HKEY_CURRENT_USER'     then Result := HKEY_CURRENT_USER;
  if StrKeyName = 'HKEY_LOCAL_MACHINE'    then Result := HKEY_LOCAL_MACHINE;
  if StrKeyName = 'HKEY_USERS'            then Result := HKEY_USERS;
  if StrKeyName = 'HKEY_PERFORMANCE_DATA' then Result := HKEY_PERFORMANCE_DATA;
  if StrKeyName = 'HKEY_CURRENT_CONFIG'   then Result := HKEY_CURRENT_CONFIG;
  if StrKeyName = 'HKEY_DYN_DATA'         then Result := HKEY_DYN_DATA;
end;

//-----------------------------------------------------------------------------
//  ファイルの拡張子からアプリケーションの参照名の値を取得する
//-----------------------------------------------------------------------------
function TForm1.GetAppProgIDName(ARootKey: Int64; AppFileExt: String): String;
var
  LRegistry : TRegistry;
begin
  Result := '';
  LRegistry := TRegistry.Create(KEY_READ);
  try
    LRegistry.RootKey := ARootKey;

    //該当する拡張子が登録されていなければ取得できない
    if LRegistry.OpenKeyReadOnly('\' + AppFileExt) then begin
      Result := LRegistry.ReadString('');
    end;
  finally
    FreeAndNil(LRegistry);
  end;
end;

//-----------------------------------------------------------------------------
//  レジストリの指定キーの内容をサブキーも含めて保存する
//
//  ARootKey      : 保存するルートキーの値
//  AkeyName      : 保存するキーの名前
//  ASaveFilePath : 保存先のフルパス
//-----------------------------------------------------------------------------
function TForm1.BackUpProgIDKeyValues(ARootKey: Int64; AKeyName: String;
  ASaveFilePath: String): Boolean;
var
  LRegistry    : TRegistry;
  LRootKeyName : string;
  LRegPath     : string;
  LCmdLine     : TplCommandRedirect;
  LCmdStr      : string;
begin
  Result := False;

  LRegistry := TRegistry.Create(KEY_READ or KEY_WRITE);
  LCmdLine  := TplCommandRedirect.Create;
  try
    LRegistry.RootKey := ARootKey;
    LRootKeyName      := LRegistry.RootKeyName;

    if (AKeyName <> '') and (AKeyName <> '.') then begin
      //該当するキーの存在を確認．なくても作成はしない
      if LRegistry.OpenKey('\' + AKeyName, False) then begin
        LRegistry.CloseKey;

        //上書き保存
  　    //ディレクトリを作成
        ForceDirectories(ExtractFileDir(ASaveFilePath));

        LRegPath       := LRootKeyName + '\' + AKeyName;
        ASaveFilePath := AnsiQuotedStr(ASaveFilePath, '"');
        LCmdStr := 'Cmd.exe /k reg save ' + LRegPath + ' ' + ASaveFilePath + ' /y';
        LCmdLine.GrabStdOutText(LCmdStr);

        Sleep(10);
        Result := True;
      end;
    end;
  finally
    FreeAndNil(LRegistry);
    FreeAndNil(LCmdLine);
  end;
end;

//-----------------------------------------------------------------------------
//  退避したレジストリの該当キーを復元する
//
//  ARootKey      : 復元するルートキーの値
//  AkeyName      : 復元するキーの名前
//  ASaveFilePath : キー情報を保存したファイルのフルパス
//-----------------------------------------------------------------------------
function TForm1.RestoreProgIDKeyValues(ARootKey: Int64; AKeyName: String;
  ASaveFilePath: String): Boolean;
var
  LRegistry    : TRegistry;
  LRootKeyName : string;
  LRegPath     : string;
  LCmdLine     : TplCommandRedirect;
  LCmdStr      : string;
begin
  Result := False;

  LRegistry := TRegistry.Create(KEY_READ or KEY_WRITE);
  LCmdLine  := TplCommandRedirect.Create;
  try
    LRegistry.RootKey := ARootKey;
    LRootKeyName      := LRegistry.RootKeyName;

    if (AKeyName <> '') and (AKeyName <> '.') then begin
      //バックアップファイルがなければ復元できない
      if FileExists(ASaveFilePath) then begin
        //元のキーが存在しないと復元できないので,なければ作成する
        if LRegistry.OpenKey('\' + AKeyName, True) then begin
          LRegistry.CloseKey;

          //指定キー以下のサブキーも含めて復元する
          LRegPath      := LRootKeyName + '\' + AKeyName;
          ASaveFilePath := AnsiQuotedStr(ASaveFilePath, '"');
          LCmdStr := 'Cmd.exe /k reg restore ' + LRegPath + ' ' + ASaveFilePath;
          LCmdLine.GrabStdOutText(LCmdStr);

          Sleep(10);
          Result := True;
        end;
      end;
    end;

    //システムに変更を通知
    SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, nil, nil);
  finally
    FreeAndNil(LRegistry);
    FreeAndNil(LCmdLine);
  end;
end;

end.