unit ListViewEx;

interface

uses
  SysUtils, Windows, Messages, Types, Classes, Graphics, Vcl.Controls, Vcl.Menus,
  Vcl.ComCtrls, Vcl.Forms, CommCtrl, UITypes;

type
  TColumnSortMethod = (csmText, csmInteger, csmFloat, csmDateTime);

  TListViewEx = class(TListView)
  strict private
    FSortColumn: Integer;
    FSortAscending: Boolean;
    FEnableSorting: Boolean;
    FOnSelCntChange: TNotifyEvent;
    FEmptyText: string;
    class constructor Create;
    class destructor Destroy;
    procedure SetSortColumn(const Value: Integer);
    procedure SetSortAscending(const Value: Boolean);
    procedure DoSelCntChange;
    procedure SetEmptyText(const AText: string);
  strict protected
    procedure ApplySortingIndicator(ColumnIndex: Integer; Ascending: Boolean);
  protected
    procedure KeyPress(var Key: Char); override;
    procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
    procedure ColClick(Column: TListColumn); override;
    procedure Resize; override;
    procedure DoSelectItem(Item: TListItem; Selected: Boolean); override;
    function OwnerDataStateChange(StartIndex: Integer; EndIndex: Integer;
      OldState: TItemStates; NewState: TItemStates): Boolean; override;
    procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
    procedure CreateWnd; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure SelectAll; override;
    procedure ClearSelection; override;
    function GetSelRows: string;
    procedure CopySelRows;
    function GetSelectedIndicesFast: TArray<Integer>;
    function GetSelectedCaptions: TArray<string>;
    function AdjustColumns: Boolean;
    procedure EnableSorting(const AColumnTypes: array of TColumnSortMethod);
    procedure DisableSorting;
    procedure Sort(const AColumnIndex: Integer; const AAscending: Boolean = True);
    procedure Resort;
  published
    property Action;
    property Align;
    property AllocBy;
    property Anchors;
    property BevelEdges;
    property BevelInner;
    property BevelOuter;
    property BevelKind default bkNone;
    property BevelWidth;
    property BiDiMode;
    property BorderStyle;
    property BorderWidth;
    property Checkboxes;
    property Color;
    property Columns;
    property ColumnClick;
    property Constraints;
    property Ctl3D;
    property DoubleBuffered default True;
    property DragCursor;
    property DragKind;
    property DragMode;
    property EmptyText: string read FEmptyText write SetEmptyText;
    property Enabled;
    property Font;
    property FlatScrollBars;
    property FullDrag;
    property GridLines;
    property Groups;
    property HideSelection default False;
    property HotTrack;
    property HotTrackStyles;
    property HoverTime;
    property IconOptions;
    property Items;
    property LargeImages;
    property MultiSelect;
    property StyleElements;
    property OwnerData;
    property OwnerDraw;
    property GroupHeaderImages;
    property GroupView default False;
    property ReadOnly default False;
    property RowSelect default True;
    property ParentBiDiMode;
    property ParentColor default False;
    property ParentDoubleBuffered;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowColumnHeaders;
    property ShowWorkAreas;
    property ShowHint;
    property SmallImages;
    property SortAscending: Boolean read FSortAscending write SetSortAscending default True;
    property SortColumn: Integer read FSortColumn write SetSortColumn default -1;
    property SortType;
    property StateImages;
    property TabOrder;
    property TabStop default True;
    property Touch;
    property ViewStyle;
    property Visible;
    property OnAdvancedCustomDraw;
    property OnAdvancedCustomDrawItem;
    property OnAdvancedCustomDrawSubItem;
    property OnChange;
    property OnChanging;
    property OnClick;
    property OnColumnClick;
    property OnColumnDragged;
    property OnColumnRightClick;
    property OnCompare;
    property OnContextPopup;
    property OnCustomDraw;
    property OnCustomDrawItem;
    property OnCustomDrawSubItem;
    property OnCreateItemClass;
    property OnData;
    property OnDataFind;
    property OnDataHint;
    property OnDataStateChange;
    property OnDblClick;
    property OnDeletion;
    property OnDrawItem;
    property OnEdited;
    property OnEditing;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGesture;
    property OnGetImageIndex;
    property OnGetSubItemImage;
    property OnDragDrop;
    property OnDragOver;
    property OnInfoTip;
    property OnInsert;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnSelCntChange: TNotifyEvent read FOnSelCntChange write FOnSelCntChange;
    property OnSelectItem;
    property OnItemChecked;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

