unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    function GetFolderPath(nFolder: Integer): string;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ShellApi,
  ShlObj,
  ActiveX;

{$R *.dfm}

//=============================================================================
//  手順
//  (1)このEXEのフォルダ内にあらかじめplUnInstall.dprをコンパイルして
//     plUnInstall.exeを作成しておく
//     plUnInstall.exeが実際の削除用プログラム
//  (2)plUnInatall.exeを別のフォルダにコピー
//  (3)移動したplUnIntall.exeに引数を指定して実行
//  (4)本アプリを終了
//
//  ShellExecuteの使用にはusesにShellApiが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LMsgText    : String;
  LSourcePath : String;
  LDestPath   : String;
  LAppPath    : String;
  LCmdParam   : String;
begin
  if DebugHook <> 0 then begin
    LMsgText := 'デバッグ中です' + sLineBreak + 'アンインストールできません';
    MessageBox(Handle, PChar(LMsgText), '情報', MB_ICONINFORMATION);
    exit;
  end;

  LMsgText := 'アンインストールします' + sLineBreak + 'よろしいですか';
  if MessageBox(Handle,
                PChar(LMsgText),
                '確認',
                MB_YESNO or  MB_ICONINFORMATION) = IDNO then begin
    exit;
  end;

  LSourcePath := ExtractFilePath(Application.ExeName) + 'plUnInstall.exe';
  LDestPath   := GetFolderPath(CSIDL_PERSONAL);
  LDestPath   := IncludeTrailingPathDelimiter(LDestPath) + 'plUnInstall.exe';
  LAppPath    := Application.ExeName;

  LAppPath := AnsiQuotedStr(LAppPath, '"');

  //plUnInstall.exeをLDestPathにコピーして実行
  //このLDestPathはユーザがアクセス(読書き)可能なフォルダであること
  if FileExists(LSourcePath) then begin
    LMsgText := 'テストアプリ削除';
    CopyFile(PChar(LSourcePath), PChar(LDestPath), False);
    Application.ProcessMessages;

    //plUnInstall.exeを起動
    LCmdParam := LAppPath + ' ' + IntToStr(Application.Handle) + ' ' + LMsgText;
    ShellExecute(Handle, '', PChar(LDestPath), PChar(LCmdParam), nil, SW_SHOW);
    //このアプリは終了
    //後は起動したplUnInstall.exeがいろいろ実行
    Close;
  end else begin
    LMsgText := 'アンインストールできません';
    MessageBox(Handle, PChar(LMsgText), '情報', MB_ICONINFORMATION);
  end;
end;

//-----------------------------------------------------------------------------
//  特殊フォルダのフルパスをCSIDL値から取得する関数
//
//  nFolder 特殊フォルダのCSIDL値の例
//    CSIDL_APPDATA  アプリケーションデータ
//    CSIDL_PERSONAL マイドキュメント
//    その他いろいろありShlObj.pas参照
//  usesにShlObj(SH...)とActiveX(IMalloc)が必要
//-----------------------------------------------------------------------------
function TForm1.GetFolderPath(nFolder: Integer): string;
var
  Lpidl    : PItemIDList;
  Lbufffer : array [0..MAX_PATH] of Char;
  LMalloc  : IMalloc;
begin
  CoGetMalloc(1, LMalloc);
  SHGetSpecialFolderLocation(0, nFolder, Lpidl);
  try
    SHGetPathFromIDList(Lpidl, Lbufffer);
    Result := Lbufffer;
  finally
    LMalloc.Free(Lpidl);
  end;
end;

end.

unit plUnInstallUnit;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    FApplicationFullPath : String;
    FDelFolder  : String;
    FDelAppHandle: THandle;
    FExeFullPath : String;
    FBatFullPath : String;
    function DeleteFolders(AFolderPath: string): Integer;
    procedure BeforeApplicationExit;
    procedure DeleteShorCut(AFindPath, ASearcFolder: String);
    function FindFileShortCut(AFindPath, ASearchFolder: String): String;
    function GetFolderPath(AnFolder: Integer): string;
    function GetLinkPathName(ALinkFilePath: String): String;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ShellAPI,
  ShlObj,
  ActiveX,
  ComObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//
