Add close buttons to selected and closeable tabs, with dark mode support.

Components/NewTabSet.pas

@@ -12,36 +12,49 @@ unit NewTabSet;
 interface
 
 uses
-  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Math, ModernColors;
+  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Math, Generics.Collections,
+  ModernColors, UxTheme;
 
 type
   TTabPosition = (tpTop, tpBottom);
 
+  TBoolList = TList<Boolean>;
+
   TNewTabSet = class(TCustomControl)
   private
+    FCloseButtons: TBoolList;
     FHints: TStrings;
+    FMenuThemeData: HTHEME;
+    FOnCloseButtonClick: TNotifyEvent;
     FTabs: TStrings;
     FTabIndex: Integer;
     FTabPosition: TTabPosition;
     FTabsOffset: Integer;
     FTheme: TTheme;
+    FThemeDark: Boolean;
     function GetTabRect(Index: Integer): TRect;
+    function GetCloseButtonRect(const TabRect: TRect): TRect;
     procedure InvalidateTab(Index: Integer);
     procedure TabsListChanged(Sender: TObject);
+    procedure SetCloseButtons(Value: TBoolList);
     procedure SetTabs(Value: TStrings);
     procedure SetTabIndex(Value: Integer);
     procedure SetTabPosition(Value: TTabPosition);
     procedure SetTheme(Value: TTheme);
     procedure SetHints(const Value: TStrings);
+    procedure UpdateThemeData(const Open: Boolean);
     procedure EnsureCurrentTabIsFullyVisible;
   protected
     procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
+    procedure WMThemeChanged(var Message: TMessage); message WM_THEMECHANGED;
     procedure CreateParams(var Params: TCreateParams); override;
+    procedure CreateWnd; override;
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
     procedure Paint; override;
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
+    property CloseButtons: TBoolList read FCloseButtons write SetCloseButtons;
     property Theme: TTheme read FTheme write SetTheme;
   published
     property Align;
@@ -53,12 +66,16 @@ type
     property TabPosition: TTabPosition read FTabPosition write SetTabPosition default tpBottom;
     property PopupMenu;
     property OnClick;
+    property OnCloseButtonClick: TNotifyEvent read FOnCloseButtonClick write FOnCloseButtonClick;
   end;
 
 procedure Register;
 
 implementation
 
+uses
+  WinApi.UxTheme;
+
 procedure Register;
 begin
   RegisterComponents('JR', [TNewTabSet]);
@@ -138,10 +155,12 @@ const
   TabPaddingX = 5;
   TabPaddingY = 3;
   TabSpacing = 1;
+  CloseButtonSizeX = 12;
 
 constructor TNewTabSet.Create(AOwner: TComponent);
 begin
   inherited;
+  FCloseButtons := TBoolList.Create;
   FTabs := TStringList.Create;
   TStringList(FTabs).OnChange := TabsListChanged;
   FTabPosition := tpBottom;
@@ -158,8 +177,15 @@ begin
     style := style and not (CS_HREDRAW or CS_VREDRAW);
 end;
 
+procedure TNewTabSet.CreateWnd;
+begin
+  inherited;
+  UpdateThemeData(True);
+end;
+
 destructor TNewTabSet.Destroy;
 begin
+  UpdateThemeData(False);
   FTabs.Free;
   inherited;
 end;
@@ -184,6 +210,13 @@ begin
   end;
 end;
 