uses
  Math, Vcl.Clipbrd, Vcl.Dialogs, Vcl.Themes, DateUtils, Winapi.ShlObj,
  StdCtrls, Buttons, StrUtils, Generics.Collections, UxTheme;

var
  InvFS: TFormatSettings;

function NaturalStringToIntDef(const S: string; const Def: Integer): Integer;
begin
  Result := StrToIntDef(S, Def);
end;

function NaturalStringToFloatDef(const S: string; const Def: Double): Double;
begin
  var T := S;
  for var i := 1 to T.Length do
    if T[i] = ',' then
      T[i] := '.';
  Result := StrToFloatDef(T, Def, InvFS);
end;

{ TListViewEx }

class constructor TListViewEx.Create;
begin
  TCustomStyleEngine.RegisterStyleHook(TListViewEx, TListViewStyleHook);
end;

class destructor TListViewEx.Destroy;
begin
  TCustomStyleEngine.UnRegisterStyleHook(TListViewEx, TListViewStyleHook);
end;

procedure TListViewEx.DisableSorting;
begin
  FEnableSorting := False;
end;

procedure TListViewEx.DoSelCntChange;
begin
  if Assigned(FOnSelCntChange) then
    FOnSelCntChange(Self);
end;

procedure TListViewEx.DoSelectItem(Item: TListItem; Selected: Boolean);
begin
  inherited;
  DoSelCntChange;
end;

procedure TListViewEx.EnableSorting(
  const AColumnTypes: array of TColumnSortMethod);
begin

  if ViewStyle <> vsReport then
    Exit;

  for var i := 0 to Columns.Count - 1 do
    if i <= High(AColumnTypes) then
      Columns[i].Tag := ord(AColumnTypes[i])
    else
      Columns[i].Tag := ord(csmText);

  FEnableSorting := True;
  ColumnClick := True;

end;

function SortProc(Left, Right: TListItem; AListView: TListViewEx): Integer; stdcall;
var
  col: Integer;
  asc: Boolean;
  csm: TColumnSortMethod;
  s1, s2: string;
begin

  col := AListView.SortColumn;
  asc := AListView.SortAscending;
  csm := TColumnSortMethod(AListView.Columns[col].Tag);

  if col = 0 then
  begin
    s1 := Left.Caption;
    s2 := Right.Caption;
  end
  else
  begin
    if col <= Left.SubItems.Count then
      s1 := Left.SubItems[col - 1]
    else
      s1 := '';

    if col <= Right.SubItems.Count then
      s2 := Right.SubItems[col - 1]
    else
      s2 := '';
  end;

  case csm of
    csmText:
      Result := AnsiCompareText(s1, s2);
    csmInteger:
      Result := CompareValue(NaturalStringToIntDef(s1, 0), NaturalStringToIntDef(s2, 0));
    csmFloat:
      Result := CompareValue(NaturalStringToFloatDef(s1, 0), NaturalStringToFloatDef(s2, 0));
    csmDateTime:
      Result := CompareDateTime(StrToDateTimeDef(s1, 0),  StrToDateTimeDef(s2, 0));
  else
    Result := 0;
  end;

  if not asc then
    Result := -Result;

end;

procedure TListViewEx.ClearSelection;
begin
  ListView_SetItemState(Handle, -1, 0, LVIS_SELECTED);
end;

procedure TListViewEx.CNNotify(var Message: TWMNotify);
begin
  inherited;
  if not FEmptyText.IsEmpty and (Message.NMHdr.hwndFrom = Handle) and (Message.NMHdr.code = LVN_GETEMPTYMARKUP) then
  begin
    with PNMLVEmptyMarkup(Message.NMHdr)^ do
    begin
      dwFlags := EMF_CENTERED;
      FillChar(szMarkup, SizeOf(szMarkup), 0);
      Move(FEmptyText[1], szMarkup[0], SizeOf(FEmptyText[1]) * FEmptyText.Length);
    end;
    Message.Result := Ord(True);
  end;
