1 { /***************************************************************************
2 checklst.pas
3 ------------
4
5 Initial Revision : Thu Jun 19 CST 2003
6
7 ***************************************************************************/
8
9 *****************************************************************************
10 This file is part of the Lazarus Component Library (LCL)
11
12 See the file COPYING.modifiedLGPL.txt, included in this distribution,
13 for details about the license.
14 *****************************************************************************
15 }
16
17 unit CheckLst;
18
19 {$mode objfpc} {$H+}
20
21 interface
22
23 uses
24 Classes, SysUtils, Math, LCLProc, LCLType, GraphType, Graphics, LMessages,
25 LResources, Controls, StdCtrls, LCLIntf;
26
27
28 type
29 TCheckListClicked = procedure(Sender: TObject; Index: integer) of object;
30
31 { TCustomCheckListBox }
32
33 TCustomCheckListBox = class(TCustomListBox)
34 private
35 FAllowGrayed: Boolean;
36 FItemDataOffset: Integer;
37 FOnClickCheck : TNotifyEvent;
38 FOnItemClick: TCheckListClicked;
GetCheckednull39 function GetChecked(const AIndex: Integer): Boolean;
GetHeadernull40 function GetHeader(AIndex: Integer): Boolean;
GetItemEnablednull41 function GetItemEnabled(AIndex: Integer): Boolean;
GetStatenull42 function GetState(AIndex: Integer): TCheckBoxState;
43 procedure SetChecked(const AIndex: Integer; const AValue: Boolean);
44 procedure SendItemState(const AIndex: Integer; const AState: TCheckBoxState);
45 procedure SendItemEnabled(const AIndex: Integer; const AEnabled: Boolean);
46 procedure SendItemHeader(const AIndex: Integer; const AHeader: Boolean);
47 procedure DoChange(var Msg: TLMessage); message LM_CHANGED;
48 procedure SetHeader(AIndex: Integer; const AValue: Boolean);
49 procedure SetItemEnabled(AIndex: Integer; const AValue: Boolean);
50 procedure SetState(AIndex: Integer; const AValue: TCheckBoxState);
51 protected
52 class procedure WSRegisterClass; override;
53 procedure AssignItemDataToCache(const AIndex: Integer; const AData: Pointer); override;
54 procedure AssignCacheToItemData(const AIndex: Integer; const AData: Pointer); override;
55 procedure CreateParams(var Params: TCreateParams); override;
56 procedure DrawItem(AIndex: Integer; ARect: TRect; State: TOwnerDrawState); override;
GetCachedDataSizenull57 function GetCachedDataSize: Integer; override;
GetCheckWidthnull58 function GetCheckWidth: Integer;
59 procedure DefineProperties(Filer: TFiler); override;
60 procedure ReadData(Stream: TStream);
61 procedure WriteData(Stream: TStream);
62 procedure ClickCheck; virtual;
63 procedure ItemClick(const AIndex: Integer); virtual;
64 procedure KeyDown(var Key: Word; Shift: TShiftState); override;
65 procedure FontChanged(Sender: TObject); override;
66 public
67 constructor Create(AOwner: TComponent); override;
68 procedure MeasureItem(Index: Integer; var TheHeight: Integer); override;
69 procedure Toggle(AIndex: Integer);
70 procedure CheckAll(AState: TCheckBoxState; aAllowGrayed: Boolean = True; aAllowDisabled: Boolean = True);
71
72 property AllowGrayed: Boolean read FAllowGrayed write FAllowGrayed default False;
73 property Checked[AIndex: Integer]: Boolean read GetChecked write SetChecked;
74 property Header[AIndex: Integer]: Boolean read GetHeader write SetHeader;
75 property ItemEnabled[AIndex: Integer]: Boolean read GetItemEnabled write SetItemEnabled;
76 property State[AIndex: Integer]: TCheckBoxState read GetState write SetState;
77 property OnClickCheck: TNotifyEvent read FOnClickCheck write FOnClickCheck;
78 property OnItemClick: TCheckListClicked read FOnItemClick write FOnItemClick;
79 end;
80
81
82 { TCheckListBox }
83
84 TCheckListBox = class(TCustomCheckListBox)
85 published
86 property Align;
87 property AllowGrayed;
88 property Anchors;
89 property BidiMode;
90 property BorderSpacing;
91 property BorderStyle;
92 property Color;
93 property Columns;
94 property Constraints;
95 property DragCursor;
96 property DragMode;
97 property ExtendedSelect;
98 property Enabled;
99 property Font;
100 property IntegralHeight;
101 property Items;
102 property ItemHeight;
103 property ItemIndex;
104 property MultiSelect;
105 property OnChangeBounds;
106 property OnClick;
107 property OnClickCheck;
108 property OnContextPopup;
109 property OnDblClick;
110 property OnDrawItem;
111 property OnDragDrop;
112 property OnDragOver;
113 property OnEndDrag;
114 property OnEnter;
115 property OnExit;
116 property OnItemClick;
117 property OnKeyPress;
118 property OnKeyDown;
119 property OnKeyUp;
120 property OnMouseDown;
121 property OnMouseEnter;
122 property OnMouseLeave;
123 property OnMouseMove;
124 property OnMouseUp;
125 property OnMouseWheel;
126 property OnMouseWheelDown;
127 property OnMouseWheelUp;
128 property OnResize;
129 property OnSelectionChange;
130 property OnShowHint;
131 property OnStartDrag;
132 property OnUTF8KeyPress;
133 property ParentBidiMode;
134 property ParentColor;
135 property ParentFont;
136 property ParentShowHint;
137 property PopupMenu;
138 property ShowHint;
139 property Sorted;
140 property Style;
141 property TabOrder;
142 property TabStop;
143 property TopIndex;
144 property Visible;
145 end;
146
147
148 procedure Register;
149
150 implementation
151
152 uses
153 WSCheckLst;
154
155 procedure Register;
156 begin
157 RegisterComponents('Additional',[TCheckListBox]);
158 end;
159
160 type
161 PCachedItemData = ^TCachedItemData;
162 TCachedItemData = record
163 State: TCheckBoxState;
164 Disabled: Boolean;
165 Header: Boolean;
166 end;
167
168 { TCustomCheckListBox }
169
170 procedure TCustomCheckListBox.AssignCacheToItemData(const AIndex: Integer;
171 const AData: Pointer);
172 begin
173 inherited AssignCacheToItemData(AIndex, AData);
174 SendItemState(AIndex, PCachedItemData(AData + FItemDataOffset)^.State);
175 SendItemEnabled(AIndex, not PCachedItemData(AData + FItemDataOffset)^.Disabled);
176 SendItemHeader(AIndex, PCachedItemData(AData + FItemDataOffset)^.Header);
177 end;
178
179 procedure TCustomCheckListBox.CreateParams(var Params: TCreateParams);
180 begin
181 inherited CreateParams(Params);
182 Params.Style := (Params.Style and not LBS_OWNERDRAWVARIABLE) or LBS_OWNERDRAWFIXED;
183 end;
184
185 procedure TCustomCheckListBox.DrawItem(AIndex: Integer; ARect: TRect; State: TOwnerDrawState);
186 begin
187 if not Header[AIndex] then begin
188 if UseRightToLeftAlignment then
189 Dec(ARect.Right, GetCheckWidth)
190 else
191 Inc(ARect.Left, GetCheckWidth);
192 end;
193 inherited;
194 end;
195
196 procedure TCustomCheckListBox.AssignItemDataToCache(const AIndex: Integer;
197 const AData: Pointer);
198 begin
199 inherited AssignItemDataToCache(AIndex, AData);
200 PCachedItemData(AData + FItemDataOffset)^.State := State[AIndex];
201 PCachedItemData(AData + FItemDataOffset)^.Disabled := not ItemEnabled[AIndex];
202 PCachedItemData(AData + FItemDataOffset)^.Header := Header[AIndex];
203 end;
204
205 constructor TCustomCheckListBox.Create(AOwner: TComponent);
206 begin
207 inherited Create(AOwner);
208 FCompStyle := csCheckListBox;
209 FItemDataOffset := inherited GetCachedDataSize;
210 end;
211
212 procedure TCustomCheckListBox.MeasureItem(Index: Integer; var TheHeight: Integer);
213 begin
214 if (Style = lbStandard) then
215 TheHeight := Max(CalculateStandardItemHeight, GetSystemMetrics(SM_CYMENUCHECK) + 2)
216 else
217 inherited MeasureItem(Index, TheHeight);
218 end;
219
220 procedure TCustomCheckListBox.Toggle(AIndex: Integer);
221 const
222 NextStateMap: array[TCheckBoxState] of array[Boolean] of TCheckBoxState =
223 (
224 {cbUnchecked} (cbChecked, cbGrayed),
225 {cbChecked } (cbUnChecked, cbUnChecked),
226 {cbGrayed } (cbChecked, cbChecked)
227 );
228 begin
229 State[AIndex] := NextStateMap[State[AIndex]][AllowGrayed];
230 end;
231
232 procedure TCustomCheckListBox.CheckAll(AState: TCheckBoxState;
233 aAllowGrayed: Boolean; aAllowDisabled: Boolean);
234 var
235 i: Integer;
236 begin
237 for i := 0 to Items.Count - 1 do begin
238 if (aAllowGrayed or (State[i] <> cbGrayed)) and (aAllowDisabled or ItemEnabled[i]) then
239 State[i] := AState;
240 end;
241 end;
242
243 procedure TCustomCheckListBox.DoChange(var Msg: TLMessage);
244 begin
245 //DebugLn(['TCustomCheckListBox.DoChange ',DbgSName(Self),' ',Msg.WParam]);
246 ClickCheck;
247 ItemClick(Msg.WParam);
248 end;
249
GetCachedDataSizenull250 function TCustomCheckListBox.GetCachedDataSize: Integer;
251 begin
252 FItemDataOffset := inherited GetCachedDataSize;
253 Result := FItemDataOffset + SizeOf(TCachedItemData);
254 end;
255
TCustomCheckListBox.GetCheckednull256 function TCustomCheckListBox.GetChecked(const AIndex: Integer): Boolean;
257 begin
258 Result := State[AIndex] <> cbUnchecked;
259 end;
260
GetCheckWidthnull261 function TCustomCheckListBox.GetCheckWidth: Integer;
262 begin
263 if HandleAllocated then
264 Result := TWSCustomCheckListBoxClass(WidgetSetClass).GetCheckWidth(Self)
265 else
266 Result := 0;
267 end;
268
GetItemEnablednull269 function TCustomCheckListBox.GetItemEnabled(AIndex: Integer): Boolean;
270 begin
271 CheckIndex(AIndex);
272
273 if HandleAllocated then
274 Result := TWSCustomCheckListBoxClass(WidgetSetClass).GetItemEnabled(Self, AIndex)
275 else
276 Result := not PCachedItemData(GetCachedData(AIndex) + FItemDataOffset)^.Disabled;
277 end;
278
GetStatenull279 function TCustomCheckListBox.GetState(AIndex: Integer): TCheckBoxState;
280 begin
281 CheckIndex(AIndex);
282
283 if HandleAllocated then
284 Result := TWSCustomCheckListBoxClass(WidgetSetClass).GetState(Self, AIndex)
285 else
286 Result := PCachedItemData(GetCachedData(AIndex) + FItemDataOffset)^.State;
287 end;
288
TCustomCheckListBox.GetHeadernull289 function TCustomCheckListBox.GetHeader(AIndex: Integer): Boolean;
290 begin
291 CheckIndex(AIndex);
292
293 if HandleAllocated then
294 Result := TWSCustomCheckListBoxClass(WidgetSetClass).GetHeader(Self, AIndex)
295 else
296 Result := PCachedItemData(GetCachedData(AIndex) + FItemDataOffset)^.Header;
297 end;
298
299
300 procedure TCustomCheckListBox.KeyDown(var Key: Word; Shift: TShiftState);
301 var
302 Index: Integer;
303 begin
304 if (Key = VK_SPACE) and (Shift=[]) then
305 begin
306 //Delphi (7) sets ItemIndex to 0 in this case and fires OnClick
307 if (ItemIndex < 0) and (Items.Count > 0) then
308 begin
309 ItemIndex := 0;
310 Click;
311 end;
312 if (ItemIndex >= 0) and ItemEnabled[ItemIndex] then
313 begin
314 Index := ItemIndex;
315 Checked[Index] := not Checked[Index];
316 ClickCheck;
317 //ToDo: does Delphi fire OnItemClick and in the same order?
318 ItemClick(Index);
319 Key := VK_UNKNOWN;
320 end;
321 end else
322 inherited KeyDown(Key,Shift);
323 end;
324
325 procedure TCustomCheckListBox.SetItemEnabled(AIndex: Integer;
326 const AValue: Boolean);
327 begin
328 CheckIndex(AIndex);
329 if HandleAllocated then
330 SendItemEnabled(AIndex, AValue)
331 else
332 PCachedItemData(GetCachedData(AIndex) + FItemDataOffset)^.Disabled := not AValue;
333 end;
334
335 procedure TCustomCheckListBox.SetState(AIndex: Integer;
336 const AValue: TCheckBoxState);
337 begin
338 CheckIndex(AIndex);
339
340 if GetState(AIndex) = AValue then
341 Exit;
342
343 if HandleAllocated then
344 SendItemState(AIndex, AValue)
345 else
346 PCachedItemData(GetCachedData(AIndex) + FItemDataOffset)^.State := AValue;
347 end;
348
349 procedure TCustomCheckListBox.SetHeader(AIndex: Integer;
350 const AValue: Boolean);
351 begin
352 CheckIndex(AIndex);
353 if HandleAllocated then
354 SendItemHeader(AIndex, AValue)
355 else
356 PCachedItemData(GetCachedData(AIndex) + FItemDataOffset)^.Header := AValue;
357 end;
358
359 class procedure TCustomCheckListBox.WSRegisterClass;
360 begin
361 inherited WSRegisterClass;
362 RegisterCustomCheckListBox;
363 end;
364
365 procedure TCustomCheckListBox.SendItemState(const AIndex: Integer;
366 const AState: TCheckBoxState);
367 begin
368 if HandleAllocated then
369 TWSCustomCheckListBoxClass(WidgetSetClass).SetState(Self, AIndex, AState);
370 end;
371
372 procedure TCustomCheckListBox.SendItemEnabled(const AIndex: Integer;
373 const AEnabled: Boolean);
374 begin
375 if HandleAllocated then
376 TWSCustomCheckListBoxClass(WidgetSetClass).SetItemEnabled(Self, AIndex, AEnabled);
377 end;
378
379 procedure TCustomCheckListBox.SendItemHeader(const AIndex: Integer;
380 const AHeader: Boolean);
381 begin
382 if HandleAllocated then
383 TWSCustomCheckListBoxClass(WidgetSetClass).SetHeader(Self, AIndex, AHeader);
384 end;
385
386 procedure TCustomCheckListBox.SetChecked(const AIndex: Integer;
387 const AValue: Boolean);
388 begin
389 if AValue then
390 SetState(AIndex, cbChecked)
391 else
392 SetState(AIndex, cbUnChecked);
393 end;
394
395 procedure TCustomCheckListBox.ClickCheck;
396 begin
397 if Assigned(FOnClickCheck) then FOnClickCheck(Self);
398 end;
399
400 procedure TCustomCheckListBox.ItemClick(const AIndex: Integer);
401 begin
402 if Assigned(OnItemClick) then OnItemClick(Self, AIndex);
403 end;
404
405 procedure TCustomCheckListBox.FontChanged(Sender: TObject);
406 begin
407 inherited FontChanged(Sender);
408 if ([csLoading, csDestroying] * ComponentState = []) and (Style = lbStandard) then
409 ItemHeight := CalculateStandardItemHeight;
410 end;
411
412 procedure TCustomCheckListBox.DefineProperties(Filer: TFiler);
413 begin
414 inherited DefineProperties(Filer);
415 Filer.DefineBinaryProperty('Data', @ReadData, @WriteData, Items.Count > 0);
416 end;
417
418 procedure TCustomCheckListBox.ReadData(Stream: TStream);
419 var
420 ChecksCount: integer;
421 Checks: string;
422 i: Integer;
423 begin
424 ChecksCount := ReadLRSInteger(Stream);
425 if ChecksCount > 0 then
426 begin
427 SetLength(Checks, ChecksCount);
428 Stream.ReadBuffer(Checks[1], ChecksCount);
429 for i := 0 to ChecksCount-1 do
430 State[i] := TCheckBoxState(ord(Checks[i + 1]));
431 end;
432 end;
433
434 procedure TCustomCheckListBox.WriteData(Stream: TStream);
435 var
436 ChecksCount: integer;
437 Checks: string;
438 i: Integer;
439 begin
440 ChecksCount := Items.Count;
441 WriteLRSInteger(Stream, ChecksCount);
442 if ChecksCount > 0 then
443 begin
444 SetLength(Checks, ChecksCount);
445 for i := 0 to ChecksCount - 1 do
446 Checks[i+1] := chr(Ord(State[i]));
447 Stream.WriteBuffer(Checks[1], ChecksCount);
448 end;
449 end;
450
451 end.
452