+procedure TNewTabSet.WMThemeChanged(var Message: TMessage);
+begin
+  { Don't Run to Cursor into this function, it will interrupt up the theme change }
+  UpdateThemeData(True);
+  inherited;
+end;
+
 function TNewTabSet.GetTabRect(Index: Integer): TRect;
 var
   CR: TRect;
@@ -198,6 +231,8 @@ begin
   for I := 0 to FTabs.Count-1 do begin
     Size := Canvas.TextExtent(FTabs[I]);
     SizeX := Size.cx + (TabPaddingX * 2) + TabSpacing;
+    if (I < FCloseButtons.Count) and FCloseButtons[I] then
+      Inc(SizeX, CloseButtonSizeX);
     SizeY := Size.cy + (TabPaddingY * 2);
     if FTabPosition = tpTop then
       Result.Top := CR.Bottom - SizeY;
@@ -208,6 +243,12 @@ begin
   SetRectEmpty(Result);
 end;
 
+function TNewTabSet.GetCloseButtonRect(const TabRect: TRect): TRect;
+begin
+  Result := TRect.Create(TabRect.Right - CloseButtonSizeX - TabPaddingX div 2,
+    TabRect.Top, TabRect.Right - TabPaddingX div 2, TabRect.Bottom);
+end;
+
 procedure TNewTabSet.InvalidateTab(Index: Integer);
 var
   R: TRect;
@@ -236,6 +277,14 @@ begin
     for I := 0 to FTabs.Count-1 do begin
       R := GetTabRect(I);
       if (X >= R.Left) and (X < R.Right) then begin
+        if (I = TabIndex) and (I < FCloseButtons.Count) and FCloseButtons[I] then begin
+          var R2 := GetCloseButtonRect(R);
+          if PtInRect(R2, TPoint.Create(X, Y)) then begin
+            if Assigned(OnCloseButtonClick) then
+              OnCloseButtonClick(Self);
+            Break;
+          end;
+        end;
         TabIndex := I;
         Break;
       end;
@@ -267,6 +316,22 @@ var
         else
           Canvas.Font.Color := clBtnText;
         Canvas.TextOut(R.Left + TabPaddingX, R.Top + TabPaddingY, FTabs[I]);
+
+       if (I < FCloseButtons.Count) and FCloseButtons[I] then begin
+          var R2 := GetCloseButtonRect(R);
+          if FMenuThemeData <> 0 then begin
+            Inc(R2.Left, 1);
+            Inc(R2.Top, 1);
+            DrawThemeBackground(FMenuThemeData, Canvas.Handle,  MENU_SYSTEMCLOSE, MSYSC_NORMAL, R2, nil);
+          end else begin
+            InflateRect(R2, -3, -6);
+            Canvas.Pen.Color := Canvas.Font.Color;
+            Canvas.MoveTo(R2.Left, R2.Top);
+            Canvas.LineTo(R2.Right, R2.Bottom);
+            Canvas.MoveTo(R2.Left, R2.Bottom-1);
+            Canvas.LineTo(R2.Right, R2.Top-1);
+          end;
+        end;
         ExcludeClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom);
         Break;
       end;
@@ -335,6 +400,14 @@ begin
   DrawTabs(False);
 end;
 
+procedure TNewTabSet.SetCloseButtons(Value: TBoolList);
+begin
+  FCloseButtons.Clear;
+  for var V in Value do
+    FCloseButtons.Add(V);
+  Invalidate;
+end;
+
 procedure TNewTabSet.SetHints(const Value: TStrings);
 begin
   FHints.Assign(Value);
@@ -371,10 +444,32 @@ procedure TNewTabSet.SetTheme(Value: TTheme);
 begin
   if FTheme <> Value then begin
     FTheme := Value;
+    var NewThemeDark := (FTheme <> nil) and FTheme.Dark;
+    if FThemeDark <> NewThemeDark then
+      UpdateThemeData(True);
+    FThemeDark := NewThemeDark;
     Invalidate;
   end;
 end;
 
+procedure TNewTabSet.UpdateThemeData(const Open: Boolean);
+begin
+  if FMenuThemeData <> 0 then begin
+    CloseThemeData(FMenuThemeData);
+    FMenuThemeData := 0;
+  end;
+
+  if Open then begin
+    if UseThemes then begin
+      if (FTheme <> nil) and FTheme.Dark then
+        FMenuThemeData := OpenThemeData(Handle, 'DarkMode::Menu')
+      else
+        FMenuThemeData := OpenThemeData(Handle, 'Menu');
+    end else
+      FMenuThemeData := 0;
+  end;
+end;
+
 procedure TNewTabSet.EnsureCurrentTabIsFullyVisible;
 var
   rcTab, rcCtl, rcLast: TRect;

