unit Unit1;

{$mode objfpc}{$H+}

interface

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

  { TForm1 }
type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private

  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

uses
  Unit2;

{ TForm1 }

//=============================================================================
//  Form2 をモーダル表示
//  uses に Unit2 が必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  Form2.ShowModal;
end;

//=============================================================================
//  FindWindow 関数でフォームのウィンドウを検索してそのウィンドウを閉じる
//  閉じるフォームの Handle プロパティの値とウィンドウハンドルの値を確認表示
//
//  uses に Windows が必要
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LhWnd : HWND;
begin
  LhWnd:= FindWindow('TForm1', nil);
  if LhWnd <> 0 then begin
    ShowMessage(IntToStr(LhWnd) + sLineBreak + IntToStr(Form1.Handle));
    PostMessage(LhWnd, WM_CLOSE, 0,  0);
  end;
end;

end.

class function TWin32WSCustomForm.CreateHandle(const AWinControl: TWinControl;
  const AParams: TCreateParams): HWND;
var
  Params: TCreateWindowExParams;
  lForm: TCustomForm absolute AWinControl;
  Bounds: TRect;
  SystemMenu: HMenu;
  LWndClassW: TWNDCLASSW;  // 追加
begin 

    CalcFormWindowFlags(lForm, Flags, FlagsEx);
    pClassName := @ClsName[0];

    // 以下のコードを追加
    if AParams.WinClassName[0] <> #0 then begin
      pClassName := @AParams.WinClassName[0];
    end else begin
      pClassName := PChar(String(AWinControl.ClassName));
    end;
    if GetClassInfoW(HINSTANCE, PWideChar(WideString(ClsName)), @LWndClassW) then begin
      LWndClassW.lpszClassName := PWideChar(WideString(pClassName));
      if Windows.RegisterClassW(@LWndClassW) = 0 then begin
        // error
      end;
    end;
    // 追加するコードはここまで     

    WindowTitle := StrCaption;

var
  FTargetWnd : HWND = 0;

  //-----------------------------------------------------------------------------
  //  ウィンドウのクラス名を取得する関数
  //  FillChar を実行しないと結果にゴミが入ることがある
  //  小規模のプログラムの場合はゴミが入る可能性は低い
  //-----------------------------------------------------------------------------
  function GetWindowClassNameStr(hWindow: HWND): String;
  var
    LBuffer : array[0..MAX_PATH-1] of Char;
    LLen    : Integer;
    LLL : PWideChar;
  begin
    FillChar(LBuffer, SizeOf(LBuffer), #0);
    LLen := GetClassName(hWindow, LBuffer, Length(LBuffer));
    if LLen > 0 then Result := LBuffer else Result := '';
  end;

  //-----------------------------------------------------------------------------
  //  EnumWindows のコールバック関数
  //  EnumWindows を実行すると，そのバック (裏) でコール (呼び出し) されて実行する関数
  //  コールバック関数の名前は任意
  //  現在起動中のウィンドウの列挙が終了するまで EnumWindows 関数は終了しない
  //  Result := false にすると強制的に列挙終了となる
  //-----------------------------------------------------------------------------
function EnumWindowHogeProc(hWindow: HWND; lData: LPARAM):WINBOOL; stdcall;
begin
  Result:= True;
  if not IsWindowVisible(hWindow) then Exit;

  if GetWindowClassNameStr(hWindow) = PString(lData)^ then begin
    if hWindow <> Application.MainForm.Handle then begin;
      FTargetWnd:= hWindow;
      if PostMessage(FTargetWnd, WM_CLOSE, 0, 0) then begin
        // 目的のウィンドウを閉じることができる
        // 管理者権限で起動してたりすると終了不可の場合もある
      end;
      // 以下の 2 行を削除すると自分以外の TForm1 を全て閉じる
      Result := False;
      Exit;
    end;
  end;
end;

//=============================================================================
//  クラス名を指定してウィンドウの列挙関数を実行
//  自分と同じクラス名のウィンドウを強制的に閉じる
//  このプログラムを複数起動してテストする
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LClassName : string;
begin
  LClassName:= Self.Classname;
  FTargetWnd:= 0;
  EnumWindows(@EnumWindowHogeProc, LPARAM(@LClassName));
  // ウィンドウの列挙が終了しないとここは実行されない
end;

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, LCLType;

type

  { TForm1 }

  TForm1 = class(TForm)
  private

  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

//=============================================================================
//  CreateParams メソッド処理
//  uses に LCLType が必要
//=============================================================================
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);

  // このフォームのウィンドウのクラス名を変更
  Params.WinClassName := 'TMyMainWindow';
end;

end.