paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

callite: Refactor drawing routines to avoid flicker.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6950 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz 2019-05-26 13:05:38 +00:00
parent fe9d27d72c
commit 5e2c0d3122
5 changed files with 127 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
components/callite/demo2/testCalLite.lpi
View File

@ -1,15 +1,21 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<Version Value="12"/>
<PathDelim Value="\"/>
<General>
<Flags>
<CompatibilityMode Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="testCalLite"/>
<Scaled Value="True"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
</General>
<i18n>
<EnableI18N LFM="False"/>

1
components/callite/demo2/testCalLite.lpr
View File

@ -9,6 +9,7 @@ uses
begin
RequireDerivedFormResource := True;
Application.Scaled:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;

40
components/callite/demo2/umaintestcallite.lfm
View File

@ -1,10 +1,10 @@
object Form1: TForm1
Left = 700
Height = 845
Height = 746
Top = 122
Width = 851
Caption = 'Examples of the TCalendaLite component'
ClientHeight = 845
ClientHeight = 746
ClientWidth = 851
Color = clWindow
Font.CharSet = ANSI_CHARSET
@ -12,16 +12,16 @@ object Form1: TForm1
LCLVersion = '2.1.0.0'
object PSettings: TPanel
Left = 0
Height = 448
Height = 432
Top = 0
Width = 851
Align = alTop
ClientHeight = 448
ClientHeight = 432
ClientWidth = 851
TabOrder = 0
object cgOptions: TCheckGroup
Left = 24
Height = 392
Height = 384
Top = 40
Width = 160
AutoFill = True
@ -34,7 +34,7 @@ object Form1: TForm1
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 372
ClientHeight = 364
ClientWidth = 156
Items.Strings = (
'coBoldDayNames'
@ -118,7 +118,7 @@ object Form1: TForm1
object rgLanguage: TRadioGroup
Left = 200
Height = 216
Top = 216
Top = 208
Width = 160
AutoFill = True
Caption = 'Language to use'
@ -149,7 +149,7 @@ object Form1: TForm1
end
object rgStartingDOW: TRadioGroup
Left = 200
Height = 168
Height = 160
Top = 40
Width = 160
AutoFill = True
@ -161,7 +161,7 @@ object Form1: TForm1
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 148
ClientHeight = 140
ClientWidth = 156
Items.Strings = (
'Sunday'
@ -177,11 +177,11 @@ object Form1: TForm1
end
object GroupBox1: TGroupBox
Left = 376
Height = 392
Height = 384
Top = 40
Width = 160
Caption = 'Colors'
ClientHeight = 372
ClientHeight = 364
ClientWidth = 156
TabOrder = 6
object CbArrowBorder: TColorButton
@ -490,7 +490,7 @@ object Form1: TForm1
end
object SelDateListbox: TListBox
Left = 560
Height = 152
Height = 120
Top = 280
Width = 274
Columns = 3
@ -632,14 +632,14 @@ object Form1: TForm1
}
OnClick = sbResetButtonHeightClick
end
end
object Label1: TLabel
Left = 15
Height = 15
Top = 818
Width = 34
Caption = 'Label1'
ParentColor = False
object Label1: TLabel
Left = 562
Height = 15
Top = 408
Width = 34
Caption = 'Label1'
ParentColor = False
end
end
object FontDialog: TFontDialog
MinFontSize = 0

2
components/callite/demo2/umaintestcallite.pp
View File

@ -216,8 +216,6 @@ begin
copyCal.Languages := demoCal.Languages;
exit;
if demoCal.Languages = lgCustom then begin
demoCal.DayNames := 'S,M,T,W,T,F,S';
demoCal.MonthNames := 'Ja,Fe,Mr,Ap,Ma,Jn,Jl,Au,Sp,Oc,Nv,Dc';

111
components/callite/source/calendarlite.pas
View File

@ -41,7 +41,7 @@ unit CalendarLite;
interface
uses
Classes, SysUtils, LResources, LCLVersion,
Classes, SysUtils, LResources, LCLVersion, LMessages,
Forms, Controls, Graphics, Dialogs, Types, ExtCtrls, Menus;
{$if lcl_fullversion >= 1080000}
@ -129,6 +129,7 @@ type
TCalDrawer = class
private
FBoundsRect: TRect;
FBuffer: TBitmap;
FCanvas: TCanvas;
FCellSize: TSize;
FColPositions: TColArray;
@ -141,6 +142,7 @@ type
FTextStyle: TTextStyle;
procedure CalcSettings;
procedure DrawArrow(ARect: TRect; AHead: TArrowhead; ADirec: TArrowDirection);
procedure DrawBackground;
procedure DrawDayCells;
procedure DrawDayLabels;
procedure DrawTodayRow;
@ -158,9 +160,12 @@ type
procedure GotoYear(AYear: word);
procedure LeftClick(APoint: TPoint; Shift: TShiftState);
procedure RightClick;
procedure SetBoundsRect(ARect: TRect);
public
constructor Create(ACanvas: TCanvas);
constructor Create(AOwner: TCalendarLite);
procedure Draw;
property BoundsRect: TRect read FBoundsRect write SetBoundsRect;
property Buffer: TBitmap read FBuffer;
end;
@ -195,6 +200,7 @@ type
TCalendarLite = class(TCustomControl)
private
FBufferValid: Boolean;
FCalDrawer: TCalDrawer;
FColors: TCalColors;
FDate: TDateTime;
@ -270,8 +276,13 @@ type
procedure MouseLeave; override;
procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
function SelMode(Shift: TShiftState): TCalSelMode;
procedure SetBiDiMode(AValue: TBiDiMode); override;
procedure SetParentBiDiMode(AValue: Boolean); override;
procedure Paint; override;
procedure Resize; override;
procedure UpdateBiDiMode;
procedure UpdateBuffer;
procedure UseDayName(ADayOfWeek: TDayOfWeek; const AValue: String);
procedure UseDayNames(const AValue: String);
procedure UseDisplayTexts(const AValue: String);
@ -281,7 +292,6 @@ type
{ Hints }
procedure ShowHintWindow(APoint: TPoint; ADate: TDate);
procedure HideHintWindow;
public
constructor Create(anOwner: TComponent); override;
destructor Destroy; override;
@ -661,10 +671,12 @@ end;
{ TCalDrawer }
constructor TCalDrawer.Create(ACanvas: TCanvas);
constructor TCalDrawer.Create(AOwner: TCalendarLite);
begin
inherited Create;
FCanvas:= ACanvas;
FBuffer := TBitmap.Create;
FOwner := AOwner;
FCanvas := FBuffer.Canvas;
FTextStyle:= DefTextStyle;
end;
@ -735,6 +747,7 @@ begin
if not Assigned(FCanvas) then Exit;
DecodeDate(FOwner.FDate, FThisYear, FThisMonth, FThisDay);
CalcSettings;
DrawBackground;
DrawTopRow;
DrawDayLabels;
DrawTodayRow;
@ -813,6 +826,18 @@ begin
end;
end;
procedure TCalDrawer.DrawBackground;
begin
FBuffer.Canvas.Brush.Color := FOwner.Colors.BackgroundColor;
if (coShowBorder in FOwner.Options) then
begin
FCanvas.Pen.Color := FOwner.FColors.BorderColor;
FCanvas.Pen.Style := psSolid;
FCanvas.Rectangle(0, 0, FBuffer.Width, FBuffer.Height);
end else
FBuffer.Canvas.FillRect(0, 0, FBuffer.Width, FBuffer.Height);
end;
procedure TCalDrawer.DrawDayCells;
var
remDays: integer = 0;
@ -1337,6 +1362,14 @@ begin
end;
end;
procedure TCalDrawer.SetBoundsRect(ARect: TRect);
begin
if FBoundsRect = ARect then exit;
FBoundsRect := ARect;
FBuffer.SetSize(FBoundsRect.Width, FBoundsRect.Height);
Draw;
end;
{ TCalColors }
@ -1368,6 +1401,7 @@ procedure TCalColors.SetColor(AIndex: Integer; AValue: TColor);
begin
if FColors[AIndex] = AValue then exit;
FColors[AIndex] := AValue;
FOwner.FBufferValid := false;
FOwner.Invalidate;
end;
@ -1380,7 +1414,7 @@ begin
FFormatSettings := DefaultFormatSettings;
FSelDates := TCalDateList.Create;
FColors := TCalColors.Create(self);
Color := clWhite;
//Color := clWhite;
FStartingDayOfWeek:= dowSunday;
with GetControlClassDefaultSize do
SetInitialBounds(0, 0, cx, cy);
@ -1391,7 +1425,7 @@ begin
Constraints.MinHeight := ScaleX(DefMinHeight, DESIGNTIME_PPI);
Constraints.MinWidth := ScaleY(DefMinWidth, DESIGNTIME_PPI);
{$endif}
Canvas.Brush.Style := bsSolid;
//Canvas.Brush.Style := bsSolid;
TabStop := true;
SetDefaultDayNames;
// FCustomDayNames := GetDayNames;
@ -1400,8 +1434,7 @@ begin
SetDefaultDisplayTexts;
FCustomDisplayTexts := GetDisplayTexts;
FPopupMenu := TPopupMenu.Create(Self);
FCalDrawer := TCalDrawer.Create(Canvas);
FCalDrawer.FOwner:= Self;
FCalDrawer := TCalDrawer.Create(Self);
FDblClickTimer := TTimer.Create(self);
FDblClickTimer.Enabled := false;
FDblClickTimer.Interval := DBLCLICK_INTERVAL;
@ -1504,10 +1537,13 @@ begin
if MonthOf(FDate) <> oldMonth then
MonthChange;
FBufferValid := false;
{
with FCalDrawer do begin
FCanvas.Brush.Color := Colors.BackgroundColor;
FCanvas.FillRect(FBoundsRect);
end;
}
Invalidate;
end;
@ -1628,6 +1664,8 @@ begin
mbLeft : FCalDrawer.LeftClick(FClickPoint, FClickShift);
mbRight : FCalDrawer.RightClick;
end;
FBufferValid := false;
Invalidate;
end;
function TCalendarLite.IsSelected(ADate: TDate): Boolean;
@ -1737,9 +1775,10 @@ var
begin
if Assigned(FCalDrawer) then
begin
if ParentColor then
Colors.BackgroundColor := Parent.Color;
if not FBufferValid then
UpdateBuffer;
Canvas.Draw(0, 0, FCalDrawer.Buffer);
(*
if ParentFont then
begin
if (Parent.Font <> FCalDrawer.FCanvas.Font)
@ -1755,7 +1794,10 @@ begin
FCalDrawer.FTextStyle.RightToLeft := False;
end;
Canvas.Brush.Color:= Colors.BackGroundColor;
if ParentColor then
Canvas.Brush.Color := Parent.Color
else
Canvas.Brush.Color:= Colors.BackGroundColor;
Canvas.FillRect(ClientRect);
if (coShowBorder in FOptions) then
begin
@ -1769,11 +1811,25 @@ begin
if (coShowBorder in FOptions) then InflateRect(r, -1, -1);
FCalDrawer.FBoundsRect:= r;
FCalDrawer.Draw;
*)
end;
inherited Paint;
end;
procedure TCalendarLite.Resize;
begin
FBufferValid := false;
inherited;
end;
procedure TCalendarLite.UpdateBuffer;
begin
FCalDrawer.BoundsRect:= ClientRect;
FCalDrawer.Draw;
FBufferValid := true;
end;
procedure TCalendarLite.PopulateHolidayPopupMenu;
var
item: TMenuItem;
@ -1879,6 +1935,7 @@ procedure TCalendarLite.SetButtonHeight(const AValue: Integer);
begin
if FButtonHeight = AValue then exit;
FButtonHeight := AValue;
FBufferValid := false;
Invalidate;
end;
@ -1886,6 +1943,7 @@ procedure TCalendarLite.SetButtonWidth(const AValue: Integer);
begin
if FButtonWidth = AValue then exit;
FButtonWidth := AValue;
FBufferValid := false;
Invalidate;
end;
@ -1922,6 +1980,8 @@ begin
DateChange;
if MonthOf(FDate) <> oldMonth then
MonthChange;
FBufferValid := false;
FBufferValid := false;
Invalidate;
end;
@ -2078,6 +2138,12 @@ begin
Result := smNextSingle;
end;
procedure TCalendarLite.SetBiDiMode(AValue: TBiDiMode);
begin
inherited;
UpdateBiDiMode;
end;
procedure TCalendarLite.SetMultiSelect(AValue: Boolean);
begin
if AValue = FMultiSelect then
@ -2088,10 +2154,17 @@ begin
FPrevDate := FDate;
end;
procedure TCalendarLite.SetParentBiDiMode(AValue: Boolean);
begin
inherited;
UpdateBiDiMode;
end;
procedure TCalendarLite.SetStartingDayOfWeek(AValue: TDayOfWeek);
begin
if FStartingDayOfWeek = AValue then Exit;
FStartingDayOfWeek := AValue;
FBufferValid := false;
Invalidate;
end;
@ -2105,6 +2178,7 @@ begin
end;
if Length(FCalDrawer.FRowPositions) <> LastRow+1 then
SetLength(FCalDrawer.FRowPositions, LastRow+1);
FBufferValid := false;
Invalidate;
end;
@ -2112,6 +2186,7 @@ procedure TCalendarLite.SetWeekendDays(AValue: TDaysOfWeek);
begin
if FWeekendDays = AValue then Exit;
FWeekendDays := AValue;
FBufferValid := false;
Invalidate;
end;
@ -2125,6 +2200,16 @@ begin
InternalClick;
end;
procedure TCalendarLite.UpdateBiDiMode;
begin
case (BiDiMode = bdLeftToRight) of
False: if not FCalDrawer.FTextStyle.RightToLeft then
FCalDrawer.FTextStyle.RightToLeft := True;
True : if FCalDrawer.FTextStyle.RightToLeft then
FCalDrawer.FTextStyle.RightToLeft := False;
end;
end;
procedure TCalendarlite.UseDayName(ADayOfWeek: TDayOfWeek; const AValue: String);
var
p: Integer;