Projects/CompForm.dfm

@@ -329,6 +329,7 @@ object CompileForm: TCompileForm
     Width = 361
     Height = 21
     Align = alTop
+    OnCloseButtonClick = MemosTabSetOnCloseButtonClick
     TabIndex = 0
     Tabs.Strings = (
       'Main Script')

Projects/CompForm.pas

@@ -319,6 +319,7 @@ type
     procedure VCloseTabClick(Sender: TObject);
     procedure VReopenTabClick(Sender: TObject);
     procedure MemosTabSetPopup(Sender: TObject);
+    procedure MemosTabSetOnCloseButtonClick(Sender: TObject);
   private
     { Private declarations }
     FMemos: TList<TCompScintEdit>;                      { FMemos[0] is the main memo and FMemos[1] the preprocessor output memo - also see MemosTabSet comment above }
@@ -485,7 +486,7 @@ type
     procedure UpdateSaveMenuItemAndButton;
     procedure UpdateTargetMenu;
     procedure UpdateTheme;
-    procedure UpdateThemeData(const Close, Open: Boolean);
+    procedure UpdateThemeData(const Open: Boolean);
     procedure UpdateStatusPanelHeight(H: Integer);
     procedure WMCopyData(var Message: TWMCopyData); message WM_COPYDATA;
     procedure WMDebuggerHello(var Message: TMessage); message WM_Debugger_Hello;
@@ -808,7 +809,7 @@ begin
 
   UpdateCaption;
 
-  UpdateThemeData(False, True);
+  UpdateThemeData(True);
 
   if CommandLineCompile then begin
     ReadSignTools(FSignTools);
@@ -860,7 +861,7 @@ destructor TCompileForm.Destroy;
   end;
 
 begin
-  UpdateThemeData(True, False);
+  UpdateThemeData(False);
 
   Application.OnActivate := nil;
   Application.OnIdle := nil;
@@ -2318,10 +2319,14 @@ end;
 
 procedure TCompileForm.VCloseTabClick(Sender: TObject);
 begin
-  { Hide memo, remove associated tab+hint and mark it as hidden }
   var Index := MemoToTabIndex(FActiveMemo);
+  { This is dirty code which directly accesses the tabset properties without
+    it knowing and also hides the memo without calling UpdatPreprocMemos but
+     doing it more cleanly is difficult }
   MemosTabSet.Tabs.Delete(Index);
   MemosTabSet.Hints.Delete(Index);
+  MemosTabSet.ShowHint := MemosTabSet.Hints.Count > 0;
+  MemosTabSet.CloseButtons.Delete(Index);
   FActiveMemo.Visible := False;
   FHiddenFiles.Add((FActiveMemo as TCompScintFileEdit).Filename);
   SaveKnownIncludedAndHiddenFiles(FMainMemo.Filename);
@@ -2765,6 +2770,11 @@ begin
   UpdateModifiedPanel;
 end;
 
+procedure TCompileForm.MemosTabSetOnCloseButtonClick(Sender: TObject);
+begin
+  VCloseTabClick(Self);
+end;
+
 procedure TCompileForm.InitializeFindText(Dlg: TFindDialog);
 var
   S: String;
@@ -3310,12 +3320,14 @@ end;
 
 procedure TCompileForm.UpdatePreprocMemos;
 
-  procedure UpdatePreprocessorOutputMemo(const NewTabs, NewHints: TStringList);
+  procedure UpdatePreprocessorOutputMemo(const NewTabs, NewHints: TStringList;
+    const NewCloseButtons: TBoolList);
   begin
     if FOptions.ShowPreprocessorOutput and (FPreprocessorOutput <> '') and
        not SameStr(TrimRight(FMainMemo.Lines.Text), FPreprocessorOutput) then begin
       NewTabs.Add('Preprocessor Output');
       NewHints.Add('');