//  実行手順
//  (1)このEXEを使用するアプリで、このEXEを別のフォルダにコピーする
//  (2)このEXEを使用するアプリ側で、コピー先のこのEXEを実行する
//     この時コマンドラインに以下の引数を指定する
//
//  ParamStr(1) アンインストール対象のアプリのフルパス
//              削除するフォルダ名はこの値から取得
//  ParamStr(2) アンインストール対象のアプリのハンドルを文字列に変換した値
//  ParamStr(3) このフォームのCaptionで本プログラムのタイトル
//
//  プロジェクトのソースコードに以下を追加して,このフォームを非表示で実行
//  Application.ShowMainForm:=False;
//  このプログラムは単独で実行した場合,何もしないで終了する
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  if ParamCount >= 2 then begin
    FDelFolder           := '';
    FExeFullPath         := Application.ExeName;
    FApplicationFullPath := ParamStr(1);
    FDelFolder           := ExtractFileDir(FApplicationFullPath);
    FDelAppHandle        := StrToIntDef(ParamStr(2), 0);

    if ParamStr(3) = '' then begin
      Application.Title := 'アンインストール';
      Self.Caption      := Application.Title;
    end else begin
      Application.Title := ParamStr(3);
      Self.Caption      := Application.Title;
    end;
    //削除対象のフォルダの指定がなければこのEXEも削除不可なので失敗
    if FDelFolder <> '' then begin
      BeforeApplicationExit;
    end else begin
      MessageBox(Handle,
                 'アンインストールまたはキャンセルできません',
                 '情報',
                 MB_ICONINFORMATION);
    end;
  end;

  //このEXEを強制終了
  Application.Terminate;
end;

//-----------------------------------------------------------------------------
//  削除の実行手順
//
//  (1)このEXEを呼出したEXEが終了するまで待つ
//  (2)削除対象のフォルダを削除
//  (3)このEXEを削除するためのバッチファイルを作成
//     このバッチファイルには自分自身を削除するコードがある
//-----------------------------------------------------------------------------
procedure TForm1.BeforeApplicationExit;
var
  LBatCmdList : TStringList;
begin
  //[デスクトップ][プログラム][スタートメニュー]にショートカットがあれば削除
  DeleteShorCut(FApplicationFullPath, GetFolderPath(CSIDL_DESKTOPDIRECTORY));
  DeleteShorCut(FApplicationFullPath, GetFolderPath(CSIDL_STARTMENU));
  DeleteShorCut(FApplicationFullPath, GetFolderPath(CSIDL_PROGRAMS));

  //削除場所によっては表示の更新に以下が必要
  //SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0);

  //このプログラムを呼出したアプリが終了するまでループ
  while True do begin
    Application.ProcessMessages;
    if GetClassLong(FDelAppHandle, GCL_HMODULE) = 0 then break;
  end;

  //フォルダ(FDelFolder)を削除
  //フォルダが存在しないという値である0を検出するまでループ
  try
    while True do begin
      if DirectoryExists(FDelFolder) = False then break;
      DeleteFolders(FDelFolder);
      Application.ProcessMessages;
    end;
  except
  end;

  LBatCmdList:=TStringList.Create;
  //BATファイルは"(ダブルクォーテーション)で囲まなくてOK
  FBatFullPath := ChangeFileExt(FExeFullPath, '.BAT');
  FExeFullPath := AnsiQuotedStr(FExeFullPath, '"');

  //このEXEファイルを削除するバッチファイル
  //削除が確認できるまでループする
  //削除後はバッチファイル自身も削除する(DEL %0)
  try
    LBatCmdList.Add(':Lbl0');
    LBatCmdList.Add('DEL ' + FExeFullPath);
    LBatCmdList.Add('IF EXIST ' + FExeFullPath + ' GOTO Lbl0');
    LBatCmdList.Add('DEL %0');
    LBatCmdList.Add('EXIT');
    LBatCmdList.SaveToFile(FBatFullPath);
  finally
    LBatCmdList.Free;
  end;

  Hide;
  MessageBox(Handle, 'アンインストールが終了しました', '情報', MB_ICONINFORMATION);
  try
    //作成したバッチファイルを実行
    ShellExecute(Handle, '', PChar(FBatFullPath), nil, nil, SW_HIDE);
  except
  end;
