Subversion Repositories userdetect2

Rev

Rev 77 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
68 daniel-mar 1 
unit VTSListView;
2 
 
81 daniel-mar 3 
{$WARN UNSAFE_CODE OFF}
4 
{$WARN UNSAFE_TYPE OFF}
5 
 
68 daniel-mar 6 
interface
7 
 
8 
// This ListView adds support for sorting arrows
9 
 
10 
// Recommended usage for the OnCompare event:
11 
(*
12 
procedure TForm1.ListViewCompare(Sender: TObject; Item1,
13 
  Item2: TListItem; Data: Integer; var Compare: Integer);
14 
var
15 
  ListView: TVTSListView;
16 
begin
17 
  ListView := Sender as TVTSListView;
18 
  if ListView.CurSortedColumn = 0 then
19 
  begin
20 
    Compare := CompareText(Item1.Caption, Item2.Caption);
21 
  end
22 
  else
23 
  begin
24 
    Compare := CompareText(Item1.SubItems[ListView.CurSortedColumn-1],
25 
                           Item2.SubItems[ListView.CurSortedColumn-1]);
26 
  end;
27 
  if ListView.CurSortedDesc then Compare := -Compare;
28 
end;
29 
*)
30 
 
31 
uses
32 
  Windows, Messages, SysUtils, Classes, Controls, ComCtrls, CommCtrl;
33 
 
34 
type
35 
  TVTSListView = class(TListView)
36 
  private
37 
    FDescending: Boolean;
38 
    FSortedColumn: Integer;
39 
    procedure WMNotifyMessage(var msg: TWMNotify); message WM_NOTIFY;
40 
  protected
41 
    procedure ShowArrowOfListViewColumn;
42 
    procedure ColClick(Column: TListColumn); override;
43 
  public
44 
    constructor Create(AOwner: TComponent); override;
45 
  published
46 
    property CurSortedColumn: integer read FSortedColumn;
47 
    property CurSortedDesc: boolean read FDescending;
48 
  end;
49 
 
50 
procedure Register;
51 
 
52 
implementation
53 
 
54 
// The arrows require a XP Manifest
55 
 
56 
{$IF not Declared(HDF_SORTUP)}
57 
const
58 
  { For Windows >= XP }
59 
  {$EXTERNALSYM HDF_SORTUP}
60 
  HDF_SORTUP              = $0400;
61 
  {$EXTERNALSYM HDF_SORTDOWN}
62 
  HDF_SORTDOWN            = $0200;
63 
{$IFEND}
64 
 
65 
{ TVTSListView }
66 
 
67 
constructor TVTSListView.Create(AOwner: TComponent);
68 
begin
69 
  inherited;
70 
  FSortedColumn := -1;
71 
end;
72 
 
73 
procedure TVTSListView.ShowArrowOfListViewColumn;
74 
var
75 
  Header: HWND;
76 
  Item: THDItem;
77 
  i: integer;
78 
begin
79 
  Header := ListView_GetHeader(Handle);
80 
  ZeroMemory(@Item, SizeOf(Item));
81 
  Item.Mask := HDI_FORMAT;
82 
 
83 
  // Remove arrows
84 
  for i := 0 to Columns.Count-1 do
85 
  begin
86 
    Header_GetItem(Header, i, Item);
87 
    Item.fmt := Item.fmt and not (HDF_SORTUP or HDF_SORTDOWN);
88 
    Header_SetItem(Header, i, Item);
89 
  end;
90 
 
91 
  // Add arrow
92 
  Header_GetItem(Header, FSortedColumn, Item);
93 
  if FDescending then
94 
    Item.fmt := Item.fmt or HDF_SORTDOWN
95 
  else
96 
    Item.fmt := Item.fmt or HDF_SORTUP;
97 
  Header_SetItem(Header, FSortedColumn, Item);
98 
end;
99 
 
100 
procedure TVTSListView.WMNotifyMessage(var msg: TWMNotify);
101 
begin
77 daniel-mar 102 
  try
103 
    inherited;
104 
  except
105 
    // Workaround for Delphi 6, which raises an EAccessViolation in
106 
    // CallWindowProc at TWinControl.DefaultHandler, when the code executed
107 
    // on Windows Server 2008.
108 
  end;
68 daniel-mar 109 
  if (Msg.NMHdr^.code = HDN_ENDTRACK) and (FSortedColumn > -1) then
110 
  begin
111 
    ShowArrowOfListViewColumn;
112 
  end;
113 
end;
114 
 
115 
procedure TVTSListView.ColClick(Column: TListColumn);
116 
begin
117 
  if not Assigned(OnCompare) then Exit;
118 
  SortType := stNone;
119 
  if Column.Index <> FSortedColumn then
120 
  begin
121 
    FSortedColumn := Column.Index;
122 
    FDescending := False;
123 
  end
124 
  else
125 
  begin
126 
    FDescending := not FDescending;
127 
  end;
128 
  ShowArrowOfListViewColumn;
129 
  SortType := stText;
130 
  inherited;
131 
end;
132 
 
133 
procedure Register;
134 
begin
135 
  RegisterComponents('ViaThinkSoft', [TVTSListView]);
136 
end;
137 
 
138 
end.