+      NewCloseButtons.Add(False);
       FPreprocessorOutputMemo.ReadOnly := False;
       try
         FPreprocessorOutputMemo.Lines.Text := FPreprocessorOutput;
@@ -3330,7 +3342,8 @@ procedure TCompileForm.UpdatePreprocMemos;
     end;
   end;
 
-  procedure UpdateIncludedFilesMemos(const NewTabs, NewHints: TStringList);
+  procedure UpdateIncludedFilesMemos(const NewTabs, NewHints: TStringList;
+    const NewCloseButtons: TBoolList);
   var
     IncludedFile: TIncludedFile;
     I: Integer;
@@ -3361,6 +3374,7 @@ procedure TCompileForm.UpdatePreprocMemos;
             if FHiddenFiles.IndexOf(IncludedFile.Filename) = -1 then begin
               NewTabs.Insert(NextTabIndex, PathExtractName(IncludedFile.Filename));
               NewHints.Insert(NextTabIndex, GetFileTitle(IncludedFile.Filename));
+              NewCloseButtons.Insert(NextTabIndex, True);
               Inc(NextTabIndex);
             end;
 
@@ -3396,25 +3410,30 @@ procedure TCompileForm.UpdatePreprocMemos;
 
 var
   NewTabs, NewHints: TStringList;
+  NewCloseButtons: TBoolList;
   I, SaveTabIndex: Integer;
   SaveTabName: String;
 begin
   NewTabs := nil;
   NewHints := nil;
+  NewCloseButtons := nil;
   try
     NewTabs := TStringList.Create;
     NewTabs.Add(MemosTabSet.Tabs[0]); { 'Main Script' }
     NewHints := TStringList.Create;
     NewHints.Add(GetFileTitle(FMainMemo.Filename));
+    NewCloseButtons := TBoolList.Create;
+    NewCloseButtons.Add(False);
 
-    UpdatePreprocessorOutputMemo(NewTabs, NewHints);
-    UpdateIncludedFilesMemos(NewTabs, NewHints);
+    UpdatePreprocessorOutputMemo(NewTabs, NewHints, NewCloseButtons);
+    UpdateIncludedFilesMemos(NewTabs, NewHints, NewCloseButtons);
 
     { Set new tabs, try keep same file open }
     SaveTabIndex := MemosTabSet.TabIndex;
     SaveTabName := MemosTabSet.Tabs[MemosTabSet.TabIndex];
     MemosTabSet.Tabs := NewTabs;
     MemosTabSet.Hints := NewHints;
+    MemosTabSet.CloseButtons := NewCloseButtons;
     I := MemosTabSet.Tabs.IndexOf(SaveTabName);
     if I <> -1 then
        MemosTabSet.TabIndex := I;
@@ -3424,6 +3443,7 @@ begin
       MemosTabSetClick(MemosTabSet);
    end;
   finally
+    NewCloseButtons.Free;
     NewHints.Free;
     NewTabs.Free;
   end;
@@ -4504,13 +4524,11 @@ begin
   SetListTheme(FindResultsList);
 end;
 
-procedure TCompileForm.UpdateThemeData(const Close, Open: Boolean);
+procedure TCompileForm.UpdateThemeData(const Open: Boolean);
 begin
-  if Close then begin
-    if FProgressThemeData <> 0 then begin
-      CloseThemeData(FProgressThemeData);
-      FProgressThemeData := 0;
-    end;
+  if FProgressThemeData <> 0 then begin
+    CloseThemeData(FProgressThemeData);
+    FProgressThemeData := 0;
   end;
 
   if Open then begin
@@ -4990,7 +5008,7 @@ end;
 procedure TCompileForm.WMThemeChanged(var Message: TMessage);
 begin
   { Don't Run to Cursor into this function, it will interrupt up the theme change }
-  UpdateThemeData(True, True);
+  UpdateThemeData(True);
   inherited;
 end;