1 {
2 Copyright (C) Alexey Torgashin, uvviewsoft.com
3 License: MPL 2.0 or LGPL
4 }
5
6 unit ATListbox;
7
8 {$ifdef FPC}
9 {$mode delphi}
10 {$endif}
11
12 interface
13
14 uses
15 Classes, SysUtils, Graphics, Controls, Forms,
16 {$ifdef FPC}
17 LMessages,
18 {$else}
19 Messages, Windows, System.UITypes,
20 {$endif}
21 StrUtils,
22 ATScrollBar,
23 ATFlatThemes,
24 ATCanvasPrimitives;
25
26 type
27 TATListboxDrawItemEvent = procedure(Sender: TObject; C: TCanvas; AIndex: integer; const ARect: TRect) of object;
28 TATListboxCalcWidth = function (Sender: TObject; C: TCanvas): integer of object;
29 TATListboxClickHeaderEvent = procedure(Sender: TObject; AColumn: integer) of object;
30
31 type
32 TATIntArray = array of integer;
33
34 type
35 TATListboxShowX = (
36 albsxNone,
37 albsxAllItems,
38 albsxHotItem
39 );
40
41 TATListboxScrollStyle = (
42 alssHide,
43 alssShow,
44 alssAuto
45 );
46
47 type
48 { TATListboxItemProp }
49
50 TATListboxItemProp = class
51 public
52 Tag: Int64;
53 Modified: boolean;
54 DataText: string;
55 constructor Create(const ATag: Int64; AModified: boolean; const ADataText: string);
56 end;
57
58 type
59 { TATListbox }
60
61 TATListbox = class(TCustomControl)
62 private
63 FTheme: PATFlatTheme;
64 FThemedScrollbar: boolean;
65 FThemedFont: boolean;
66 FScrollbar: TATScrollbar;
67 FScrollbarHorz: TATScrollbar;
68 FScrollStyleHorz: TATListboxScrollStyle;
69 FScrollStyleVert: TATListboxScrollStyle;
70 FOwnerDrawn: boolean;
71 FVirtualMode: boolean;
72 FVirtualItemCount: integer;
73 FItemIndex: integer;
74 FItemHeightPercents: integer;
75 FItemHeight: integer;
76 FItemHeightIsFixed: boolean;
77 FItemTop: integer;
78 FHeaderImages: TImageList;
79 FScrollHorz: integer;
80 FBitmap: Graphics.TBitmap;
81 FBorderVisible: boolean;
82 FCanGetFocus: boolean;
83 FList: TStringList;
84 FHotTrack: boolean;
85 FHotTrackIndex: integer;
86 FIndentLeft: integer;
87 FIndentTop: integer;
88 FIndentForX: integer;
89 FColumnSep: char;
90 FColumnSizes: TATIntArray;
91 FColumnWidths: TATIntArray;
92 FHeaderImageIndexes: TATIntArray;
93 FHeaderText: string;
94 FClientOriginY: integer;
95 FClientWidth: integer;
96 FClientHeight: integer;
97 FShowX: TATListboxShowX;
98 FMaxWidth: integer;
99 FOnDrawItem: TATListboxDrawItemEvent;
100 FOnCalcScrollWidth: TATListboxCalcWidth;
101 FOnClickX: TNotifyEvent;
102 FOnClickHeader: TATListboxClickHeaderEvent;
103 FOnChangeSel: TNotifyEvent;
104 FOnScroll: TNotifyEvent;
105 FShowOsBarVert: boolean;
106 FShowOsBarHorz: boolean;
107 procedure SetShowOsBarVert(AValue: boolean);
108 procedure SetShowOsBarHorz(AValue: boolean);
109 property ShowOsBarVert: boolean read FShowOsBarVert write SetShowOsBarVert;
110 property ShowOsBarHorz: boolean read FShowOsBarHorz write SetShowOsBarHorz;
ShowColumnsnull111 function ShowColumns: boolean;
112 procedure DoDefaultDrawItem(C: TCanvas; AIndex: integer; R: TRect);
113 procedure DoPaintTo(C: TCanvas);
114 procedure DoPaintX(C: TCanvas; const R: TRect; ACircle: boolean);
GetMaxWidthnull115 function GetMaxWidth(C: TCanvas): integer;
GetOnDrawScrollbarnull116 function GetOnDrawScrollbar: TATScrollbarDrawEvent;
ItemBottomnull117 function ItemBottom: integer;
118 procedure ScrollbarChange(Sender: TObject);
119 procedure ScrollbarHorzChange(Sender: TObject);
120 procedure SetCanBeFocused(AValue: boolean);
121 procedure SetItemHeightPercents(AValue: integer);
122 procedure SetOnDrawScrollbar(AValue: TATScrollbarDrawEvent);
123 procedure SetScrollHorz(AValue: integer);
124 procedure SetVirtualItemCount(AValue: integer);
125 procedure SetItemIndex(AValue: integer);
126 procedure SetItemTop(AValue: integer);
127 procedure SetItemHeight(AValue: integer);
128 procedure SetThemedScrollbar(AValue: boolean);
129 procedure UpdateClientSizes;
130 procedure UpdateColumnWidths;
131 procedure UpdateFromScrollbarMsg(const Msg: {$ifdef FPC}TLMScroll{$else}TWMVScroll{$endif});
132 procedure UpdateFromScrollbarHorzMsg(const Msg: {$ifdef FPC}TLMScroll{$else}TWMHScroll{$endif});
133 {$ifndef FPC}
134 procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;
135 procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
136 procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
137 {$endif}
138 procedure UpdateScrollbars(C: TCanvas);
GetVisibleItemsnull139 function GetVisibleItems: integer;
GetItemHeightDefaultnull140 function GetItemHeightDefault: integer;
GetColumnWidthnull141 function GetColumnWidth(AIndex: integer): integer;
142 procedure DoKeyDown(var Key: Word; Shift: TShiftState);
CurrentFontNamenull143 function CurrentFontName: string;
CurrentFontSizenull144 function CurrentFontSize: integer;
145 protected
146 procedure Paint; override;
147 procedure Click; override;
148 procedure Resize; override;
149 procedure DoExit; override;
150 {$ifdef FPC}
151 procedure LMVScroll(var Msg: TLMVScroll); message LM_VSCROLL;
152 procedure LMHScroll(var Msg: TLMHScroll); message LM_HSCROLL;
153 procedure MouseLeave; override;
154 {$else}
155 procedure WMSize(var Msg: TWMSize); message WM_SIZE;
156 procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;
157 procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
158 procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
159 procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
160 {$endif}
161 procedure KeyDown(var Key: Word; Shift: TShiftState); override;
162 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
163 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
DoMouseWheelnull164 function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
165 MousePos: TPoint): Boolean; override;
166 procedure ChangedSelection; virtual;
167 procedure Scrolled; virtual;
168 procedure DoContextPopup(MousePos: TPoint; var Handled: Boolean); override;
169 public
170 constructor Create(AOwner: TComponent); override;
171 destructor Destroy; override;
172 property Items: TStringList read FList;
173 property ItemIndex: integer read FItemIndex write SetItemIndex;
174 property ItemTop: integer read FItemTop write SetItemTop;
175 property ItemHeight: integer read FItemHeight write SetItemHeight;
176 property ItemHeightDefault: integer read GetItemHeightDefault;
ItemCountnull177 function ItemCount: integer;
IsIndexValidnull178 function IsIndexValid(AValue: integer): boolean;
179 property ClientWidth: integer read FClientWidth write FClientWidth;
180 property ClientHeight: integer read FClientHeight write FClientHeight;
181 property ScrollHorz: integer read FScrollHorz write SetScrollHorz;
182 property HotTrackIndex: integer read FHotTrackIndex;
183 property VirtualItemCount: integer read FVirtualItemCount write SetVirtualItemCount;
184 property VisibleItems: integer read GetVisibleItems;
GetItemIndexAtnull185 function GetItemIndexAt(Pnt: TPoint): integer;
GetColumnIndexAtnull186 function GetColumnIndexAt(Pnt: TPoint): integer;
187 property Theme: PATFlatTheme read FTheme write FTheme;
188 property ThemedScrollbar: boolean read FThemedScrollbar write SetThemedScrollbar;
189 property ThemedFont: boolean read FThemedFont write FThemedFont;
190 property Scrollbar: TATScrollbar read FScrollbar;
191 property ScrollbarHorz: TATScrollbar read FScrollbarHorz;
192 property ColumnSeparator: char read FColumnSep write FColumnSep;
193 property ColumnSizes: TATIntArray read FColumnSizes write FColumnSizes;
194 property ColumnWidth[AIndex: integer]: integer read GetColumnWidth;
195 property HeaderText: string read FHeaderText write FHeaderText;
196 property HeaderImages: TImageList read FHeaderImages write FHeaderImages;
197 property HeaderImageIndexes: TATIntArray read FHeaderImageIndexes write FHeaderImageIndexes;
198 {$ifdef FPC}
CanFocusnull199 function CanFocus: boolean; override;
CanSetFocusnull200 function CanSetFocus: boolean; override;
201 {$endif}
202 procedure Invalidate; override;
203 procedure UpdateItemHeight;
204 published
205 property Align;
206 property Anchors;
207 property BorderVisible: boolean read FBorderVisible write FBorderVisible default false;
208 {$ifdef FPC}
209 property BorderStyle;
210 property BorderSpacing;
211 {$endif}
212 property CanGetFocus: boolean read FCanGetFocus write SetCanBeFocused default false;
213 property DoubleBuffered stored false;
214 property Enabled;
215 property HotTrack: boolean read FHotTrack write FHotTrack default false;
216 property IndentLeft: integer read FIndentLeft write FIndentLeft default 4;
217 property IndentTop: integer read FIndentTop write FIndentTop default 2;
218 property ItemHeightPercents: integer read FItemHeightPercents write SetItemHeightPercents default 100;
219 property OwnerDrawn: boolean read FOwnerDrawn write FOwnerDrawn default false;
220 property ParentColor;
221 property ParentFont;
222 property ParentShowHint;
223 property PopupMenu;
224 property ScrollStyleHorz: TATListboxScrollStyle read FScrollStyleHorz write FScrollStyleHorz default alssAuto;
225 property ScrollStyleVert: TATListboxScrollStyle read FScrollStyleVert write FScrollStyleVert default alssShow;
226 property ShowHint;
227 property ShowXMark: TATListboxShowX read FShowX write FShowX default albsxNone;
228 property VirtualMode: boolean read FVirtualMode write FVirtualMode default true;
229 property Visible;
230 property OnClick;
231 property OnClickXMark: TNotifyEvent read FOnClickX write FOnClickX;
232 property OnClickHeader: TATListboxClickHeaderEvent read FOnClickHeader write FOnClickHeader;
233 property OnDblClick;
234 property OnContextPopup;
235 property OnChangedSel: TNotifyEvent read FOnChangeSel write FOnChangeSel;
236 property OnDrawItem: TATListboxDrawItemEvent read FOnDrawItem write FOnDrawItem;
237 property OnCalcScrollWidth: TATListboxCalcWidth read FOnCalcScrollWidth write FOnCalcScrollWidth;
238 property OnDrawScrollbar: TATScrollbarDrawEvent read GetOnDrawScrollbar write SetOnDrawScrollbar;
239 property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;
240 property OnKeyPress;
241 property OnKeyDown;
242 property OnKeyUp;
243 property OnResize;
244 property OnMouseDown;
245 property OnMouseUp;
246 property OnMouseMove;
247 property OnMouseEnter;
248 property OnMouseLeave;
249 property OnMouseWheel;
250 property OnMouseWheelDown;
251 property OnMouseWheelUp;
252 end;
253
254
255 implementation
256
257 uses
258 {$ifdef FPC}
259 Types,
260 InterfaceBase,
261 LCLType, LCLIntf,
262 {$endif}
263 Math;
264
265 type
266 TATStringSeparator = record
267 private
268 FSep: char;
269 FStr: string;
270 FPos: integer;
271 public
272 procedure Init(const AStr: string; ASep: char);
GetItemStrnull273 function GetItemStr(out AValue: string): boolean;
274 end;
275
276 procedure TATStringSeparator.Init(const AStr: string; ASep: char);
277 begin
278 FStr:= AStr;
279 FSep:= ASep;
280 FPos:= 1;
281 end;
282
GetItemStrnull283 function TATStringSeparator.GetItemStr(out AValue: string): boolean;
284 var
285 N: integer;
286 begin
287 if FPos>Length(FStr) then
288 begin
289 AValue:= '';
290 exit(false);
291 end;
292 N:= PosEx(FSep, FStr, FPos);
293 if N=0 then
294 N:= Length(FStr)+1;
295 AValue:= Copy(FStr, FPos, N-FPos);
296 FPos:= N+1;
297 Result:= true;
298 end;
299
IsDoubleBufferedNeedednull300 function IsDoubleBufferedNeeded: boolean;
301 begin
302 Result := true;
303 {$ifdef FPC}
304 Result:= WidgetSet.GetLCLCapability(lcCanDrawOutsideOnPaint) = LCL_CAPABILITY_YES;
305 {$endif}
306 end;
307
308 { TATListboxItemProp }
309
310 constructor TATListboxItemProp.Create(const ATag: Int64; AModified: boolean;
311 const ADataText: string);
312 begin
313 Tag:= ATag;
314 Modified:= AModified;
315 DataText:= ADataText;
316 end;
317
318 { TATListbox }
319
GetVisibleItemsnull320 function TATListbox.GetVisibleItems: integer;
321 begin
322 Result:= (ClientHeight-FClientOriginY) div FItemHeight;
323 end;
324
TATListbox.IsIndexValidnull325 function TATListbox.IsIndexValid(AValue: integer): boolean;
326 begin
327 Result:= (AValue>=0) and (AValue<ItemCount);
328 end;
329
GetItemHeightDefaultnull330 function TATListbox.GetItemHeightDefault: integer;
331 begin
332 Result:= FTheme^.DoScaleFont(CurrentFontSize) * 18 div 10 + 2;
333 Result:= Result * Screen.PixelsPerInch div 96;
334 end;
335
336 procedure TATListbox.UpdateItemHeight;
337 begin
338 if not FItemHeightIsFixed then
339 FItemHeight:= GetItemHeightDefault * FItemHeightPercents div 100;
340 end;
341
342 procedure TATListbox.ChangedSelection;
343 begin
344 if Assigned(FOnChangeSel) then
345 FOnChangeSel(Self);
346 end;
347
348 procedure TATListbox.Scrolled;
349 begin
350 if Assigned(FOnScroll) then
351 FOnScroll(Self);
352 end;
353
354 procedure TATListbox.DoContextPopup(MousePos: TPoint; var Handled: Boolean);
355 begin
356 //must select item under mouse cursor
357 ItemIndex:= GetItemIndexAt(MousePos);
358
359 inherited;
360 end;
361
TATListbox.GetMaxWidthnull362 function TATListbox.GetMaxWidth(C: TCanvas): integer;
363 var
364 i: integer;
365 begin
366 Result:= 0;
367
368 if FVirtualMode then
369 begin
370 if Assigned(FOnCalcScrollWidth) then
371 Result:= FOnCalcScrollWidth(Self, C);
372 end
373 else
374 if ShowColumns then
375 begin
376 for i:= 0 to High(FColumnWidths) do
377 Inc(Result, FColumnWidths[i]);
378 end
379 else
380 begin
381 for i:= 0 to ItemCount-1 do
382 Result:= Max(Result, C.TextWidth(Items[i]));
383 Inc(Result, FIndentLeft+2);
384 end;
385 end;
386
387 procedure TATListbox.UpdateScrollbars(C: TCanvas);
388 var
389 NeedVertBar, NeedHorzBar: boolean;
390 si: TScrollInfo;
391 begin
392 if FScrollStyleHorz in [alssShow, alssAuto] then
393 FMaxWidth:= GetMaxWidth(C)
394 else
395 FMaxWidth:= 10;
396
397 case FScrollStyleVert of
398 alssAuto:
399 NeedVertBar:= ItemCount*ItemHeight>Height; //not ClientHeight
400 alssShow:
401 NeedVertBar:= true;
402 alssHide:
403 NeedVertBar:= false;
404 end;
405
406 case FScrollStyleHorz of
407 alssAuto:
408 NeedHorzBar:= FMaxWidth>Width; //not ClientWidth
409 alssShow:
410 NeedHorzBar:= true;
411 alssHide:
412 NeedHorzBar:= false;
413 end;
414
415 FScrollbar.Visible:= FThemedScrollbar and NeedVertBar;
416 FScrollbarHorz.Visible:= FThemedScrollbar and NeedHorzBar;
417 ShowOsBarVert:= not FThemedScrollbar and NeedVertBar;
418 ShowOsBarHorz:= not FThemedScrollbar and NeedHorzBar;
419
420 if FThemedScrollbar then
421 begin
422 if FScrollbar.Visible then
423 begin
424 FScrollbar.Min:= 0;
425 FScrollbar.Max:= ItemCount;
426 FScrollbar.PageSize:= VisibleItems;
427 FScrollbar.Position:= ItemTop;
428 FScrollbar.Update;
429 end;
430
431 if FScrollbarHorz.Visible then
432 begin
433 if FScrollbar.Visible then
434 FScrollbarHorz.IndentCorner:= 100
435 else
436 FScrollbarHorz.IndentCorner:= 0;
437
438 FScrollbarHorz.Min:= 0;
439 FScrollbarHorz.Max:= FMaxWidth;
440 FScrollbarHorz.PageSize:= ClientWidth;
441 FScrollbarHorz.Position:= ScrollHorz;
442 FScrollbarHorz.Update;
443 end;
444 end
445 else
446 begin
447 FillChar(si{%H-}, SizeOf(si), 0);
448 si.cbSize:= SizeOf(si);
449 si.fMask:= SIF_ALL or SIF_DISABLENOSCROLL;
450 si.nMin:= 0;
451
452 if ShowOsBarVert then
453 begin
454 si.nMax:= ItemCount;
455 si.nPage:= GetVisibleItems;
456 si.nPos:= FItemTop;
457 SetScrollInfo(Handle, SB_VERT, si, True);
458 end;
459
460 if ShowOsBarHorz then
461 begin
462 si.nMax:= FMaxWidth;
463 si.nPage:= ClientWidth;
464 si.nPos:= ScrollHorz;
465 SetScrollInfo(Handle, SB_HORZ, si, True);
466 end;
467 end;
468 end;
469
ItemCountnull470 function TATListbox.ItemCount: integer;
471 begin
472 if FVirtualMode then
473 Result:= FVirtualItemCount
474 else
475 Result:= Items.Count;
476 end;
477
478
479 procedure TATListbox.DoPaintTo(C: TCanvas);
480 var
481 Index: integer;
482 bPaintX, bCircle: boolean;
483 R, RectX: TRect;
484 begin
485 C.Font.Name:= CurrentFontName;
486 C.Font.Size:= FTheme^.DoScaleFont(CurrentFontSize);
487
488 C.Brush.Color:= ColorToRGB(FTheme^.ColorBgListbox);
489 C.FillRect(Rect(0, 0, ClientWidth, ClientHeight));
490
491 if FHeaderText<>'' then
492 FClientOriginY:= FItemHeight
493 else
494 FClientOriginY:= 0;
495
496 FIndentForX:= 0;
497 if FShowX<>albsxNone then
498 Inc(FIndentForX, FTheme^.DoScale(FTheme^.XMarkWidth));
499
500 if FHeaderText<>'' then
501 begin
502 r.Top:= 0;
503 r.Bottom:= FItemHeight;
504 r.Left:= 0;
505 r.Right:= ClientWidth;
506
507 C.Font.Style:= [];
508 DoDefaultDrawItem(C, -1, r);
509
510 C.Pen.Color:= FTheme^.ColorSeparators;
511 C.MoveTo(0, FItemHeight-1);
512 C.LineTo(ClientWidth, FItemHeight-1);
513 end;
514
515 for Index:= FItemTop to ItemCount-1 do
516 begin
517 r.Top:= (Index-FItemTop)*FItemHeight + FClientOriginY;
518 r.Bottom:= r.Top+FItemHeight;
519 r.Left:= 0;
520 r.Right:= ClientWidth;
521 if r.Top>=ClientHeight then Break;
522
523 if FOwnerDrawn then
524 begin
525 if Assigned(FOnDrawItem) then
526 FOnDrawItem(Self, C, Index, r);
527 end
528 else
529 begin
530 DoDefaultDrawItem(C, Index, r);
531 end;
532
533 bCircle:=
534 (Index>=0) and (Index<FList.Count) and
535 (FList.Objects[Index] is TATListboxItemProp) and
536 TATListboxItemProp(FList.Objects[Index]).Modified;
537
538 case FShowX of
539 albsxNone:
540 bPaintX:= false;
541 albsxAllItems:
542 bPaintX:= true;
543 albsxHotItem:
544 bPaintX:= bCircle or (FHotTrack and (Index=FHotTrackIndex));
545 end;
546
547 if bPaintX then
548 begin
549 RectX:= Rect(r.Left, r.Top, r.Left+FIndentForX, r.Bottom);
550 DoPaintX(C, RectX, bCircle and (Index<>FHotTrackIndex));
551 end;
552 end;
553
554 if FBorderVisible then
555 begin
556 if Focused then
557 C.Brush.Color:= FTheme^.ColorListboxBorderFocused
558 else
559 C.Brush.Color:= FTheme^.ColorListboxBorderPassive;
560 C.FrameRect(Rect(0, 0, ClientWidth, ClientHeight));
561 end;
562 end;
563
564 procedure TATListbox.DoPaintX(C: TCanvas; const R: TRect; ACircle: boolean);
565 var
566 P: TPoint;
567 NColor: TColor;
568 begin
569 NColor:= FTheme^.ColorArrows;
570 if FHotTrack then
571 begin
572 P:= ScreenToClient(Mouse.CursorPos);
573 if PtInRect(R, P) then
574 NColor:= FTheme^.ColorArrowsOver;
575 end;
576
577 if ACircle then
578 CanvasPaintCircleMark(C, R, NColor,
579 FTheme^.DoScale(FTheme^.XMarkOffsetLeft),
580 FTheme^.DoScale(FTheme^.XMarkOffsetRight)
581 )
582 else
583 CanvasPaintXMark(C, R, NColor,
584 FTheme^.DoScale(FTheme^.XMarkOffsetLeft),
585 FTheme^.DoScale(FTheme^.XMarkOffsetRight),
586 FTheme^.DoScale(FTheme^.XMarkLineWidth)
587 );
588 end;
589
TATListbox.GetOnDrawScrollbarnull590 function TATListbox.GetOnDrawScrollbar: TATScrollbarDrawEvent;
591 begin
592 Result:= FScrollbar.OnOwnerDraw;
593 end;
594
GetColumnWidthnull595 function TATListbox.GetColumnWidth(AIndex: integer): integer;
596 begin
597 if (AIndex>=0) and (AIndex<Length(FColumnSizes)) then
598 Result:= FColumnWidths[AIndex]
599 else
600 Result:= 0;
601 end;
602
603 procedure TATListbox.UpdateColumnWidths;
604 var
605 NTotalWidth, NTotalWidthEx,
606 NAutoSized,
607 NSize, NFixedSize, i: integer;
608 begin
609 NTotalWidth:= ClientWidth;
610 NTotalWidthEx:= NTotalWidth;
611 NAutoSized:= 0;
612 NFixedSize:= 0;
613
614 SetLength(FColumnWidths, Length(FColumnSizes));
615
616 for i:= 0 to High(FColumnSizes) do
617 if FColumnSizes[i]>0 then
618 Dec(NTotalWidthEx, FColumnSizes[i]);
619 NTotalWidthEx:= Max(0, NTotalWidthEx);
620
621 //set width of fixed columns
622 for i:= 0 to High(FColumnSizes) do
623 begin
624 NSize:= FColumnSizes[i];
625
626 //auto-sized?
627 if NSize=0 then
628 Inc(NAutoSized)
629 else
630 //in percents?
631 if NSize<0 then
632 NSize:= NTotalWidthEx * -NSize div 100;
633
634 Inc(NFixedSize, NSize);
635 FColumnWidths[i]:= NSize;
636 end;
637
638 //set width of auto-sized columns
639 for i:= 0 to High(FColumnSizes) do
640 if FColumnSizes[i]=0 then
641 FColumnWidths[i]:= Max(0, NTotalWidth-NFixedSize) div NAutoSized;
642 end;
643
644 procedure TATListbox.SetShowOsBarVert(AValue: boolean);
645 begin
646 if FShowOsBarVert=AValue then Exit;
647 FShowOsBarVert:= AValue;
648 ShowScrollBar(Handle, SB_Vert, AValue);
649 end;
650
651 procedure TATListbox.SetShowOsBarHorz(AValue: boolean);
652 begin
653 if FShowOsBarHorz=AValue then Exit;
654 FShowOsBarHorz:= AValue;
655 ShowScrollBar(Handle, SB_Horz, AValue);
656 end;
657
TATListbox.ShowColumnsnull658 function TATListbox.ShowColumns: boolean;
659 begin
660 Result:= Length(FColumnSizes)>0;
661 end;
662
663 procedure TATListbox.DoDefaultDrawItem(C: TCanvas; AIndex: integer; R: TRect);
664 //AIndex=-1 means 'paint header'
665 var
666 Sep: TATStringSeparator;
667 SLine, SItem: string;
668 NIndentLeft, NIndentTop, NLineHeight, NIndentText,
669 NColOffset, NColWidth, NAllWidth, i: integer;
670 begin
671 if AIndex=-1 then
672 begin
673 C.Brush.Color:= ColorToRGB(FTheme^.ColorBgListboxHeader);
674 C.Font.Color:= ColorToRGB(FTheme^.ColorFontListboxHeader);
675 end
676 else
677 if AIndex=FItemIndex then
678 begin
679 C.Brush.Color:= ColorToRGB(FTheme^.ColorBgListboxSel);
680 C.Font.Color:= ColorToRGB(FTheme^.ColorFontListboxSel);
681 end
682 else
683 if FHotTrack and (AIndex=FHotTrackIndex) then
684 begin
685 C.Brush.Color:= ColorToRGB(FTheme^.ColorBgListboxHottrack);
686 C.Font.Color:= ColorToRGB(FTheme^.ColorFontListbox);
687 end
688 else
689 begin
690 C.Brush.Color:= ColorToRGB(FTheme^.ColorBgListbox);
691 C.Font.Color:= ColorToRGB(FTheme^.ColorFontListbox);
692 end;
693 C.FillRect(R);
694
695 if AIndex=-1 then
696 SLine:= FHeaderText
697 else
698 if (AIndex>=0) and (AIndex<FList.Count) then
699 SLine:= FList[AIndex]
700 else
701 SLine:= '('+IntToStr(AIndex)+')';
702
703 NIndentLeft:= FIndentLeft+FIndentForX;
704 NLineHeight:= C.TextHeight(SLine);
705 NIndentTop:= (FItemHeight-NLineHeight) div 2;
706
707 if not ShowColumns then
708 begin
709 C.TextOut(
710 R.Left+NIndentLeft-ScrollHorz,
711 R.Top+NIndentTop,
712 SLine);
713 end
714 else
715 begin
716 NAllWidth:= ClientWidth;
717 NColOffset:= R.Left+FIndentLeft-ScrollHorz;
718 C.Pen.Color:= Theme^.ColorSeparators;
719 Sep.Init(SLine, FColumnSep);
720
721 for i:= 0 to Length(FColumnSizes)-1 do
722 begin
723 NColWidth:= FColumnWidths[i];
724 Sep.GetItemStr(SItem);
725
726 NIndentText:= NColOffset+1+IfThen(i=0, NIndentLeft);
727
728 C.FillRect(
729 Rect(NColOffset,
730 R.Top,
731 NAllWidth,
732 R.Bottom)
733 );
734
735 if AIndex=-1 then
736 if Assigned(FHeaderImages) and
737 (i<=High(FHeaderImageIndexes)) and
738 (FHeaderImageIndexes[i]>=0) then
739 begin
740 FHeaderImages.Draw(C,
741 NIndentText,
742 R.Top+(R.Height-FHeaderImages.Height) div 2,
743 FHeaderImageIndexes[i]);
744 Inc(NIndentText, FHeaderImages.Width);
745 end;
746
747 C.TextOut(
748 NIndentText,
749 R.Top+NIndentTop,
750 SItem
751 );
752
753 Inc(NColOffset, NColWidth);
754 {$ifdef FPC}
755 C.Line(NColOffset-1, R.Top, NColOffset-1, R.Bottom);
756 {$else}
757 C.MoveTo (NColOffset-1, R.Top);
758 C.LineTo (NColOffset-1, R.Bottom);
759 {$endif}
760 end;
761 end;
762 end;
763
764 procedure TATListbox.UpdateClientSizes;
765 begin
766 FClientWidth:= Width;
767 if FScrollbar.Visible then
768 FClientWidth:= Max(0, FClientWidth-FScrollbar.Width);
769
770 FClientHeight:= Height;
771 if FScrollbarHorz.Visible then
772 FClientHeight:= Max(0, FClientHeight-FScrollbarHorz.Height);
773 end;
774
775 procedure TATListbox.Paint;
776 var
777 R: TRect;
778 C: TCanvas;
779 begin
780 inherited;
781
782 if DoubleBuffered then
783 C:= FBitmap.Canvas
784 else
785 C:= Canvas;
786
787 UpdateItemHeight;
788 UpdateScrollbars(C);
789 UpdateClientSizes;
790 UpdateColumnWidths;
791
792 R:= Rect(0, 0, ClientWidth, ClientHeight);
793 if DoubleBuffered then
794 begin
795 DoPaintTo(C);
796 Canvas.CopyRect(R, C, R);
797 end
798 else
799 DoPaintTo(C);
800 end;
801
802 procedure TATListbox.Click;
803 var
804 Pnt: TPoint;
805 NItem, NColumn: integer;
806 begin
807 if FCanGetFocus then
808 {$ifdef FPC}
809 LCLIntf.SetFocus(Handle);
810 {$else}
811 SetFocus;
812 {$endif}
813
814 Pnt:= ScreenToClient(Mouse.CursorPos);
815 NItem:= GetItemIndexAt(Pnt);
816
817 if NItem>=0 then
818 if FShowX<>albsxNone then
819 if Pnt.X<FIndentForX then
820 begin
821 if Assigned(FOnClickX) then
822 FOnClickX(Self);
823 exit;
824 end;
825
826 if NItem=-2 then
827 begin
828 if Assigned(FOnClickHeader) then
829 begin
830 NColumn:= GetColumnIndexAt(Pnt);
831 FOnClickHeader(Self, NColumn);
832 end;
833 exit;
834 end;
835
836 inherited; //OnClick must be after ItemIndex set
837 end;
838
839 procedure TATListbox.Resize;
840 begin
841 inherited;
842
843 //ATSynEdit has the same code
844 if DoubleBuffered then
845 if Assigned(FBitmap) then
846 BitmapResizeBySteps(FBitmap, Width, Height);
847
848 Invalidate;
849 end;
850
851 procedure TATListbox.DoExit;
852 begin
853 inherited;
854 if FBorderVisible then
855 Invalidate;
856 end;
857
TATListbox.GetColumnIndexAtnull858 function TATListbox.GetColumnIndexAt(Pnt: TPoint): integer;
859 var
860 NSize, i: integer;
861 begin
862 Result:= -1;
863 NSize:= 0;
864
865 if ShowXMark<>albsxNone then
866 begin
867 NSize:= FIndentForX;
868 if Pnt.X<FIndentForX then
869 begin
870 Result:= -2;
871 exit;
872 end;
873 end;
874
875 if not ShowColumns then
876 exit;
877
878 for i:= 0 to High(FColumnWidths) do
879 begin
880 if Pnt.X<NSize+FColumnWidths[i] then
881 begin
882 Result:= i;
883 exit;
884 end;
885 Inc(NSize, FColumnWidths[i]);
886 end;
887 end;
888
GetItemIndexAtnull889 function TATListbox.GetItemIndexAt(Pnt: TPoint): integer;
890 begin
891 if FHeaderText<>'' then
892 if (Pnt.Y>=0) and (Pnt.Y<FItemHeight) then
893 begin
894 Result:= -2;
895 exit
896 end;
897
898 Result:= -1;
899 if ItemCount=0 then exit;
900
901 Dec(Pnt.Y, FClientOriginY);
902
903 if (Pnt.X>=0) and (Pnt.X<ClientWidth) then
904 begin
905 Result:= Pnt.Y div FItemHeight + FItemTop;
906 if Result>=ItemCount then
907 Result:= -1;
908 end;
909 end;
910
TATListbox.ItemBottomnull911 function TATListbox.ItemBottom: integer;
912 begin
913 Result:= Min(ItemCount-1, FItemTop+GetVisibleItems-1);
914 end;
915
916 procedure TATListbox.ScrollbarChange(Sender: TObject);
917 begin
918 ItemTop:= FScrollbar.Position;
919 end;
920
921 procedure TATListbox.ScrollbarHorzChange(Sender: TObject);
922 begin
923 ScrollHorz:= FScrollbarHorz.Position;
924 end;
925
926 procedure TATListbox.SetCanBeFocused(AValue: boolean);
927 begin
928 if FCanGetFocus=AValue then Exit;
929 FCanGetFocus:= AValue;
930 {$ifdef FPC}
931 if AValue then
932 ControlStyle:= ControlStyle-[csNoFocus]
933 else
934 ControlStyle:= ControlStyle+[csNoFocus];
935 {$endif}
936 end;
937
938 procedure TATListbox.SetItemHeightPercents(AValue: integer);
939 begin
940 if FItemHeightPercents=AValue then Exit;
941 FItemHeightPercents:= AValue;
942 FItemHeightIsFixed:= false;
943 end;
944
945 procedure TATListbox.SetOnDrawScrollbar(AValue: TATScrollbarDrawEvent);
946 begin
947 FScrollbar.OnOwnerDraw:= AValue;
948 end;
949
950 procedure TATListbox.SetScrollHorz(AValue: integer);
951 begin
952 if FScrollHorz=AValue then Exit;
953 FScrollHorz:= AValue;
954 FScrollbarHorz.Position:= AValue;
955 Invalidate;
956 end;
957
958 procedure TATListbox.SetVirtualItemCount(AValue: integer);
959 begin
960 if FVirtualItemCount=AValue then Exit;
961 if AValue<0 then Exit;
962 FVirtualItemCount:= AValue;
963 Scrolled;
964 Invalidate;
965 end;
966
967 procedure TATListbox.SetItemIndex(AValue: integer);
968 begin
969 if FItemIndex=AValue then Exit;
970 if not IsIndexValid(AValue) then Exit;
971 FItemIndex:= AValue;
972
973 UpdateItemHeight; //ItemHeight may be not inited
974 UpdateClientSizes; //ClientHeight may be not inited
975
976 //scroll if needed
977 if FItemIndex=0 then
978 FItemTop:= 0
979 else
980 if FItemIndex<FItemTop then
981 FItemTop:= FItemIndex
982 else
983 if FItemIndex>ItemBottom then
984 FItemTop:= Max(0, FItemIndex-GetVisibleItems+1);
985
986 ChangedSelection;
987 Invalidate;
988 end;
989
990 procedure TATListbox.SetItemTop(AValue: integer);
991 begin
992 if FItemTop=AValue then Exit;
993 if not IsIndexValid(AValue) then Exit;
994 FItemTop:= Max(0, AValue);
995 Scrolled;
996 Invalidate;
997 end;
998
999 procedure TATListbox.SetItemHeight(AValue: integer);
1000 begin
1001 if AValue=FItemHeight then exit;
1002 FItemHeight:= AValue;
1003 FItemHeightIsFixed:= true;
1004 end;
1005
1006 procedure TATListbox.SetThemedScrollbar(AValue: boolean);
1007 begin
1008 if FThemedScrollbar=AValue then Exit;
1009 FThemedScrollbar:= AValue;
1010 Invalidate;
1011 end;
1012
1013
1014 constructor TATListbox.Create(AOwner: TComponent);
1015 begin
1016 inherited;
1017
1018 ControlStyle:= ControlStyle+[csOpaque] {$ifdef FPC}-[csTripleClicks]{$endif};
1019 DoubleBuffered:= IsDoubleBufferedNeeded;
1020 Width:= 180;
1021 Height:= 150;
1022 Font.Size:= 9;
1023
1024 CanGetFocus:= false;
1025 FBorderVisible:= false;
1026 FList:= TStringList.Create;
1027 FVirtualItemCount:= 0;
1028 FItemIndex:= 0;
1029 FItemHeightPercents:= 100;
1030 FItemHeight:= 17;
1031 FItemTop:= 0;
1032 FScrollStyleVert:= alssShow;
1033 FScrollStyleHorz:= alssAuto;
1034 FScrollHorz:= 0;
1035 FIndentLeft:= 4;
1036 FIndentTop:= 2;
1037 FOwnerDrawn:= false;
1038 FVirtualMode:= true;
1039 FHotTrack:= false;
1040 FColumnSep:= #9;
1041 SetLength(FColumnSizes, 0);
1042 SetLength(FColumnWidths, 0);
1043 FShowX:= albsxNone;
1044
1045 FBitmap:= Graphics.TBitmap.Create;
1046 BitmapResize(FBitmap, 800, 600);
1047
1048 FTheme:= @ATFlatTheme;
1049 FThemedScrollbar:= true;
1050 FThemedFont:= true;
1051
1052 FScrollbar:= TATScrollbar.Create(Self);
1053 FScrollbar.Parent:= Self;
1054 FScrollbar.Kind:= sbVertical;
1055 FScrollbar.Align:= alRight;
1056 FScrollbar.OnChange:= ScrollbarChange;
1057
1058 FScrollbarHorz:= TATScrollbar.Create(Self);
1059 FScrollbarHorz.Parent:= Self;
1060 FScrollbarHorz.Kind:= sbHorizontal;
1061 FScrollbarHorz.Align:= alBottom;
1062 FScrollbarHorz.IndentCorner:= 100;
1063 FScrollbarHorz.OnChange:= ScrollbarHorzChange;
1064 end;
1065
1066 destructor TATListbox.Destroy;
1067 begin
1068 FreeAndNil(FList);
1069 FreeAndNil(FBitmap);
1070 inherited;
1071 end;
1072
1073 procedure TATListbox.UpdateFromScrollbarMsg(const Msg: {$ifdef FPC}TLMScroll{$else}TWMVScroll{$endif});
1074 var
1075 NMax: integer;
1076 begin
1077 NMax:= Max(0, ItemCount-GetVisibleItems);
1078
1079 case Msg.ScrollCode of
1080 SB_TOP: FItemTop:= 0;
1081 SB_BOTTOM: FItemTop:= NMax;
1082
1083 SB_LINEUP: FItemTop:= Max(0, FItemTop-1);
1084 SB_LINEDOWN: FItemTop:= Min(NMax, FItemTop+1);
1085
1086 SB_PAGEUP: FItemTop:= Max(0, FItemTop-GetVisibleItems);
1087 SB_PAGEDOWN: FItemTop:= Min(NMax, FItemTop+GetVisibleItems);
1088
1089 SB_THUMBPOSITION,
1090 SB_THUMBTRACK: FItemTop:= Max(0, Msg.Pos);
1091 end;
1092 end;
1093
1094 procedure TATListbox.UpdateFromScrollbarHorzMsg(const Msg: {$ifdef FPC}TLMScroll{$else}TWMHScroll{$endif});
1095 var
1096 NMax: integer;
1097 begin
1098 NMax:= Max(0, FMaxWidth-ClientWidth);
1099
1100 case Msg.ScrollCode of
1101 SB_TOP: FScrollHorz:= 0;
1102 SB_BOTTOM: FScrollHorz:= NMax;
1103
1104 SB_LINEUP: FScrollHorz:= Max(0, FScrollHorz-1);
1105 SB_LINEDOWN: FScrollHorz:= Min(NMax, FScrollHorz+1);
1106
1107 SB_PAGEUP: FScrollHorz:= Max(0, FScrollHorz-ClientWidth);
1108 SB_PAGEDOWN: FScrollHorz:= Min(NMax, FScrollHorz+ClientWidth);
1109
1110 SB_THUMBPOSITION,
1111 SB_THUMBTRACK: FScrollHorz:= Max(0, Msg.Pos);
1112 end;
1113 end;
1114
1115 {$ifndef FPC}
1116 procedure TATListbox.CMMouseEnter(var msg: TMessage);
1117 begin
1118 inherited;
1119 Invalidate;
1120 end;
1121
1122 procedure TATListbox.CMMouseLeave(var msg: TMessage);
1123 begin
1124 inherited;
1125 Invalidate;
1126 end;
1127
1128 procedure TATListbox.WMEraseBkgnd(var Message: TMessage);
1129 begin
1130 Message.Result:= 1;
1131 if Assigned(FScrollbar) then
1132 if not MouseInClient then
1133 FScrollbar.Refresh;
1134 end;
1135 {$endif}
1136
1137 {$ifdef FPC}
1138 procedure TATListbox.LMVScroll(var Msg: TLMVScroll);
1139 begin
1140 UpdateFromScrollbarMsg(Msg);
1141 Invalidate;
1142 end;
1143
1144 procedure TATListbox.LMHScroll(var Msg: TLMHScroll);
1145 begin
1146 UpdateFromScrollbarHorzMsg(Msg);
1147 Invalidate;
1148 end;
1149 {$endif}
1150
1151 {$ifndef FPC}
1152 procedure TATListbox.WMSize(var Msg: TWMSize);
1153 begin
1154 inherited;
1155 if (csCreating in ControlState) then exit;
1156 Invalidate;
1157 end;
1158
1159 procedure TATListbox.WMVScroll(var Msg: TWMVScroll);
1160 begin
1161 UpdateFromScrollbarMsg(Msg);
1162 Invalidate;
1163 end;
1164
1165 procedure TATListbox.WMHScroll(var Msg: TWMHScroll);
1166 begin
1167 UpdateFromScrollbarHorzMsg(Msg);
1168 Invalidate;
1169 end;
1170
1171 procedure TATListbox.WMGetDlgCode(var Message: TWMGetDlgCode);
1172 begin
1173 inherited;
1174 Message.Result:= Message.Result or DLGC_WANTARROWS;
1175 end;
1176
1177 procedure TATListbox.WMKeyDown(var Message: TWMKeyDown);
1178 var
1179 ShiftState: TShiftState;
1180 begin
1181
1182 { Check the ShiftState, like delphi does while processing WMKeyDown }
1183 ShiftState := KeyDataToShiftState(Message.KeyData);
1184 DoKeyDown(Message.CharCode,ShiftState);
1185
1186 inherited;
1187
1188 end;
1189
1190 {$endif}
1191
1192 {$ifdef FPC}
CanFocusnull1193 function TATListbox.CanFocus: boolean;
1194 begin
1195 Result:= FCanGetFocus;
1196 end;
1197 {$endif}
1198
1199 {$ifdef FPC}
CanSetFocusnull1200 function TATListbox.CanSetFocus: boolean;
1201 begin
1202 Result:= FCanGetFocus;
1203 end;
1204 {$endif}
1205
TATListbox.CurrentFontNamenull1206 function TATListbox.CurrentFontName: string;
1207 begin
1208 if FThemedFont then
1209 Result:= FTheme^.FontName
1210 else
1211 Result:= Font.Name;
1212 end;
1213
TATListbox.CurrentFontSizenull1214 function TATListbox.CurrentFontSize: integer;
1215 begin
1216 if FThemedFont then
1217 Result:= FTheme^.FontSize
1218 else
1219 Result:= Font.Size;
1220 end;
1221
1222 procedure TATListbox.Invalidate;
1223 {$ifndef FPC}
1224 var
1225 R: TRect;
1226 {$endif}
1227 begin
1228 {$ifdef FPC}
1229 inherited Invalidate;
1230 {$else}
1231 // https://github.com/Alexey-T/ATFlatControls/issues/32
1232 if (Assigned(FScrollbar) and FScrollbar.Visible) or
1233 (Assigned(FScrollbarHorz) and FScrollbarHorz.Visible) then
1234 begin
1235 R:= Rect(0, 0, ClientWidth, ClientHeight);
1236 InvalidateRect(Handle, R, false);
1237 end
1238 else
1239 inherited Invalidate;
1240 {$endif}
1241 end;
1242
TATListbox.DoMouseWheelnull1243 function TATListbox.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
1244 MousePos: TPoint): Boolean;
1245 begin
1246 if not ThemedScrollbar then
1247 begin
1248 Result:= inherited;
1249 exit
1250 end;
1251
1252 Result:= true;
1253 if WheelDelta>0 then
1254 ItemTop:= Max(0, ItemTop-Mouse.WheelScrollLines)
1255 else
1256 ItemTop:= Max(0, Min(ItemCount-VisibleItems, ItemTop+Mouse.WheelScrollLines));
1257 end;
1258
1259 procedure TATListbox.DoKeyDown(var Key: Word; Shift: TShiftState);
1260 begin
1261 if (key=vk_up) then
1262 begin
1263 ItemIndex:= ItemIndex-1;
1264 key:= 0;
1265 Exit
1266 end;
1267 if (key=vk_down) then
1268 begin
1269 ItemIndex:= ItemIndex+1;
1270 key:= 0;
1271 Exit
1272 end;
1273
1274 if (key=vk_prior) then
1275 begin
1276 ItemIndex:= Max(0, ItemIndex-(VisibleItems-1));
1277 key:= 0;
1278 Exit
1279 end;
1280 if (key=vk_next) then
1281 begin
1282 ItemIndex:= Min(ItemCount-1, ItemIndex+(VisibleItems-1));
1283 key:= 0;
1284 Exit
1285 end;
1286
1287 if (key=vk_home) then
1288 begin
1289 ItemIndex:= 0;
1290 key:= 0;
1291 Exit
1292 end;
1293 if (key=vk_end) then
1294 begin
1295 ItemIndex:= ItemCount-1;
1296 key:= 0;
1297 Exit
1298 end;
1299
1300 if (key=vk_return) then
1301 begin
1302 DblClick;
1303 key:= 0;
1304 Exit
1305 end;
1306 end;
1307
1308 procedure TATListbox.KeyDown(var Key: Word; Shift: TShiftState);
1309 begin
1310 inherited;
1311 DoKeyDown(Key,Shift);
1312 end;
1313
1314 procedure TATListbox.MouseMove(Shift: TShiftState; X, Y: Integer);
1315 var
1316 NewIndex: integer;
1317 begin
1318 inherited;
1319
1320 if FHotTrack then
1321 begin
1322 NewIndex:= GetItemIndexAt(Point(X, Y));
1323 if (FHotTrackIndex<>NewIndex) or (FShowX<>albsxNone) then
1324 begin
1325 FHotTrackIndex:= NewIndex;
1326 Invalidate;
1327 end;
1328 end
1329 else
1330 FHotTrackIndex:= -1;
1331 end;
1332
1333 procedure TATListbox.MouseDown(Button: TMouseButton; Shift: TShiftState;
1334 X, Y: Integer);
1335 begin
1336 ItemIndex:= GetItemIndexAt(Point(X, Y));
1337 inherited;
1338 end;
1339
1340 {$ifdef fpc}
1341 procedure TATListbox.MouseLeave;
1342 begin
1343 inherited;
1344 if FHotTrack then
1345 begin
1346 FHotTrackIndex:= -1;
1347 Invalidate;
1348 end;
1349 end;
1350 {$endif}
1351
1352 initialization
1353
1354 end.
1355
1356