end;

//-----------------------------------------------------------------------------
//  引数のAFolderPathというフォルダ(サブフォルダも含めて)を削除する関数
//  SHFileOperation本来の進行ダイアログは非表示
//  fFlagsメンバの値にFOF_ALLOWUNDOを追加すればゴミ箱への移動
//
//  Delphi 2009以降の場合は，System.IOUtils.TDirectory.Deleteの方がいいだろう
//-----------------------------------------------------------------------------
function TForm1.DeleteFolders(AFolderPath: string): Integer;
var
  LfoStruct : TSHFileOpStruct;
begin
  LfoStruct.Wnd   := Application.Handle;
  LfoStruct.wFunc := FO_DELETE;
  LfoStruct.pFrom := PChar(AFolderPath+#0);
  LfoStruct.pTo   := #0;
  LfoStruct.fFlags:= FOF_SILENT or FOF_NOCONFIRMATION;
  LfoStruct.fAnyOperationsAborted := False;
  LfoStruct.hNameMappings := nil;
  LfoStruct.lpszProgressTitle := nil;

  Result := SHFileOperation(LfoStruct);
end;

//-----------------------------------------------------------------------------
//  指定場所のショートカットを削除
//
//  AFindPath    ショートカットの元ファイル(実行形式など)
//  ASearcFolder ショートカットの有無を検索するフォルダ
//-----------------------------------------------------------------------------
procedure TForm1.DeleteShorCut(AFindPath, ASearcFolder: String);
var
  ALinkPath : String;
begin
  ALinkPath := FindFileShortCut(AFindPath, ASearcFolder);
  if ALinkPath <> '' then begin
    DeleteFile(ALinkPath);
  end;
end;

//-----------------------------------------------------------------------------
//  指定したファイルが指定フォルダ内にあるか調査
//
//  SearchLinkFolderで指定するフォルダの中に，FindPathのファイルのショートカッ
//  トリンクが作成されているかを検出する．
//  ショートカットの名前が変更されている場合も検索可能
//  ショートカットがない場合は空文字を返す
//  既にに作成済みならそのフルパス名(拡張子は.lnk)を返す
//
//  名前の比較は念のため，全て小文字に変換してから比較する．
//-----------------------------------------------------------------------------
function TForm1.FindFileShortCut(AFindPath, ASearchFolder: String): String;
var
  LSearchRec    : TSearchRec;
  LGetFileName  : String;
  LFindPath     : String;
  LPath         : String;
  LAttr         : Integer;
  LSearchFolder : String;
begin
  Result := '';
  LAttr  := FaArchive;

  //大文字と小文字を区別しないで検索するために小文字に統一
  LFindPath := AnsiLowerCase(ExtractFileName(AFindPath));
  //フォルダ名の最後尾に\がなければ追加
  LSearchFolder := IncludeTrailingBackslash(ASearchFolder);

  try
    FindFirst(LSearchFolder + '*.*', LAttr, LSearchRec);
    //ASearcFolder内のファイルを全て調べる
    repeat
      LGetFileName := AnsiLowerCase(LSearchRec.Name);
      if (LGetFileName <> '.') and (LGetFileName <> '..') then begin
        LPath := AnsiLowerCase(GetLinkPathName(LSearchFolder + LGetFileName));
        if ExtractFileName(LPath) = LFindPath then begin
          Result := LSearchFolder + LGetFileName;
          break;
        end;
      end;
    until FindNext(LSearchRec) <> 0;
  finally
    FindClose(LSearchRec);
  end;
end;

//-----------------------------------------------------------------------------
//  CSIDL値から特殊フォルダのフルパスを取得する関数
//
//  AnFolder 特殊フォルダのCSIDL値の例
//    CSIDL_DESKTOPDIRECTORY ディスクトップ
//    CSIDL_PROGRAMS         スタートメニューのプログラム
//    CSIDL_STARTMENU        スタートメニュー
//    CSIDL_STARTUP          スタートアップ
//    CSIDL_SENDTO           コンテキストの｢送る｣
//    その他いろいろありShlObj.pas参照
//  usesにShlObj(SH...)とActiveX(IMalloc)が必要
//-----------------------------------------------------------------------------
function TForm1.GetFolderPath(AnFolder: Integer): string;
var
  Lpidl   : PItemIDList;
  LMalloc  : IMalloc;
  Lbuffer  : array [0..MAX_PATH-1] of Char;
begin
  CoGetMalloc(1, LMalloc);
  SHGetSpecialFolderLocation(0, AnFolder, Lpidl);
  try
    SHGetPathFromIDList(Lpidl, Lbuffer);
    Result := Lbuffer;
  finally
    LMalloc.Free(Lpidl);
  end;
end;

//-----------------------------------------------------------------------------
//  引数のALinkFilePath(フルパス)が，あるファイルのショートカットリンクの時に
//  そのリンク元，つまり実体を返す関数．成功しない時は空文字を返す
//
//  LinkPath ショートカットファイル名(拡張子はlnk)
//  TShellLinkにはusesにShlObjが必要
//  TPersisFileにはusesにActiveXが必要
//  CreateComObjectにはusesにComObjが必要
//-----------------------------------------------------------------------------
function TForm1.GetLinkPathName(ALinkFilePath: String): String;
var
  LShellLink   : IShellLink;
  LPersistFile : IPersistFile;
  LFileLink    : String;
  LiFlag       : Cardinal;
  LFindData    : TWin32FindData;
  LFilePath    : array[0..MAX_PATH-1] of char;
  Lwsz         : array[0..MAX_PATH-1] of WideChar;
begin
  Result := '';

  LFileLink    := ALinkFilePath;
  LShellLink   := CreateComObject(CLSID_SHELLLINK) as IShellLink;
  LPersistFile := LShellLink as IPersistFile;

  LiFlag := SLGP_RAWPATH or SLGP_UNCPRIORITY;

  //---------------------------------------------------------------------------
  //  Delphi 2009以上用のコード
  //---------------------------------------------------------------------------
  {$IFDEF Unicode}
  if LPersistFile.Load(PChar(LFileLink), STGM_READ) = S_OK then begin
    try
      //初期化
      FillChar(LFilePath, SizeOf(LFilePath), #0);
      //ショートカットファイルの参照先を取得
      LShellLink.GetPath(@LFilePath, MAX_PATH, LFindData, LiFlag);
      //関数の戻り値にセット
      Result := LFilePath;
    except
    end;
  end;

  {$ELSE}
  //---------------------------------------------------------------------------
  //  Delphi 2007以前用のコード
  //---------------------------------------------------------------------------
  MultiByteToWideChar(CP_ACP, 0, PChar(LFileLink), -1, Lwsz, MAX_PATH);
  if LPersistFile.Load(Lwsz, STGM_READ) = S_OK then begin
    try
      //初期化
      FillChar(LFilePath, SizeOf(LFilePath), #0);
      //ショートカットファイルの参照先を取得
      LShellLink.GetPath(@LFilePath, MAX_PATH, LFindData, LiFlag);
      //関数の戻り値にセット
      Result := LFilePath;
    except
    end;
  end;
  {$ENDIF}
end;

end.