{*********************************************************} {* VPMONTHVIEW.PAS 1.03 *} {*********************************************************} {* ***** BEGIN LICENSE BLOCK ***** *} {* Version: MPL 1.1 *} {* *} {* The contents of this file are subject to the Mozilla Public License *} {* Version 1.1 (the "License"); you may not use this file except in *} {* compliance with the License. You may obtain a copy of the License at *} {* http://www.mozilla.org/MPL/ *} {* *} {* Software distributed under the License is distributed on an "AS IS" basis, *} {* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} {* for the specific language governing rights and limitations under the *} {* License. *} {* *} {* The Original Code is TurboPower Visual PlanIt *} {* *} {* The Initial Developer of the Original Code is TurboPower Software *} {* *} {* Portions created by TurboPower Software Inc. are Copyright (C) 2002 *} {* TurboPower Software Inc. All Rights Reserved. *} {* *} {* Contributor(s): *} {* *} {* ***** END LICENSE BLOCK ***** *} {$IF FPC_FullVersion >= 30200} {$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined} {$IFEND} {$I vp.inc} unit VpMonthView; interface uses {$IFDEF LCL} LMessages, LCLProc, LCLType, LCLIntf, FileUtil, {$ELSE} Windows, Messages, {$ENDIF} Classes, Graphics, Controls, ComCtrls, ExtCtrls, Buttons, Forms, Menus, VpConst, VpBase, VpBaseDS, VpMisc, VpData, VpSR; type TVpMonthdayRec = packed record Rec : TRect; Date : TDateTime; OffDay : Boolean; end; type TVpMonthdayArray = array of TVpMonthdayRec; { Forward Declarations } TVpMonthView = class; TVpMVDayNameStyle = (dsLong, dsShort, dsLetter); TVpOnEventClick = procedure(Sender: TObject; Event: TVpEvent) of object; TVpMonthViewAttr = class(TPersistent) private FMonthView: TVpMonthView; FColor: TColor; FFont: TVpFont; procedure SetColor(AValue: TColor); procedure SetFont(AValue: TVpFont); protected procedure UpdateMonthView; public constructor Create(AOwner: TVpMonthView); destructor Destroy; override; property MonthView: TVpMonthView read FMonthVIew; published property Font: TVpFont read FFont write SetFont; property Color: TColor read FColor write SetColor default DEFAULT_HEADERCOLOR; end; TVpMvHolidayAttr = class(TVpMonthViewAttr) public constructor Create(AOwner: TVpMonthView); published property Color default HOLIDAY_COLOR; end; TVpMvWeekendAttr = class(TVpMonthViewAttr) public constructor Create(AOwner: TVpMonthView); published property Color default WEEKEND_COLOR; end; (* TVpMvHeadAttr = class(TPersistent) protected{ private } FOwner: TVpMonthView; FColor: TColor; FFont: TVpFont; procedure SetColor(const Value: TColor); procedure SetFont(Value: TVpFont); public constructor Create(AOwner: TVpMonthView); destructor Destroy; override; property Owner: TVpMonthView read FOwner; published property Font: TVpFont read FFont write SetFont; property Color: TColor read FColor write SetColor; end; TVpDayHeadAttr = class(TPersistent) protected{private} FMonthView: TVpMonthView; FFont: TVpFont; FColor: TColor; procedure SetColor(Value: TColor); procedure SetFont(Value: TVpFont); public constructor Create(AOwner: TVpMonthView); destructor Destroy; override; property MonthView: TVpMonthView read FMonthView; published property Color: TColor read FColor write SetColor; property Font: TVpFont read FFont write SetFont; end; *) TVpMvTodayAttr = class(TVpMonthViewAttr) private FBorderPen: TPen; procedure SetBorderPen(Value: TPen); protected public constructor Create(AOwner: TVpMonthView); destructor Destroy; override; published property BorderPen: TPen read FBorderPen write SetBorderPen; end; { TVpMonthView } TVpMonthView = class(TVpLinkableControl) private FAllowDragAndDrop: Boolean; FApplyCategoryInfos: Boolean; FColor: TColor; // FColumnWidth: Integer; FComponentHint: TTranslateString; FDate: TDateTime; FDateLabelFormat: string; FDayHeadAttr: TVpMonthViewAttr; FDayNameStyle: TVpMVDayNameStyle; FDayNumberFont: TVpFont; FDaysMargin: Integer; FDefaultPopup: TPopupMenu; FDragDropTransparent: Boolean; FDrawingStyle: TVpDrawingStyle; FEventDayStyle: TFontStyles; FEventFont: TVpFont; FExternalPopup: TPopupMenu; FHeadAttr: TVpMonthViewAttr; FHintMode: TVpHintMode; FHolidayAttr: TVpMvHolidayAttr; FKBNavigate: Boolean; FMonthMargin: Integer; FLineColor: TColor; FMouseDate: TDateTime; FOffDayColor: TColor; FOffDayFontColor: TColor; FRightClickChangeDate: Boolean; FSelectedDayColor: TColor; FShowEvents: Boolean; FShowEventTime: Boolean; FTimeFormat: TVpTimeFormat; FTodayAttr: TVpMvTodayAttr; FWeekendAttr: TVpMvWeekendAttr; FWeekStartsOn: TVpDayType; // Internal variables mvActiveEvent: TVpEvent; mvActiveEventRec: TRect; mvDragging: Boolean; mvLoaded: Boolean; mvMouseDown: Boolean; mvMouseDownPoint: TPoint; // Event variables FOnAddEvent: TVpOnAddNewEvent; FOnEventClick: TVpOnEventClick; FOnEventDblClick: TVpOnEventClick; FOnHoliday: TVpHolidayEvent; FOnModifyEvent: TVpOnModifyEvent; FOwnerDrawCells: TVpOwnerDrawDayEvent; FOwnerEditEvent: TVpEditEvent; { property methods } function IsStoredDateLabelFormat: Boolean; procedure SetApplyCategoryInfos(AValue: Boolean); procedure SetColor(Value: TColor); reintroduce; procedure SetDate(Value: TDateTime); procedure SetDateLabelFormat(Value: string); procedure SetDayNameStyle(Value: TVpMVDayNameStyle); procedure SetDayNumberFont(Value: TVpFont); procedure SetDaysMargin(Value: Integer); procedure SetDrawingStyle(Value: TVpDrawingStyle); procedure SetEventDayStyle(Value: TFontStyles); procedure SetEventFont(Value: TVpFont); procedure SetLineColor(Value: TColor); procedure SetMonthMargin(Value: Integer); procedure SetOffDayColor(Value: TColor); procedure SetOffDayFontColor(Value: TColor); procedure SetPopupMenu(AValue: TPopupMenu); procedure SetRightClickChangeDate(const v: Boolean); procedure SetSelectedDayColor(Value: TColor); procedure SetShowEvents(Value: Boolean); procedure SetShowEventTime(Value: Boolean); procedure SetTimeFormat(Value: TVpTimeFormat); procedure SetWeekStartsOn(Value: TVpDayType); protected{ private } // Needed by the drawer FPrevYearBtn: TSpeedButton; FPrevMonthBtn: TSpeedButton; FNextMonthBtn: TSpeedButton; FNextYearBtn: TSpeedButton; mvHeaderHeight: Integer; mvMonthHeadHeight: Integer; mvDayHeadHeight: Integer; mvEventArray: TVpEventArray; mvMonthDayArray: TVpMonthdayArray; { internal methods } function GetDateAtCoord(APoint: TPoint): TDateTime; procedure mvPopulate; procedure mvSpawnEventEditDialog(IsNewEvent: Boolean); procedure mvSetDateByCoord(APoint: TPoint); procedure mvHookUp; procedure mvPenChanged(Sender: TObject); function SelectEventAtCoord(Point: TPoint): Boolean; procedure SpinButtonClick(Sender: TObject); { inherited methods } procedure CreateParams(var Params: TCreateParams); override; procedure CreateWnd; override; procedure Loaded; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseEnter; override; procedure MouseLeave; override; procedure MouseMove(Shift: TShiftState; X,Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure Paint; override; { drag and drop } procedure DoEndDrag(Target: TObject; X, Y: Integer); override; procedure DoStartDrag(var DragObject: TDragObject); override; procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); override; { message handlers } {$IFNDEF LCL} procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN; procedure WMLButtonDblClick(var Msg: TWMLButtonDblClk);message WM_LBUTTONDBLCLK; procedure WMSize(var Msg: TWMSize); message WM_SIZE; procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; procedure WMRButtonDown(var Msg: TWMRButtonDown); message WM_RBUTTONDOWN; procedure CMWantSpecialKey(var Msg: TCMWantSpecialKey); message CM_WANTSPECIALKEY; {$ELSE} procedure WMLButtonDown(var Msg: TLMLButtonDown); message LM_LBUTTONDOWN; procedure WMLButtonDblClick(var Msg: TLMLButtonDblClk); message LM_LBUTTONDBLCLK; procedure WMSize(var Msg: TLMSize); message LM_SIZE; procedure WMSetFocus(var Msg: TLMSetFocus); message LM_SETFOCUS; procedure WMRButtonDown(var Msg: TLMRButtonDown); message LM_RBUTTONDOWN; {$ENDIF} { Hints } procedure ShowHintWindow(APoint: TPoint; ADate: TDateTime); procedure HideHintWindow; procedure SetHint(const AValue: TTranslateString); override; { Popup menu } function GetPopupMenu: TPopupMenu; override; procedure InitializeDefaultPopup; procedure PopupToday(Sender: TObject); procedure PopupNextMonth(Sender: TObject); procedure PopupPrevMonth(Sender: TObject); procedure PopupNextYear(Sender: TObject); procedure PopupPrevYear(Sender: TObject); procedure PopupCustomDate(Sender: TObject); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function BuildEventString(AEvent: TVpEvent; AShowEventTime, AStartTimeOnly: Boolean): String; procedure DragDrop(Source: TObject; X, Y: Integer); override; procedure LoadLanguage; procedure Invalidate; override; function IsHoliday(ADate: TDate; out AHolidayName: String): Boolean; procedure LinkHandler(Sender: TComponent; NotificationType: TVpNotificationType; const Value: Variant); override; function GetControlType: TVpItemType; override; procedure PaintToCanvas(ACanvas: TCanvas; ARect: TRect; Angle: TVpRotationAngle; ADate: TDateTime); procedure RenderToCanvas(RenderCanvas: TCanvas; RenderIn: TRect; Angle: TVpRotationAngle; Scale: Extended; RenderDate: TDateTime; StartLine, StopLine: Integer; UseGran: TVpGranularity; DisplayOnly: Boolean); override; { LCL scaling } {$IF VP_LCL_SCALING <> 0} procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double); override; {$IFEND} {$IF VP_LCL_SCALING = 2} procedure FixDesignFontsPPI(const ADesignTimePPI: Integer); override; procedure ScaleFontsPPI(const AToPPI: Integer; const AProportion: Double); override; {$ELSEIF VP_LCL_SCALING = 1} procedure ScaleFontsPPI(const AProportion: Double); override; {$ENDIF} property Date: TDateTime read FDate write SetDate; published { inherited properties } property Align; property Anchors; {$IFDEF LCL} property BorderSpacing; {$ENDIF} property PopupMenu: TPopupMenu read GetPopupMenu write SetPopupMenu; property TabStop default true; property TabOrder; property AllowDragAndDrop: Boolean read FAllowDragAndDrop write FAllowDragAndDrop default false; property ApplyCategoryInfos: Boolean read FApplyCategoryInfos write SetApplyCategoryInfos default false; property Color: TColor read FColor write SetColor default DEFAULT_COLOR; property DateLabelFormat: string read FDateLabelFormat write SetDateLabelFormat stored IsStoredDateLabelFormat; property DayHeadAttributes: TVpMonthviewAttr read FDayHeadAttr write FDayHeadAttr; property DayNameStyle: TVpMVDayNameStyle read FDayNameStyle write SetDayNameStyle default dsShort; property DayNumberFont: TVpFont read FDayNumberFont write SetDayNumberFont; property DaysMargin: Integer read FDaysMargin write SetDaysMargin default 2; property DragDropTransparent: Boolean read FDragDropTransparent write FDragDropTransparent default false; property DrawingStyle: TVpDrawingStyle read FDrawingStyle write SetDrawingStyle default ds3d; property EventDayStyle: TFontStyles read FEventDayStyle write SetEventDayStyle default []; property EventFont: TVpFont read FEventFont write SetEventFont; property HeadAttributes: TVpMonthViewAttr read FHeadAttr write FHeadAttr; property HolidayAttributes: TVpMvHolidayAttr read FHolidayAttr write FHolidayAttr; property HintMode: TVpHintMode read FHintMode write FHintMode default hmPlannerHint; property KBNavigation: Boolean read FKBNavigate write FKBNavigate default true; property LineColor: TColor read FLineColor write SetLineColor default DEFAULT_LINECOLOR; property MonthMargin: Integer read FMonthMargin write SetMonthMargin default TEXT_MARGIN; property OffDayColor: TColor read FOffDayColor write SetOffDayColor default OFF_COLOR; property OffDayFontColor: TColor read FOffDayFontColor write SetOffDayFontColor default clGray; property OwnerDrawCells: TVpOwnerDrawDayEvent read FOwnerDrawCells write FOwnerDrawCells; property RightClickChangeDate: Boolean read FRightClickChangeDate write SetRightClickChangeDate default vpDefWVRClickChangeDate; property SelectedDayColor: TColor read FSelectedDayColor write SetSelectedDayColor default clRed; property ShowEvents: Boolean read FShowEvents write SetShowEvents default true; property ShowEventTime: Boolean read FShowEventTime write SetShowEventTime default false; property TimeFormat: TVpTimeFormat read FTimeFormat write SetTimeFormat default tf12Hour; property TodayAttributes: TVpMvTodayAttr read FTodayAttr write FTodayAttr; property WeekendAttributes: TVpMvWeekendAttr read FWeekendAttr write FWeekendAttr; property WeekStartsOn: TVpDayType read FWeekStartsOn write SetWeekStartsOn default dtSunday; {events} property OnAddEvent: TVpOnAddNewEvent read FOnAddEvent write FOnAddEvent; property OnEventClick: TVpOnEventClick read FOnEventClick write FOnEventClick; property OnEventDblClick: TVpOnEventClick read FOnEventDblClick write FOnEventDblClick; property OnHoliday: TVpHolidayEvent read FOnHoliday write FOnHoliday; property OnModifyEvent: TVpOnModifyEvent read FOnModifyEvent write FOnModifyEvent; property OnOwnerEditEvent: TVpEditEvent read FOwnerEditEvent write FOwnerEditEvent; end; implementation uses {$IFDEF LCL} DateUtils, {$ENDIF} SysUtils, LazUTF8, Dialogs, StrUtils, VpMonthViewPainter, VpEvntEditDlg; (*****************************************************************************) { TVpMonthViewAttr } (*****************************************************************************) constructor TVpMonthViewAttr.Create(AOwner: TVpMonthView); begin inherited Create; FMonthView := AOwner; FColor := DEFAULT_HEADERCOLOR; FFont := TVpFont.Create(AOwner); end; destructor TVpMonthViewAttr.Destroy; begin FFont.Free; inherited; end; procedure TVpMonthViewAttr.SetColor(AValue: TColor); begin if FColor <> AValue then begin FColor := AValue; UpdateMonthView; end; end; procedure TVpMonthViewAttr.SetFont(AValue: TVpFont); begin FFont.Assign(AValue); FFont.Owner := FMonthView; UpdateMonthView; end; procedure TVpMonthViewAttr.UpdateMonthView; begin if Assigned(FMonthView) then FMonthView.Invalidate; end; (*****************************************************************************) { TVpMvHolidayAttr } (*****************************************************************************) constructor TVpMvHolidayAttr.Create(AOwner: TVpMonthView); begin inherited Create(AOwner); FColor := HOLIDAY_COLOR; end; (*****************************************************************************) { TVpMvWeekendAttr } (*****************************************************************************) constructor TVpMvWeekendAttr.Create(AOwner: TVpMonthView); begin inherited Create(AOwner); FColor := WEEKEND_COLOR; end; (*****************************************************************************) { TVpMvTodayAttr } (*****************************************************************************) constructor TVpMvTodayAttr.Create(AOwner: TVpMonthView); begin inherited Create(AOwner); FBorderPen := TPen.Create; FBorderPen.Color := clRed; FBorderPen.Width := 3; FBorderPen.OnChange := FMonthView.mvPenChanged; end; destructor TVpMvTodayAttr.Destroy; begin FBorderPen.Free; inherited; end; procedure TVpMvTodayAttr.SetBorderPen(Value: TPen); begin if Value <> FBorderPen then begin FBorderPen.Assign(Value); MonthView.Invalidate; end; end; (*****************************************************************************) { TVpMonthView } (*****************************************************************************) constructor TVpMonthView.Create(AOwner: TComponent); begin inherited; ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks]; HintWindowClass := TVpHintWindow; { Create internal classes and stuff } FHeadAttr := TVpMonthViewAttr.Create(self); FDayHeadAttr := TVpMonthViewAttr.Create(self); FHolidayAttr := TVpMvHolidayAttr.Create(self); FWeekendAttr := TVpMvWeekendAttr.Create(self); FTodayAttr := TVpMvTodayAttr.Create(Self); FPrevYearBtn := TSpeedButton.Create(self); FPrevYearBtn.Hint := RSPrevYear; FPrevYearBtn.OnClick := SpinButtonClick; FPrevMonthBtn := TSpeedButton.Create(self); FPrevMonthBtn.Hint := RSPrevMonth; FPrevMonthBtn.OnClick := SpinButtonClick; FNextMonthBtn := TSpeedButton.Create(self); FNextMonthBtn.Hint := RSNextMonth; FNextMonthBtn.OnClick := SpinButtonClick; FNextYearBtn := TSpeedButton.Create(self); FNextYearBtn.Hint := RSNextYear; FNextYearBtn.OnClick := SpinButtonClick; // Speedbutton glyphs {$IFDEF NEW_ICONS} LoadGlyphFromRCDATA(FPrevYearBtn.Glyph, 'VpLArrows', 16, 24, 32); LoadGlyphFromRCDATA(FPrevMonthBtn.Glyph, 'VpLArrow', 16, 24, 32); LoadGlyphFromRCDATA(FNextMonthBtn.Glyph, 'VpRArrow', 16, 24, 32); LoadGlyphFromRCDATA(FNextYearBtn.Glyph, 'VpRArrows', 16, 24, 32); {$ELSE} FPrevYearBtn.Glyph.LoadFromResourceName(HINSTANCE, 'VPLEFTARROWS'); FPrevMonthBtn.Glyph.LoadFromResourceName(HINSTANCE, 'VPLEFTARROW'); FNextMonthBtn.Glyph.LoadFromResourceName(HINSTANCE, 'VPRIGHTARROW'); FNextYearUpBtn.Glyph.LoadFromResourceName(HINSTANCE, 'VPRIGHTARROWS'); {$ENDIF} { Set styles and initialize internal variables } {$IFDEF VERSION4} // DoubleBuffered := true; {$ENDIF} FShowEvents := true; FEventDayStyle := []; FShowEventTime := false; FDayNameStyle :=dsShort; FKBNavigate := true; mvDragging := false; mvMouseDownPoint := Point(0, 0); mvMouseDown := false; DragMode := dmManual; // mvCreatingEditor := false; FSelectedDayColor := clRed; FDrawingStyle := ds3d; FColor := DEFAULT_COLOR; FLineColor := DEFAULT_LINECOLOR; FDate := Trunc(Now); FTimeFormat := tf12Hour; FDateLabelFormat := 'mmmm yyyy'; FRightClickChangeDate := vpDefWVRClickChangeDate; FDaysMargin := 2; FMonthMargin := TEXT_MARGIN; { set up fonts and colors } FDayHeadAttr.Color := clBtnFace; { Assign default font to DayNumberFont and EventFont } FDayNumberFont := TVpFont.Create(AOwner); FDayNumberFont.Assign(Font); FEventFont := TVpFont.Create(AOwner); FEventFont.Assign(Font); FOffDayFontColor := clGray; FOffDayColor := OFF_COLOR; FHolidayAttr.Font.Assign(FDayNumberFont); FWeekendAttr.Font.Assign(FHolidayAttr.Font); SetLength(mvEventArray, MaxVisibleEvents); SetLength(mvMonthdayArray, 45); { size } Height := 225; Width := 300; { Popup menu } FDefaultPopup := TPopupMenu.Create(Self); FDefaultPopup.Name := 'default'; InitializeDefaultPopup; Self.PopupMenu := FDefaultPopup; LoadLanguage; mvHookUp; end; destructor TVpMonthView.Destroy; begin FHeadAttr.Free; FHolidayAttr.Free; FTodayAttr.Free; FDayHeadAttr.Free; FWeekendAttr.Free; FDayNumberFont.Free; FEventFont.Free; inherited; end; function TVpMonthView.BuildEventString(AEvent: TVpEvent; AShowEventTime, AStartTimeOnly: Boolean): String; var timefmt: String; timeStr: String; descrStr: String; grp: TVpResourceGroup; res: TVpResource; begin Result := ''; if (AEvent = nil) or (Datastore = nil) or (Datastore.Resource = nil) then exit; timeStr := ''; descrStr := ''; if AShowEventTime then begin if AEvent.AllDayEvent then timeStr := RSAllDay else begin timeFmt := GetTimeFormatStr(TimeFormat); timeStr := FormatDateTime(timefmt, AEvent.StartTime); if not AStartTimeOnly then timeStr := timeStr + ' - ' + FormatDateTime(timeFmt, AEvent.EndTime); end; end; if AEvent.IsOverlayed then begin res := Datastore.Resources.GetResource(AEvent.ResourceID); grp := Datastore.Resource.Group; if (grp <> nil) then descrStr := Format('[%s]%s', [ IfThen(odResource in grp.ShowDetails, res.Description, res.Description), IfThen(odEventDescription in grp.ShowDetails, ' ' + AEvent.Description) ]); end else descrStr := AEvent.Description; if (timeStr <> '') and (descrStr <> '') then Result := timeStr + ': ' + descrStr else if (timeStr <> '') then Result := timeStr else Result := descrStr; end; procedure TVpMonthView.LoadLanguage; var item: TMenuItem; begin for item in FDefaultPopup.Items do if item is TVpMenuItem then TVpMenuItem(item).Translate; end; procedure TVpMonthView.Invalidate; begin inherited; end; function TVpMonthView.IsHoliday(ADate: TDate; out AHolidayName: String): Boolean; begin AHolidayName := ''; if Assigned(FOnHoliday) then FOnHoliday(Self, ADate, AHolidayName); Result := AHolidayName <> ''; end; procedure TVpMonthView.LinkHandler(Sender: TComponent; NotificationType: TVpNotificationType; const Value: Variant); begin // mvInLinkHandler := true; // try case NotificationType of neDateChange : Date := Value; neDataStoreChange : Invalidate; neInvalidate : Invalidate; end; // finally // mvInLinkHandler := false; // end; end; procedure TVpMonthView.mvHookUp; var I: Integer; begin { If the component is being dropped on a form at designtime, then } { automatically hook up to the first datastore component found } if csDesigning in ComponentState then for I := 0 to pred(Owner.ComponentCount) do begin if (Owner.Components[I] is TVpCustomDataStore) then begin DataStore := TVpCustomDataStore(Owner.Components[I]); Exit; end; end; end; procedure TVpMonthView.mvPenChanged(Sender: TObject); begin Invalidate; end; procedure TVpMonthView.Loaded; begin inherited; mvLoaded := true; mvPopulate; end; function TVpMonthView.GetControlType: TVpItemType; begin Result := itMonthView; end; procedure TVpMonthView.Paint; begin RenderToCanvas(Canvas, Rect (0, 0, Width, Height), ra0, 1, Self.Date, -1, -1, gr30Min, False); end; procedure TVpMonthView.PaintToCanvas(ACanvas: TCanvas; ARect: TRect; Angle: TVpRotationAngle; ADate: TDateTime); begin RenderToCanvas(ACanvas, ARect, Angle, 1, ADate, -1, -1, gr30Min, True); end; procedure TVpMonthView.RenderToCanvas(RenderCanvas: TCanvas; RenderIn: TRect; Angle: TVpRotationAngle; Scale: Extended; RenderDate: TDateTime; StartLine, StopLine: Integer; UseGran: TVpGranularity; DisplayOnly: Boolean); var painter: TVpMonthViewPainter; begin // mvPainting := true; painter := TVpMonthViewPainter.Create(Self, RenderCanvas); try painter.RenderToCanvas(RenderIn, Angle, Scale, RenderDate, StartLine, StopLine, UseGran, DisplayOnly); finally painter.Free; // mvPainting := false; end; end; procedure TVpMonthView.mvPopulate; begin if DataStore <> nil then DataStore.Date := FDate; end; procedure TVpMonthView.mvSpawnEventEditDialog(IsNewEvent: Boolean); var AllowIt: Boolean; EventDlg : TVpEventEditDialog; begin if DataStore = nil then Exit; if (not IsNewEvent) and (not mvActiveEvent.CanEdit) then begin MessageDlg(RSCannotEditOverlayedEvent, mtInformation, [mbOk], 0); exit; end; AllowIt := false; if Assigned(FOwnerEditEvent) then FOwnerEditEvent(self, mvActiveEvent, IsNewEvent, DataStore.Resource, AllowIt) else begin EventDlg := TVpEventEditDialog.Create(nil); try EventDlg.DataStore := DataStore; EventDlg.TimeFormat := FTimeFormat; AllowIt := EventDlg.Execute(mvActiveEvent); finally EventDlg.Free; end; end; if AllowIt then begin mvActiveEvent.Changed := true; DataStore.PostEvents; if IsNewEvent and Assigned(FOnAddEvent) then FOnAddEvent(self, mvActiveEvent); if not IsNewEvent and Assigned(FOnModifyEvent) then FOnModifyEvent(self, mvActiveEvent); end else begin if IsNewEvent then begin DataStore.Resource.Schedule.DeleteEvent(mvActiveEvent); mvActiveEvent := nil; end; DataStore.PostEvents; end; Invalidate; end; procedure TVpMonthView.SpinButtonClick(Sender: TObject); begin if Sender = FPrevYearBtn then Date := IncYear(Date, -1) else if Sender = FNextYearBtn then Date := IncYear(Date, +1) else if Sender = FPrevMonthBtn then Date := IncMonth(Date, -1) else if Sender = FNextMonthBtn then Date := IncMonth(Date, +1); end; procedure TVpMonthView.SetApplyCategoryInfos(AValue: Boolean); begin if FApplyCategoryInfos <> AValue then begin FApplyCategoryInfos := AValue; Invalidate; end; end; procedure TVpMonthView.SetColor(Value: TColor); begin if FColor <> Value then begin FColor := Value; Invalidate; end; end; procedure TVpMonthView.SetDrawingStyle(Value: TVpDrawingStyle); begin if FDrawingStyle <> Value then begin FDrawingStyle := Value; Invalidate; end; end; procedure TVpMonthView.SetLineColor(Value: TColor); begin if FLineColor <> Value then begin FLineColor := Value; Invalidate end; end; procedure TVpMonthView.SetOffDayColor(Value: TColor); begin if Value <> FOffDayColor then begin FOffDayColor := Value; Invalidate; end; end; procedure TVpMonthView.SetOffDayFontColor(Value: TColor); begin FOffDayFontColor := Value; Invalidate; end; function TVpMonthView.IsStoredDateLabelFormat: Boolean; begin Result := FDateLabelFormat <> 'mmmm yyyy'; end; procedure TVpMonthView.SetDateLabelFormat(Value: string); begin if Value <> FDateLabelFormat then begin FDateLabelFormat := Value; Invalidate; end; end; procedure TVpMonthView.SetShowEvents(Value: Boolean); begin if FShowEvents <> Value then begin FShowEvents := Value; Invalidate; end; end; procedure TVpMonthView.SetEventDayStyle(Value: TFontStyles); begin if FEventDayStyle <> Value then begin FEventDayStyle := Value; Invalidate; end; end; procedure TVpMonthView.SetDayNameStyle(Value: TVpMVDayNameStyle); begin if FDayNameStyle <> Value then begin FDayNameStyle := Value; Invalidate; end; end; procedure TVpMonthView.SetDayNumberFont(Value: TVpFont); begin FDayNumberFont.Assign(Value); Invalidate; end; procedure TVpMonthView.SetDaysMargin(Value: Integer); begin if Value <> FDaysMargin then begin FDaysMargin := Value; Invalidate; end; end; procedure TVpMonthView.SetEventFont(Value: TVpFont); begin FEventFont.Assign(Value); Invalidate; end; procedure TVpMonthView.SetMonthMargin(Value: Integer); begin if Value <> FMonthMargin then begin FMonthMargin := Value; Invalidate; end; end; procedure TVpMonthView.SetSelectedDayColor(Value: TColor); begin if Value <> FSelectedDayColor then begin FSelectedDayColor := Value; Invalidate; end; end; procedure TVpMonthView.SetShowEventTime(Value: Boolean); begin if Value <> FShowEventTime then begin FShowEventTime := Value; Invalidate; end; end; procedure TVpMonthView.SetTimeFormat(Value: TVpTimeFormat); begin if Value <> FTimeFormat then begin FTimeFormat := Value; Invalidate; end; end; procedure TVpMonthView.SetDate(Value: TDateTime); begin if FDate <> Trunc(Value) then begin FDate := Trunc(Value); if DataStore <> nil then DataStore.Date := FDate; if mvLoaded then mvPopulate; Invalidate; if ControlLink <> nil then ControlLink.Notify(self, neDateChange, FDate); end; end; {$IFNDEF LCL} procedure TVpMonthView.WMSize(var Msg: TWMSize); {$ELSE} procedure TVpMonthView.WMSize(var Msg: TLMSize); {$ENDIF} begin inherited; { force a repaint on resize } Invalidate; end; procedure TVpMonthView.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); with Params do begin Style := Style or WS_TABSTOP; {$IFNDEF LCL} WindowClass.style := CS_DBLCLKS; {$ENDIF} end; end; procedure TVpMonthView.CreateWnd; begin inherited; FPrevYearBtn.Parent := self; FPrevMonthBtn.Parent := self; FNextMonthBtn.Parent := self; FNextYearBtn.Parent := self; end; procedure TVpMonthView.DoEndDrag(Target: TObject; X, Y: Integer); begin Unused(Target, X, Y); if ReadOnly or (not FAllowDragAndDrop) then Exit; {$IFNDEF LCL} TVpEventDragObject(Target).Free; {$ENDIF} // not needed for LCL: we use DragObjectEx !! end; procedure TVpMonthView.DoStartDrag(var DragObject: TDragObject); {$IFDEF LCL} var P, HotSpot: TPoint; EventName: string; {$ENDIF} begin if ReadOnly or not FAllowDragAndDrop then Exit; if mvActiveEvent <> nil then begin {$IFDEF LCL} GetCursorPos(P{%H-}); P := TVpMonthView(Self).ScreenToClient(P); EventName := mvActiveEvent.Description; HotSpot := Point(P.X - Self.mvActiveEventRec.Left, P.Y - Self.mvActiveEventRec.Top); DragObject := TVpEventDragObject.CreateWithDragImages(Self as TControl, HotSpot, Self.mvActiveEventRec, EventName, FDragDropTransparent); {$ELSE} DragObject := DragObject := TVpEventDragObject.Create(Self); {$ENDIF} TVpEventDragObject(DragObject).Event := mvActiveEvent; end else {$IFDEF LCL} CancelDrag; {$ELSE} DragObject.Free; {$ENDIF} end; procedure TVpMonthView.DragDrop(Source: TObject; X, Y: Integer); var Event: TVpEvent; i: Integer; P: TPoint; newDate, dateDiff: TDate; begin if ReadOnly or (not FAllowDragAndDrop) then Exit; P := Point(X, Y); newDate := -1; for i := 0 to pred(Length(mvMonthdayArray)) do if PointInRect(P, mvMonthdayArray[i].Rec) then begin newDate := mvMonthdayArray[i].Date; break; end; if newDate = -1 then exit; Event := TVpEventDragObject(Source).Event; if Event <> nil then begin dateDiff := trunc(newDate) - trunc(Event.StartTime); Event.StartTime := newDate + frac(Event.StartTime); Event.EndTime := Event.EndTime + dateDiff; DataStore.PostEvents; Repaint; end; end; procedure TVpMonthView.DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin Unused(Source, X, State); Accept := false; if ReadOnly or (not FAllowDragAndDrop) then Exit; if (Y > mvDayHeadHeight) then Accept := true; end; {$IFNDEF LCL} procedure TVpMonthView.WMLButtonDown(var Msg: TWMLButtonDown); {$ELSE} procedure TVpMonthView.WMLButtonDown(var Msg: TLMLButtonDown); {$ENDIF} begin inherited; // if the mouse was pressed down in the client area, then select the cell. if not Focused then SetFocus; if (Msg.YPos > mvDayHeadHeight) then begin { The mouse click landed inside the client area } MvSetDateByCoord(Point(Msg.XPos, Msg.YPos)); { Did the mouse click land on an event? } if SelectEventAtCoord(Point(Msg.XPos, Msg.YPos)) then if (Assigned(FOnEventClick)) then FOnEventClick(self, mvActiveEvent); end; end; {$IFNDEF LCL} procedure TVpMonthView.WMLButtonDblClick(var Msg: TWMLButtonDblClk); {$ELSE} procedure TVpMonthView.WMLButtonDblClick(var Msg: TLMLButtonDblClk); {$ENDIF} var startTime, endTime: TDateTime; newevent: Boolean; begin inherited; mvMouseDownPoint := Point(0, 0); mvMouseDown := false; mvDragging := false; // if the mouse was pressed down in the client area, then select the cell. if not focused then SetFocus; if (Msg.YPos > mvDayHeadHeight) then begin { The mouse click landed inside the client area } MvSetDateByCoord(Point(Msg.XPos, Msg.YPos)); newEvent := not SelectEventAtCoord(Point(Msg.XPos, Msg.YPos)); if newEvent then mvActiveEvent := nil; { Did the mouse click land on an event? } if Assigned(FOnEventDblClick) then begin if SelectEventAtCoord(Point(Msg.XPos, Msg.YPos)) then FOnEventDblClick(self, mvActiveEvent); end else if mvActiveEvent <> nil then begin mvSpawnEventEditDialog(newevent); end else if (DataStore.Resource <> nil) then begin { otherwise, we must want to create a new event } startTime := trunc(Date) + 0.5; { default to 12:00 noon } endTime := startTime + 30 / MinutesInDay; { StartTime + 30 minutes } mvActiveEvent := DataStore.Resource.Schedule.AddEvent( DataStore.GetNextID('Events'), startTime, endTime ); { edit this new event } mvSpawnEventEditDialog(True); // true = new event end; end; end; {$IFNDEF LCL} procedure TVpMonthView.WMSetFocus(var Msg: TWMSetFocus); {$ELSE} procedure TVpMonthView.WMSetFocus(var Msg: TLMSetFocus); {$ENDIF} begin Unused(Msg); // if active event is nil then set active event to the first diaplsyed one. end; {$IFNDEF LCL} procedure TVpMonthView.CMWantSpecialKey(var Msg: TCMWantSpecialKey); begin inherited; Msg.Result := 1; end; {$ENDIF} {$IFNDEF LCL} procedure TVpMonthView.WMRButtonDown(var Msg: TWMRButtonDown); {$ELSE} procedure TVpMonthView.WMRButtonDown(var Msg: TLMRButtonDown); {$ENDIF} begin inherited; if (PopupMenu = FDefaultPopup) then begin if not Focused then SetFocus; if FRightClickChangeDate then mvSetDateByCoord (Point (Msg.XPos, Msg.YPos)); end; end; { Hint support } procedure TVpMonthView.ShowHintWindow(APoint: TPoint; ADate: TDateTime); var txt, s: String; i: Integer; event: TVpEvent; list: TList; holiday: String = ''; todayDate: TDate; begin HideHintWindow; if (csDesigning in ComponentState) then exit; case FHintMode of hmPlannerHint: begin if (ADate = 0) or (Datastore = nil) or (Datastore.Resource = nil) then exit; txt := ''; // If the date is a holiday we put the holidayname at the top IsHoliday(ADate, holiday); // Collect all events of this day and add them separated by line feeds to // the hint string (txt). list := TList.Create; try Datastore.Resource.Schedule.EventsByDate(ADate, List); for i:=0 to list.Count-1 do begin event := TVpEvent(list[i]); s := BuildEventString(event, true, false); txt := IfThen(txt = '', s, txt + LineEnding + s); end; finally list.Free; end; // If we have any events then we put the current date at the top. todayDate := SysUtils.Date(); if (txt = '') and (holiday = '') and (ADate = todayDate) then txt := RSToday + LineEnding + FormatDateTime('ddddd', ADate) else if (txt <> '') or (holiday <> '') then begin if (txt = '') and (holiday <> '') then txt := FormatDateTime('ddddd', ADate) + LineEnding + holiday else begin txt := LineEnding + txt; if holiday <> '' then txt := holiday + LineEnding + txt; txt := FormatDateTime('ddddd', ADate) + LineEnding + txt; if ADate = todayDate then txt := RSToday + LineEnding + txt; end; end; end; hmComponentHint: txt := FComponentHint; end; if (txt <> '') then begin Hint := txt; Application.Hint := txt; Application.ActivateHint(ScreenToClient(APoint), true); end else if FHintMode = hmPlannerHint then begin Hint := ''; Application.Hint := ''; end; end; procedure TVpMonthView.HideHintWindow; begin Application.CancelHint; end; procedure TVpMonthView.SetHint(const AValue: TTranslateString); begin inherited; if FHintMode = hmComponentHint then FComponentHint := AValue; end; { PopupMenu } function TVpMonthView.GetPopupMenu: TPopupMenu; begin if FExternalPopup = nil then Result := FDefaultPopup else Result := FExternalPopup; end; procedure TVpMonthView.SetPopupMenu(AValue: TPopupMenu); begin if (AValue = nil) or (AValue = FDefaultPopup) then FExternalPopup := nil else FExternalPopup := AValue; end; procedure TVpMonthView.InitializeDefaultPopup; var NewItem: TVpMenuItem; begin FDefaultPopup.Items.Clear; if RSToday <> '' then begin NewItem := TVpMenuItem.Create(Self); NewItem.Kind := mikToday; NewItem.OnClick := PopupToday; FDefaultPopup.Items.Add(NewItem); end; NewItem := TVpMenuItem.Create(Self); NewItem.Kind := mikSeparator; FDefaultPopup.Items.Add(NewItem); if RSNextMonth <> '' then begin NewItem := TVpMenuItem.Create(Self); NewItem.Kind := mikNextMonth; NewItem.OnClick := PopupNextMonth; FDefaultPopup.Items.Add(NewItem); end; if RSPrevMonth <> '' then begin NewItem := TVpMenuItem.Create(Self); NewItem.Kind := mikPrevMonth; NewItem.OnClick := PopupPrevMonth; FDefaultPopup.Items.Add(NewItem); end; NewItem := TVpMenuItem.Create(Self); NewItem.Kind := mikSeparator; FDefaultPopup.Items.Add(NewItem); if RSNextYear <> '' then begin NewItem := TVpMenuItem.Create(Self); NewItem.Kind := mikNextYear; NewItem.OnClick := PopupNextYear; FDefaultPopup.Items.Add(NewItem); end; if RSPrevYear <> '' then begin NewItem := TVpMenuItem.Create(Self); NewItem.Kind := mikPrevYear; NewItem.OnClick := PopupPrevYear; FDefaultPopup.Items.Add(NewItem); end; NewItem := TVpMenuItem.Create(Self); NewItem.Kind := mikSeparator; FDefaultPopup.Items.Add(NewItem); if RSCustomDate <> '' then begin NewItem := TVpMenuItem.Create(Self); NewItem.Kind := mikCustomDate; NewItem.OnClick := PopupCustomDate; NewItem.Tag := 0; FDefaultPopup.Items.Add(NewItem); end; end; procedure TVpMonthView.PopupToday(Sender: TObject); begin Date := Now; end; procedure TVpMonthView.PopupNextMonth(Sender: TObject); begin Date := IncMonth(Date, +1); end; procedure TVpMonthView.PopupPrevMonth(Sender: TObject); begin Date := IncMonth(Date, -1); end; procedure TVpMonthView.PopupNextYear(Sender: TObject); begin Date := IncYear(Date, +1); end; procedure TVpMonthView.PopupPrevYear(Sender: TObject); begin Date := IncYear(Date, -1); end; procedure TVpMonthView.PopupCustomDate(Sender: TObject); var d: TDate; begin d := Date; if DateDialog(RSSelectCustomDate, d) then Date := d; end; { - renamed from EditEventAtCoord and re-written} function TVpMonthView.SelectEventAtCoord(Point: TPoint): Boolean; var I: Integer; begin result := false; I := 0; while I < Length(mvEventArray) do begin if mvEventArray[I].Event = nil then begin Inc(I); Break; end else begin if (Point.X > mvEventArray[I].Rec.Left) and (Point.X < mvEventArray[I].Rec.Right) and (Point.Y > mvEventArray[I].Rec.Top) and (Point.Y < mvEventArray[I].Rec.Bottom) then begin result := true; Break; end else Inc(I); end; end; if result then begin mvActiveEvent := TVpEvent(mvEventArray[I].Event); mvActiveEventRec := mvEventArray[I].Rec; end; end; procedure TVpMonthView.mvSetDateByCoord(APoint: TPoint); var I: Integer; begin for I := 0 to pred(Length(mvMonthdayArray)) do if PointInRect(APoint, mvMonthdayArray[I].Rec) then begin Date := mvMonthdayArray[I].Date; break; end; end; function TVpMonthView.GetDateAtCoord(APoint: TPoint): TDateTime; var i: Integer; begin for i:=0 to High(mvMonthDayArray) do if PointInRect(APoint, mvMonthDayArray[i].Rec) then begin Result := mvMonthDayArray[i].Date; exit; end; Result := 0; end; procedure TVpMonthView.KeyDown(var Key: Word; Shift: TShiftState); var M, D, Y: Word; PopupPoint: TPoint; begin if FKBNavigate then case Key of VK_UP : if ssCtrl in Shift then begin DecodeDate(Date, Y, M, D); Date := EncodeDate(Y - 1, M, 1); end else Date := Date - 7; VK_DOWN: if ssCtrl in Shift then begin DecodeDate(Date, Y, M, D); Date := EncodeDate(Y + 1, M, 1); end else Date := Date + 7; VK_NEXT: SpinButtonClick(FNextMonthBtn); VK_PRIOR: SpinButtonClick(FPrevMonthBtn); VK_LEFT: if ssCtrl in Shift then SpinButtonClick(FPrevMonthBtn) else Date := Date - 1; VK_RIGHT: if ssCtrl in Shift then SpinButtonClick(FNextMonthBtn) else Date := Date + 1; VK_HOME: begin DecodeDate(Date, Y, M, D); if D = 1 then SpinButtonClick(FPrevMonthBtn) else Date := EncodeDate(Y, M, 1); end; VK_END: begin DecodeDate(Date, Y, M, D); if D = DaysInAMonth(Y, M) then begin if M = 12 then begin M := 1; Inc(Y); end else Inc(M); end; Date := EncodeDate(Y, M, DaysInAMonth(Y, M)); end; {$IFNDEF LCL} VK_TAB: if ssShift in Shift then Windows.SetFocus(GetNextDlgTabItem(GetParent(Handle), Handle, False)) else Windows.SetFocus(GetNextDlgTabItem(GetParent(Handle), Handle, True)); {$ENDIF} VK_F10: if (ssShift in Shift) and not Assigned(PopupMenu) then begin PopupPoint := GetClientOrigin; FDefaultPopup.Popup(PopupPoint.x + 10, PopupPoint.y + 10); end; VK_APPS: if not Assigned(PopupMenu) then begin PopupPoint := GetClientOrigin; FDefaultPopup.Popup(PopupPoint.x + 10, PopupPoint.y + 10); end; end; end; procedure TVpMonthView.MouseDown(Button: TMouseButton; Shift: TShiftState; X,Y: Integer); begin inherited; if not Focused then SetFocus; { Left button } if Button = mbLeft then begin mvMouseDown := true; mvMouseDownPoint := Point(X, Y); if (Y > mvDayHeadHeight) then begin { The mouse click landed inside the client area } // oldDate := FDate; mvSetDateByCoord(mvMouseDownPoint); (* { We must repaint the control here, before evaluation of the click on the events, because if the day has changed by wvSetDateByCoord then events will have different indexes in the event array; and index positions are evaluated during painting. } if oldDate <> FDate then Paint; { If an active event was clicked, then enable the click timer. If the item is double clicked before the click timer fires, then the edit dialog will appear, otherwise the in-place editor will appear. } if EventAtCoord(wvMouseDownPoint) then wvClickTimer.Enabled := true; *) end; end; (* { Right button } if Button = mbRight then begin if not Assigned(PopupMenu) then exit; { The mouse click landed inside the client area } wvSetDateByCoord(Point(X, Y)); EventAtCoord(Point(X, Y)); wvClickTimer.Enabled := false; if not Assigned(ActiveEvent) then begin for i := 0 to FDefaultPopup.Items.Count - 1 do if (FDefaultPopup.Items[i].Tag = 1) or (ReadOnly) then FDefaultPopup.Items[i].Enabled := False; end else begin for i := 0 to FDefaultPopup.Items.Count - 1 do FDefaultPopup.Items[i].Enabled := True; end; end; *) end; procedure TVpMonthView.MouseEnter; begin FMouseDate := 0; end; procedure TVpMonthView.MouseLeave; begin HideHintWindow; end; procedure TVpMonthView.MouseMove(Shift: TShiftState; X, Y: Integer); var day: TDateTime; begin inherited MouseMove(Shift, X, Y); if (mvActiveEvent <> nil) and (not ReadOnly) then begin if (not mvDragging) and mvMouseDown and ((mvMouseDownPoint.x <> x) or (mvMouseDownPoint.y <> y)) and mvActiveEvent.CanEdit then begin mvDragging := true; //mvClickTimer.Enabled := false; BeginDrag(true); end; end; if ShowHint then begin day := GetDateAtCoord(Point(X, Y)); if day = 0 then HideHintWindow else if FMouseDate <> day then begin FMouseDate := day; ShowHintWindow(Point(X, Y), day); end; end; end; procedure TVpMonthView.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited MouseUp(Button, Shift, X, Y); if Button = mbLeft then begin mvMouseDownPoint := Point(0, 0); mvMouseDown := false; mvDragging := false; end; end; procedure TVpMonthView.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if (Operation = opRemove) and (AComponent = FExternalPopup) then FExternalPopup := nil; end; procedure TVpMonthView.SetRightClickChangeDate(const v: Boolean); begin if v <> FRightClickChangeDate then FRightClickChangeDate := v; end; procedure TVpMonthView.SetWeekStartsOn(Value: TVpDayType); begin if Value <> FWeekStartsOn then begin FWeekStartsOn := Value; Invalidate; end; end; {$IF VP_LCL_SCALING <> 0} procedure TVpMonthView.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double); begin inherited; if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then begin FDaysMargin := round(FDaysMargin * AXProportion); FMonthMargin := round(FMonthMargin * AXProportion); end; end; {$IFEND} {$IF VP_LCL_SCALING = 2} procedure TVpMonthView.FixDesignFontsPPI(const ADesignTimePPI: Integer); begin inherited; DoFixDesignFontPPI(DayHeadAttributes.Font, ADesignTimePPI); DoFixDesignFontPPI(DayNumberFont, ADesignTimePPI); DoFixDesignFontPPI(EventFont, ADesignTimePPI); DoFixDesignFontPPI(HeadAttributes.Font, ADesignTimePPI); DoFixDesignFontPPI(HolidayAttributes.Font, ADesignTimePPI); DoFixDesignFontPPI(TodayAttributes.Font, ADesignTimePPI); DoFixDesignFontPPI(WeekendAttributes.Font, ADesignTimePPI); end; procedure TVpMonthView.ScaleFontsPPI(const AToPPI: Integer; const AProportion: Double); begin inherited; DoScaleFontPPI(DayHeadAttributes.Font, AToPPI, AProportion); DoScaleFontPPI(DayNumberFont, AToPPI, AProportion); DoScaleFontPPI(EventFont, AToPPI, AProportion); DoScaleFontPPI(HeadAttributes.Font, AToPPI, AProportion); DoScaleFontPPI(HolidayAttributes.Font, AToPPI, AProportion); DoScaleFontPPI(TodayAttributes.Font, AToPPI, AProportion); DoScaleFontPPI(WeekendAttributes.Font, AToPPI, AProportion); end; {$ELSEIF VP_LCL_SCALING = 1} procedure TVpMonthView.ScaleFontsPPI(const AProportion: Double); begin inherited; DoScaleFontPPI(DayHeadAttributes.Font, AProportion); DoScaleFontPPI(DayNumberFont, AProportion); DoScaleFontPPI(EventFont, Aproportion); DoScaleFontPPI(HeadAttributes.Font, AProportion); DoScaleFontPPI(HolidayAttributes.Font, AProportion); DoScaleFontPPI(TodayAttributes.Font, AProportion); DoScaleFontPPI(WeekendAttributes.Font, AProportion); end; {$ENDIF} end.