end;

procedure TListViewEx.ColClick(Column: TListColumn);
begin

  inherited;

  if FEnableSorting and not OwnerData then
  begin

    if Column.Index = FSortColumn then
      SortAscending := not FSortAscending // triggers setter
    else
    begin
      FSortAscending := True;
      SortColumn := Column.Index; // triggers setter
    end;

    CustomSort(@SortProc, NativeInt(Self));

  end;

end;

procedure TListViewEx.CopySelRows;
begin
  var S := GetSelRows;
  if not S.IsEmpty then
    Clipboard.AsText := S;
end;

constructor TListViewEx.Create(AOwner: TComponent);
begin

  inherited;

  FSortColumn := -1;
  FSortAscending := True;
  FEnableSorting := False;

  DoubleBuffered := True;
  RowSelect := True;
  HideSelection := False;

end;

procedure TListViewEx.CreateWnd;
begin
  inherited;
  ListView_SetExtendedListViewStyleEx(Handle, LVS_EX_DOUBLEBUFFER, LVS_EX_DOUBLEBUFFER);
  SetWindowTheme(Handle, 'Explorer', nil)
end;

function TListViewEx.GetSelectedCaptions: TArray<string>;
begin
  var Idxs := GetSelectedIndicesFast;
  SetLength(Result, Length(Idxs));
  for var i := 0 to High(Idxs) do
    Result[i] := Items[Idxs[i]].Caption;
end;

function TListViewEx.GetSelectedIndicesFast: TArray<Integer>;
var
  c, idx: Integer;
begin

  var LSelCount := Self.SelCount;

  if Self.Items.Count = LSelCount then
  begin
    SetLength(Result, LSelCount);
    for var i := 0 to High(Result) do
      Result[i] := i;
    Exit;
  end;

  SetLength(Result, LSelCount);
  idx := -1;
  c := 0;
  repeat
    idx := ListView_GetNextItem(Handle, idx, LVNI_ALL or LVNI_SELECTED);
    if idx <> -1 then
    begin
      Result[c] := idx;
      Inc(c);
    end;
  until idx = -1;

end;

