A Delphi VCL Task Dialog-like Table Dialog

This class implements a list view-based table dialog box for the Delphi VCL framework and the native Win32 platform.

First, let us give some examples of this class in action. Then we will give the full source code.

Examples

A simple table dialog box with an OK button.

var res := TTableDialog.ShowTable(
  Self,
  'Audio Properties',
  ['Duration', 'Channel count', 'Sample frequency', 'Bit depth'],
  ['24 s', '2', '44.1 kHz', '32'],
  mtInformation
);

A simple table dialog box with an information icon, a blue (“Main Instruction”) title, and an OK button.

A simple table dialog box with a question mark icon, a blue (“Main Instruction”) title, and Yes, No, and Cancel buttons.

The table can be copied to clipboard and is adjusting its size intelligently depending on its content. Since the table is a list view, truncated strings are shown in full in tooltips:

A table dialog with a very long value being truncated.

A table dialog with a very long value being truncated but shown in full in a tooltip because the cursor is hovering above it.

Similarly, a vertical scrollbar is displayed if necessary (here you also see that high DPI is supported):

A table dialog with a very long list of name–value pairs, forcing a vertical scrollbar to be displayed (125% DPI).

Source code

{******************************************************************************}
{                                                                              }
{ Rejbrand Task Table Dialog                                                   }
{                                                                              }
{ Copyright © 2021 Andreas Rejbrand                                            }
{                                                                              }
{ https://english.rejbrand.se/                                                 }
{                                                                              }
{******************************************************************************}

unit TableDialog;

interface

uses
  Windows, Messages, SysUtils, Types, UITypes, Classes, Forms, Dialogs,
  Controls, Graphics, StdCtrls, ComCtrls;

type
  TTableDialog = class
  strict private
    type TFormData = class(TComponent)
    public
      ListView: TListView;
      IconKind: PWideChar;
      Icon: HICON;
      LIWSD: Boolean;
      Title: string;
    end;
    class function Scale(X: Integer): Integer; static;
    class procedure FormShow(Sender: TObject);
    class procedure FormDestroy(Sender: TObject);
    class procedure FormPaint(Sender: TObject);
    class procedure FormKeyPress(Sender: TObject; var Key: Char);
    class procedure LVToClipboard(AListView: TListView);
    class function GetTitleWidth(const AFormData: TFormData): Integer; static;
    class procedure SetupTitleFont(ACanvas: TCanvas); static;
  public
    class function ShowTable(AOwner: TCustomForm; const ACaption, ATitle: string;
      const ANames, AValues: array of string;
      const AButtonTypes: array of TModalResult;
      const AButtonLabels: array of string;
      ADefaultButton, ACancelButton: TModalResult;
      ADialogType: TMsgDlgType;
      const AWidth: Integer = 0; const AHeight: Integer = 0): TModalResult; overload;
    class function ShowTable(AOwner: TCustomForm; const ACaption, ATitle: string;
      const ANames, AValues: array of string;
      ADialogType: TMsgDlgType;
      const AWidth: Integer = 0; const AHeight: Integer = 0): TModalResult; overload;
    class function ShowTable(AOwner: TCustomForm; const ACaption: string;
      const ANames, AValues: array of string;
      ADialogType: TMsgDlgType;
      const AWidth: Integer = 0; const AHeight: Integer = 0): TModalResult; overload;
  end;

implementation

uses
  Math, Clipbrd, CommCtrl;

class procedure TTableDialog.FormShow(Sender: TObject);
var
  FormData: TFormData;
  ComCtl: HMODULE;
  LoadIconWithScaleDown: function(hinst: HINST; pszName: LPCWSTR; cx: Integer;
    cy: Integer; var phico: HICON): HResult; stdcall;
begin
  if not (Sender is TForm) then
    Exit;
  if not (TObject(TForm(Sender).Tag) is TFormData) then
    Exit;
  TForm(Sender).OnShow := nil;
  FormData := TFormData(TForm(Sender).Tag);
  if FormData.IconKind = nil then
    Exit;
  ComCtl := LoadLibrary('ComCtl32.dll');
  if ComCtl <> 0 then
  begin
    try
      LoadIconWithScaleDown := GetProcAddress(ComCtl, 'LoadIconWithScaleDown');
      if Assigned(LoadIconWithScaleDown) then
        FormData.LIWSD := Succeeded(LoadIconWithScaleDown(0, FormData.IconKind,
          Scale(32), Scale(32), FormData.Icon));
    finally
      FreeLibrary(ComCtl);
    end;
  end;
  if not FormData.LIWSD then
    FormData.Icon := LoadIcon(0, FormData.IconKind);
end;

class function TTableDialog.GetTitleWidth(const AFormData: TFormData): Integer;
var
  bm: TBitmap;
begin

  if AFormData.Title.IsEmpty then
    Exit(0);

  bm := TBitmap.Create;
  try
    SetupTitleFont(bm.Canvas);
    Result := bm.Canvas.TextWidth(AFormData.Title)
  finally
    bm.Free;
  end;

end;

class procedure TTableDialog.FormDestroy(Sender: TObject);
var
  FormData: TFormData;
begin
  if not (Sender is TForm) then
    Exit;
  if not (TObject(TForm(Sender).Tag) is TFormData) then
    Exit;
  FormData := TFormData(TForm(Sender).Tag);
  if (FormData.Icon <> 0) and FormData.LIWSD then
    DestroyIcon(FormData.Icon);
end;

class procedure TTableDialog.FormKeyPress(Sender: TObject; var Key: Char);
var
  FormData: TFormData;
begin
  if not (Sender is TForm) then
    Exit;
  if not (TObject(TForm(Sender).Tag) is TFormData) then
    Exit;
  FormData := TFormData(TForm(Sender).Tag);
  case Key of
    ^C:
      LVToClipboard(FormData.ListView);
  end;
end;

class procedure TTableDialog.FormPaint(Sender: TObject);
var
  FormData: TFormData;
  Frm: TForm;
  Y: Integer;
  R: TRect;
  S: string;
begin

  if not (Sender is TForm) then
    Exit;

  if not (TObject(TForm(Sender).Tag) is TFormData) then
    Exit;

  Frm := TForm(Sender);
  FormData := TFormData(TForm(Sender).Tag);

  Y := Frm.ClientHeight - Scale(25 + 8 + 8);

  Frm.Canvas.Brush.Color := clWhite;
  Frm.Canvas.FillRect(Rect(0, 0, Frm.ClientWidth, Y));

  Frm.Canvas.Pen.Color := $00DFDFDF;
  Frm.Canvas.MoveTo(0, Y);
  Frm.Canvas.LineTo(Frm.ClientWidth, Y);

  if FormData.Icon <> 0 then
  begin
    DrawIconEx(Frm.Canvas.Handle, Scale(8), Scale(8), FormData.Icon,
      Scale(32), Scale(32), 0, 0, DI_NORMAL);
    R.Left := R.Left + Scale(32 + 8);
  end;

  S := FormData.Title;

  if not s.IsEmpty then
  begin
    R := Rect(
      Scale(IfThen(FormData.Icon <> 0, 8 + 32 + 8, 8)),
      Scale(8),
      Frm.ClientWidth - Scale(8),
      Scale(8 + 32)
    );
    SetupTitleFont(Frm.Canvas);
    Frm.Canvas.TextRect(R, S, [tfSingleLine, tfLeft, tfTop, tfEndEllipsis]);
  end;

end;

class procedure TTableDialog.LVToClipboard(AListView: TListView);

  function GetRow(AIndex: Integer): string;
  begin
    if InRange(AIndex, 0, AListView.Items.Count - 1) and (AListView.Items[AIndex].SubItems.Count = 1) then
      Result := AListView.Items[AIndex].Caption + #9 + AListView.Items[AIndex].SubItems[0]
    else
      Result := '';
  end;

var
  S: string;
  i: Integer;
begin
  if AListView = nil then
    Exit;
  S := GetRow(0);
  for i := 1 to AListView.Items.Count - 1 do
    S := S + sLineBreak + GetRow(i);
  Clipboard.AsText := S;
end;

class function TTableDialog.Scale(X: Integer): Integer;
begin
  Result := MulDiv(X, Screen.PixelsPerInch, 96);
end;

class procedure TTableDialog.SetupTitleFont(ACanvas: TCanvas);
begin
  if Screen.Fonts.IndexOf('Segoe UI') <> -1 then
    ACanvas.Font.Name := 'Segoe UI'
  else if Screen.Fonts.IndexOf('Tahoma') <> -1 then
    ACanvas.Font.Name := 'Tahoma';
  ACanvas.Font.Size := 12;
  ACanvas.Font.Color := $00993300;
end;

class function TTableDialog.ShowTable(AOwner: TCustomForm; const ACaption: string;
  const ANames, AValues: array of string; ADialogType: TMsgDlgType;
  const AWidth, AHeight: Integer): TModalResult;
begin
  Result := ShowTable(
    AOwner,
    ACaption,
    '',
    ANames,
    AValues,
    [mrOk],
    ['OK'],
    mrOk,
    mrOk,
    ADialogType,
    AWidth,
    AHeight);
end;

class function TTableDialog.ShowTable(AOwner: TCustomForm; const ACaption,
  ATitle: string; const ANames, AValues: array of string;
  ADialogType: TMsgDlgType; const AWidth, AHeight: Integer): TModalResult;
begin
  Result := ShowTable(
    AOwner,
    ACaption,
    ATitle,
    ANames,
    AValues,
    [mrOk],
    ['OK'],
    mrOk,
    mrOk,
    ADialogType,
    AWidth,
    AHeight);
end;

class function TTableDialog.ShowTable(AOwner: TCustomForm;
  const ACaption, ATitle: string;
  const ANames, AValues: array of string;
  const AButtonTypes: array of TModalResult;
  const AButtonLabels: array of string;
  ADefaultButton, ACancelButton: TModalResult;
  ADialogType: TMsgDlgType;
  const AWidth, AHeight: Integer): TModalResult;
const
  Sounds: array[TMsgDlgType] of Integer =
    (MB_ICONWARNING, MB_ICONERROR, MB_ICONINFORMATION, MB_ICONQUESTION, 0);
  Icons: array[TMsgDlgType] of MakeIntResource =
    (IDI_WARNING, IDI_ERROR, IDI_INFORMATION, IDI_QUESTION, nil);
var
  dlg: TForm;
  FormData: TFormData;
  lv: TListView;
  btn: TButton;
  i: Integer;
  snd: Integer;
  W0, W1, W01Min, W01Max, MinW, H, RSpace: Integer;
begin

  if Length(ANames) <> Length(AValues) then
    raise Exception.Create('The lengths of the columns don''t match.');

  if Length(AButtonTypes) <> Length(AButtonLabels) then
    raise Exception.Create('The lengths of the button arrays don''t match.');

  dlg := TForm.Create(AOwner);
  try

    dlg.BorderStyle := bsDialog;
    dlg.Caption := ACaption;
    if AWidth <> 0 then
      dlg.Width := Scale(AWidth)
    else
      dlg.Width := Scale(640);
    if AHeight <> 0 then
      dlg.Height := Scale(AHeight)
    else
      dlg.Height := Scale(480);
    dlg.Position := poOwnerFormCenter;
    dlg.Scaled := False;
    dlg.Font.Name := 'Segoe UI';
    dlg.Font.Size := 9;
    FormData := TFormData.Create(dlg);
    dlg.Tag := NativeInt(FormData);
    TFormData(dlg.Tag).IconKind := Icons[ADialogType];
    TFormData(dlg.Tag).Title := ATitle;
    dlg.OnShow := FormShow;
    dlg.OnDestroy := FormDestroy;
    dlg.OnPaint := FormPaint;
    dlg.OnKeyPress := FormKeyPress;
    dlg.KeyPreview := True;

    for i := 0 to High(AButtonTypes) do
    begin
      btn := TButton.Create(dlg);
      btn.Parent := dlg;
      btn.Caption := AButtonLabels[i];
      btn.Default := AButtonTypes[i] = ADefaultButton;
      btn.Cancel := AButtonTypes[i] = ACancelButton;
      btn.ModalResult := AButtonTypes[i];
      btn.Width := Scale(75);
      btn.Height := Scale(25);
      btn.Left := dlg.ClientWidth - (btn.Width + Scale(8)) * (Length(AButtonTypes) - i);
      btn.Top := dlg.ClientHeight - btn.Height - Scale(8);
      btn.Anchors := [akRight, akBottom];
    end;

    lv := TListView.Create(dlg);
    TFormData(dlg.Tag).ListView := lv;
    lv.Parent := dlg;
    lv.DoubleBuffered := True;
    lv.ReadOnly := True;
    lv.BorderStyle := bsNone;
    lv.Left := Scale(8) + IfThen(Icons[ADialogType] <> nil, Scale(32 + 8));
    lv.Width := dlg.ClientWidth - Scale(16) - IfThen(Icons[ADialogType] <> nil, Scale(32 + 8));
    if ATitle.IsEmpty then
    begin
      lv.Top := Scale(8);
      lv.Height := dlg.ClientHeight - Scale(16 + 8 + 4) - Scale(25);
    end
    else
    begin
      lv.Top := Scale(8 + 32 + 8);
      lv.Height := dlg.ClientHeight - Scale(8 + 32 + 8 + 8 + 4 + 8) - Scale(25);
    end;
    lv.Anchors := [akLeft, akTop, akRight, akBottom];
    lv.ViewStyle := vsReport;
    lv.RowSelect := True;
    lv.ShowColumnHeaders := False;

    RSpace := GetSystemMetricsForWindow(SM_CXVSCROLL, dlg.Handle) + scale(2);

    with lv.Columns.Add do
    begin
      Caption := 'Name';
      Width := Min(Scale(150), lv.ClientWidth div 2);
    end;
    with lv.Columns.Add do
    begin
      Caption := 'Value';
      Width := lv.ClientWidth - lv.Columns[0].Width - RSpace;
    end;

    W0 := 0;
    W1 := 0;

    lv.Items.BeginUpdate;
    try
      for i := 0 to High(ANames) do
        with lv.Items.Add do
        begin
          Caption := ANames[i];
          SubItems.Add(AValues[i]);
          W0 := Max(W0, ListView_GetStringWidth(lv.Handle, PChar('XXI' + ANames[i])));
          W1 := Max(W1, ListView_GetStringWidth(lv.Handle, PChar('XXI' + AValues[i])));
        end;
    finally
      lv.Items.EndUpdate;
    end;

    if lv.Items.Count > 0 then
      H := lv.Items[0].DisplayRect(drBounds).Height
    else
      H := 0;

    if AWidth = 0 then
    begin
      if ATitle.IsEmpty then
        MinW := Scale(300)
      else
        MinW := Min(Scale(8) + IfThen(Icons[ADialogType] <> nil, Scale(32 + 8)) + GetTitleWidth(FormData) + Scale(16), Scale(800));
      MinW := Max(MinW, Scale(300));
      MinW := Max(MinW, Scale(75) * Length(AButtonTypes) + Scale(8) * (Length(AButtonTypes) + 1));
      W01Min := Min(W0, W1);
      W01Max := Max(W0, W1);
      if W01Min < W01Max div 5 then
        W01Min := W01Max div 5;
      dlg.ClientWidth := EnsureRange(
        dlg.ClientWidth - lv.Width + W01Max + W01Min + RSpace,
        MinW,
        Scale(800)
      );
    end;

    if AHeight = 0 then
      dlg.ClientHeight := EnsureRange(
        dlg.ClientHeight - lv.Height + Succ(lv.Items.Count) * H,
        Scale(100),
        Scale(600)
      );

    if (Round(1.2 * W0) < (lv.ClientWidth - RSpace) div 2) and (Round(1.2 * W0) + W1 < lv.ClientWidth - RSpace) then
      W0 := Round(1.2 * W0);

    if (W0 > (lv.ClientWidth - RSpace) div 2) and (W1 > (lv.ClientWidth - RSpace) div 2) then
      W0 := (lv.ClientWidth - RSpace) div 2;

    if (W0 > 2 * (lv.ClientWidth - RSpace) div 3) and (W1 > (lv.ClientWidth - RSpace) div 3) then
      W0 := (lv.ClientWidth - RSpace) div 2;

    lv.Columns[0].Width :=
      EnsureRange(
        W0,
        lv.ClientWidth div 6,
        3 * lv.ClientWidth div 4
      );

    lv.Columns[1].Width := lv.ClientWidth - lv.Columns[0].Width - RSpace;

    snd := Sounds[ADialogType];
    if snd <> 0 then
      MessageBeep(snd);

    for var CtlIdx := 0 to dlg.ControlCount - 1 do
      if (dlg.Controls[CtlIdx] is TButton) and TButton(dlg.Controls[CtlIdx]).Default then
      begin
        dlg.ActiveControl := TButton(dlg.Controls[CtlIdx]);
        Break;
      end;

    Result := dlg.ShowModal;

  finally
    dlg.Free;
  end;

end;

end.