diff --git a/components/callite/demo2/testCalLite.lpi b/components/callite/demo2/testCalLite.lpi index 4057bf780..5eb7e04e1 100644 --- a/components/callite/demo2/testCalLite.lpi +++ b/components/callite/demo2/testCalLite.lpi @@ -1,15 +1,21 @@ - + + + + - + <Scaled Value="True"/> <UseAppBundle Value="False"/> <ResourceType Value="res"/> <UseXPManifest Value="True"/> + <XPManifest> + <DpiAware Value="True"/> + </XPManifest> </General> <i18n> <EnableI18N LFM="False"/> diff --git a/components/callite/demo2/testCalLite.lpr b/components/callite/demo2/testCalLite.lpr index ec04b3575..52ca81da4 100644 --- a/components/callite/demo2/testCalLite.lpr +++ b/components/callite/demo2/testCalLite.lpr @@ -9,6 +9,7 @@ uses begin RequireDerivedFormResource := True; + Application.Scaled:=True; Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; diff --git a/components/callite/demo2/umaintestcallite.lfm b/components/callite/demo2/umaintestcallite.lfm index 2791fdd82..08c910d49 100644 --- a/components/callite/demo2/umaintestcallite.lfm +++ b/components/callite/demo2/umaintestcallite.lfm @@ -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 diff --git a/components/callite/demo2/umaintestcallite.pp b/components/callite/demo2/umaintestcallite.pp index 6a1a4ca52..a34faa7f5 100644 --- a/components/callite/demo2/umaintestcallite.pp +++ b/components/callite/demo2/umaintestcallite.pp @@ -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'; diff --git a/components/callite/source/calendarlite.pas b/components/callite/source/calendarlite.pas index 5154fd608..f19f6e25d 100644 --- a/components/callite/source/calendarlite.pas +++ b/components/callite/source/calendarlite.pas @@ -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;