function TListViewEx.GetSelRows: string;
begin
  var idx := GetSelectedIndicesFast;
  var L := TList<string>.Create;
  try
    for var i in idx do
    begin
      var S := Items[i].Caption;
      for var c := 0 to Columns.Count - 2 do
        if c < Items[i].SubItems.Count then
          S := S + #9 + Items[i].SubItems[c]
        else
          S := S + #9;
      L.Add(S);
    end;
    Result := string.Join(#13#10, L.ToArray);
  finally
    L.Free;
  end;
end;

procedure TListViewEx.KeyPress(var Key: Char);
begin
  inherited;
  case Key of
    ^A:
      SelectAll;
    ^C:
      CopySelRows;
  end;
end;

function TListViewEx.OwnerDataStateChange(StartIndex, EndIndex: Integer;
  OldState, NewState: TItemStates): Boolean;
begin
  inherited;
  DoSelCntChange;
  Result := True;
end;

procedure TListViewEx.Resize;
begin
  inherited;
  ApplySortingIndicator(FSortColumn, FSortAscending);
end;

procedure TListViewEx.Resort;
begin

  if FEnableSorting and not OwnerData then
  begin

    ApplySortingIndicator(FSortColumn, FSortAscending);

    if FSortColumn <> -1 then
      CustomSort(@SortProc, NativeInt(Self));

  end;

end;

procedure TListViewEx.SelectAll;
begin
  if MultiSelect then
    ListView_SetItemState(Handle, -1, LVIS_SELECTED, LVIS_SELECTED);
end;

procedure TListViewEx.SetEmptyText(const AText: string);
begin
  if FEmptyText <> AText then
  begin
    FEmptyText := AText;
    RecreateWnd;
  end;
end;

procedure TListViewEx.SetSortAscending(const Value: Boolean);
begin
  FSortAscending := Value;
  ApplySortingIndicator(FSortColumn, FSortAscending);
end;

procedure TListViewEx.SetSortColumn(const Value: Integer);
begin
  FSortColumn := Value;
  ApplySortingIndicator(FSortColumn, FSortAscending);
end;

procedure TListViewEx.Sort(const AColumnIndex: Integer;
  const AAscending: Boolean);
begin

  if FEnableSorting and not OwnerData then
  begin

    FSortColumn := AColumnIndex;
    FSortAscending := AAscending;
    ApplySortingIndicator(FSortColumn, FSortAscending);

    if AColumnIndex <> -1 then
      CustomSort(@SortProc, NativeInt(Self));

  end;

end;

procedure TListViewEx.WMNotify(var Message: TWMNotify);
type
  PNMHeader = ^TNMHeader;
  TNMHeader = tagNMHEADERW;
begin
  inherited;
  if Message.NMHdr^.hwndFrom = ListView_GetHeader(Handle) then
    case Message.NMHdr^.code of
      HDN_ENDTRACK, HDN_DIVIDERDBLCLICK:
        begin
          ApplySortingIndicator(FSortColumn, FSortAscending);
        end;
     end
end;

function TListViewEx.AdjustColumns: Boolean;
var
  AutoSizeWidths: TArray<Integer>;
  TotalAutoSizeWidth: Integer;
  NumAutoSizeCols: Integer;
  FixedWidth: Integer;
  FreeWidth: Integer;
  VScrollLikely: Boolean;
  hdr: HWND;
  hdrRect: TRect;
  hdrHeight: Integer;
begin

  Result := False;

  if ViewStyle <> vsReport then
    Exit;

  SetLength(AutoSizeWidths, Columns.Count);
  FixedWidth := 0;
  TotalAutoSizeWidth := 0;
  NumAutoSizeCols := 0;
  for var i := 0 to Columns.Count - 1 do
    if Columns[i].AutoSize then
    begin
      AutoSizeWidths[i] := Columns[i].Width;
      Inc(TotalAutoSizeWidth, AutoSizeWidths[i]);
      Inc(NumAutoSizeCols);
    end
    else
      Inc(FixedWidth, Columns[i].Width);

  if TotalAutoSizeWidth = 0 then
    Exit;

  hdr := ListView_GetHeader(Handle);
  if (hdr <> 0) and GetWindowRect(hdr, hdrRect) then
    hdrHeight := hdrRect.Height
  else
    hdrHeight := 24;

  if Items.Count > 0 then
    VScrollLikely := Items.Count * Items[0].DisplayRect(drBounds).Height >=
      Height - 2 * GetSystemMetrics(SM_CYEDGE) - hdrHeight
  else
    VScrollLikely := False;

  FreeWidth := Width - 2 * GetSystemMetrics(SM_CXEDGE) - FixedWidth;
  if VScrollLikely then
    Dec(FreeWidth, GetSystemMetrics(SM_CXVSCROLL));

  if FreeWidth < 6 * NumAutoSizeCols then
    Exit;

  for var i := 0 to Columns.Count - 1 do
    if Columns[i].AutoSize then
      Columns[i].Width := Floor(FreeWidth * AutoSizeWidths[i] / TotalAutoSizeWidth);

  Result := True;

end;

procedure TListViewEx.ApplySortingIndicator(ColumnIndex: Integer;
  Ascending: Boolean);
var
  header: HWND;
  hitem: THDItem;
begin

  if ViewStyle <> vsReport then
    Exit;

  header := ListView_GetHeader(Handle);
  hitem.Mask := HDI_FORMAT;
  for var i := 0 to Columns.Count - 1 do
    if Header_GetItem(header, i, hitem) then
    begin
      if i = ColumnIndex then
        if Ascending then
          hitem.fmt := (hitem.fmt or HDF_SORTUP) and not HDF_SORTDOWN
        else
          hitem.fmt := (hitem.fmt or HDF_SORTDOWN) and not HDF_SORTUP
      else
        hitem.fmt := hitem.fmt and not (HDF_SORTUP or HDF_SORTDOWN);
      Header_SetItem(header, i, hitem);
    end;

end;

procedure Register;
begin
  RegisterComponents('Rejbrand 2020', [TListViewEx]);
end;

initialization
  InvFS := TFormatSettings.Invariant;

end.
