{*********************************************************} {* 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 ***** *} {$I vp.inc} unit VpMonthView; interface uses {$IFDEF LCL} LMessages, LCLProc, LCLType, LCLIntf, FileUtil, {$ELSE} Windows, Messages, {$ENDIF} Classes, Graphics, Controls, ComCtrls, ExtCtrls, Forms, Menus, VpConst, VpBase, VpBaseDS, VpMisc, VpData, VpSR, VpCanvasUtils; 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); 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; 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) protected FBorderPen: TPen; procedure SetBorderPen(Value: TPen); public constructor Create(AOwner: TVpMonthView); destructor Destroy; override; published property BorderPen: TPen read FBorderPen write SetBorderPen; end; { TVpMonthView } TVpMonthView = class(TVpLinkableControl) private FComponentHint: TTranslateString; FHintMode: TVpHintMode; FOnHoliday: TVpHolidayEvent; FAllowDragAndDrop: Boolean; FDragDropTransparent: Boolean; protected{ private } FKBNavigate: Boolean; FColumnWidth: Integer; FColor: TColor; FLineColor: TColor; FLineCount: Integer; FVisibleLines: Integer; FDayNameStyle: TVpMVDayNameStyle; FOffDayColor: TColor; FOffDayFontColor: TColor; FSelectedDayColor: TColor; FWeekStartsOn: TVpDayType; FShowEvents: Boolean; FEventDayStyle: TFontStyles; FDateLabelFormat: string; FShowEventTime: Boolean; FTopLine: Integer; FDayHeadAttr: TVpMonthViewAttr; FHeadAttr: TVpMonthViewAttr; FHolidayAttr: TVpMvHolidayAttr; FTodayAttr: TVpMvTodayAttr; FWeekendAttr: TVpMvWeekendAttr; FDayNumberFont: TVpFont; FEventFont: TVpFont; FTimeFormat: TVpTimeFormat; FDrawingStyle: TVpDrawingStyle; FDate: TDateTime; FDefaultPopup: TPopupMenu; FRightClickChangeDate: Boolean; FMouseDate: TDateTime; { event variables } FOnAddEvent: TVpOnAddNewEvent; FOwnerDrawCells: TVpOwnerDrawDayEvent; FOwnerEditEvent: TVpEditEvent; FOnEventClick: TVpOnEventClick; FOnEventDblClick: TVpOnEventClick; { internal variables } mvLoaded: Boolean; mvDayHeadHeight: Integer; mvSpinButtons: TUpDown; mvEventArray: TVpEventArray; mvMonthDayArray: TVpMonthdayArray; mvActiveEvent: TVpEvent; mvActiveEventRec: TRect; mvDragging: Boolean; mvMouseDown: Boolean; mvMouseDownPoint: TPoint; // wvHotPoint: TPoint; { property methods } procedure SetDrawingStyle(Value: TVpDrawingStyle); procedure SetColor(Value: TColor); procedure SetLineColor(Value: TColor); procedure SetOffDayColor(Value: TColor); procedure SetOffDayFontColor(Value: TColor); procedure SetDateLabelFormat(Value: string); procedure SetShowEvents(Value: Boolean); procedure SetEventDayStyle(Value: TFontStyles); procedure SetDayNameStyle(Value: TVpMVDayNameStyle); procedure SetDayNumberFont(Value: TVpFont); procedure SetEventFont(Value: TVpFont); procedure SetSelectedDayColor(Value: TColor); procedure SetShowEventTime(Value: Boolean); procedure SetTimeFormat(Value: TVpTimeFormat); procedure SetDate(Value: TDateTime); procedure SetRightClickChangeDate(const v: Boolean); procedure SetWeekStartsOn(Value: TVpDayType); { internal methods } function GetDateAtCoord(APoint: TPoint): TDateTime; procedure mvPopulate; procedure mvSpawnEventEditDialog(IsNewEvent: Boolean); procedure mvSpinButtonClick(Sender: TObject; Button: TUDBtnType); procedure mvSetDateByCoord(APoint: TPoint); procedure mvHookUp; procedure mvPenChanged(Sender: TObject); function SelectEventAtCoord(Point: TPoint): Boolean; { 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 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 } procedure InitializeDefaultPopup; procedure PopupToday(Sender: TObject); procedure PopupNextMonth(Sender: TObject); procedure PopupPrevMonth(Sender: TObject); procedure PopupNextYear(Sender: TObject); procedure PopupPrevYear(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; {$IF VP_LCL_SCALING = 2} 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 TabStop; property TabOrder; property AllowDragAndDrop: Boolean read FAllowDragAndDrop write FAllowDragAndDrop default false; property Color: TColor read FColor write SetColor; property DateLabelFormat: string read FDateLabelFormat write SetDateLabelFormat; property DayHeadAttributes: TVpMonthviewAttr read FDayHeadAttr write FDayHeadAttr; property DayNameStyle: TVpMVDayNameStyle read FDayNameStyle write SetDayNameStyle; property DayNumberFont: TVpFont read FDayNumberFont write SetDayNumberFont; property DragDropTransparent: Boolean read FDragDropTransparent write FDragDropTransparent default false; property DrawingStyle: TVpDrawingStyle read FDrawingStyle write SetDrawingStyle stored True; property EventDayStyle: TFontStyles read FEventDayStyle write SetEventDayStyle; property EventFont: TVpFont read FEventFont write SetEventFont; // property HeadAttributes: TVpMvHeadAttr read FHeadAttr write FHeadAttr; 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; property LineColor: TColor read FLineColor write SetLineColor default clGray; 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; property ShowEvents: Boolean read FShowEvents write SetShowEvents; property ShowEventTime: Boolean read FShowEventTime write SetShowEventTime; property TimeFormat: TVpTimeFormat read FTimeFormat write SetTimeFormat; property TodayAttributes: TVpMvTodayAttr read FTodayAttr write FTodayAttr; property WeekendAttributes: TVpMvWeekendAttr read FWeekendAttr write FWeekendAttr; property WeekStartsOn: TVpDayType read FWeekStartsOn write SetWeekStartsOn; {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 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 := clBtnFace; 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; FMonthView.Invalidate; end; end; procedure TVpMonthViewAttr.SetFont(AValue: TVpFont); begin FFont.Assign(AValue); 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); mvSpinButtons := TUpDown.Create(self); { FHeadAttr := TVpMvHeadAttr.Create(self); FDayHeadAttr := TVpDayHeadAttr.Create(self); FTodayAttr := TVpMvTodayAttr.Create(self); FHolidayAttr := TvpMvHolidayAttr.Create(self); mvSpinButtons := TUpDown.Create(self); } { Set styles and initialize internal variables } {$IFDEF VERSION4} // DoubleBuffered := true; {$ENDIF} FShowEvents := true; FEventDayStyle := []; FShowEventTime := false; FDayNameStyle :=dsShort; FKBNavigate := true; mvSpinButtons.OnClick := mvSpinButtonClick; mvSpinButtons.Orientation := udHorizontal; mvSpinButtons.Min := -32768; mvSpinButtons.Max := 32767; mvDragging := false; mvMouseDownPoint := Point(0, 0); mvMouseDown := false; DragMode := dmManual; // mvCreatingEditor := false; FSelectedDayColor := clRed; FDrawingStyle := ds3d; // mvPainting := false; FColor := clWindow; FLineColor := clGray; FDate := Trunc(Now); FTimeFormat := tf12Hour; FDateLabelFormat := 'mmmm yyyy'; FColumnWidth := 200; FRightClickChangeDate := vpDefWVRClickChangeDate; // mvVisibleEvents := 0; { set up fonts and colors } // FDayHeadAttributes.Font.Name := 'Tahoma'; wp: better use defaults // FDayHeadAttributes.Font.Size := 10; // FDayHeadAttributes.Font.Style := []; 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; FDefaultPopup := TPopupMenu.Create(Self); Self.PopupMenu := FDefaultPopup; LoadLanguage; mvHookUp; end; {=====} destructor TVpMonthView.Destroy; begin FHeadAttr.Free; FHolidayAttr.Free; FTodayAttr.Free; FDayHeadAttr.Free; FWeekendAttr.Free; FDayNumberFont.Free; FEventFont.Free; // mvSpinButtons.Free; // FDefaultPopup.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; begin FDefaultPopup.Items.Clear; InitializeDefaultPopup; 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); end else begin if IsNewEvent then begin DataStore.Resource.Schedule.DeleteEvent(mvActiveEvent); mvActiveEvent := nil; end; DataStore.PostEvents; end; Invalidate; mvActiveEvent := nil; end; procedure TVpMonthView.mvSpinButtonClick(Sender: TObject; Button: TUDBtnType); var M, D, Y: Word; begin DecodeDate(Date, Y, M, D); if Button = btNext then begin if M = 12 then begin M := 1; Y := Y + 1; end else M := M + 1; end else begin if M = 1 then begin M := 12; Y := Y - 1; end else M := M - 1; end; if (D > DaysInAMonth(Y, M)) then D := DaysInAMonth(Y, M); Date := EncodeDate(Y, M, D); 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; Repaint; end; end; {=====} procedure TVpMonthView.SetLineColor(Value: TColor); begin if FLineColor <> Value then begin FLineColor := Value; Repaint; 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; {=====} 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.SetEventFont(Value: TVpFont); begin FEventFont.Assign(Value); Invalidate; 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; mvSpinButtons.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)); { 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 newevent := not SelectEventAtCoord(Point(Msg.XPos, Msg.YPos)); 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 not Assigned (PopupMenu) then begin if not focused then SetFocus; if FRightClickChangeDate then mvSetDateByCoord (Point (Msg.XPos, Msg.YPos)); end; end; {=====} 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; procedure TVpMonthView.InitializeDefaultPopup; var NewItem : TMenuItem; begin if RSToday <> '' then begin NewItem := TMenuItem.Create(Self); NewItem.Caption := RSToday; NewItem.OnClick := PopupToday; FDefaultPopup.Items.Add(NewItem); end; NewItem := TMenuItem.Create(Self); NewItem.Caption := '-'; FDefaultPopup.Items.Add(NewItem); if RSNextMonth <> '' then begin NewItem := TMenuItem.Create(Self); NewItem.Caption := RSNextMonth; NewItem.OnClick := PopupNextMonth; FDefaultPopup.Items.Add(NewItem); end; if RSPrevMonth <> '' then begin NewItem := TMenuItem.Create(Self); NewItem.Caption := RSPrevMonth; NewItem.OnClick := PopupPrevMonth; FDefaultPopup.Items.Add(NewItem); end; NewItem := TMenuItem.Create(Self); NewItem.Caption := '-'; FDefaultPopup.Items.Add(NewItem); if RSNextYear <> '' then begin NewItem := TMenuItem.Create(Self); NewItem.Caption := RSNextYear; NewItem.OnClick := PopupNextYear; FDefaultPopup.Items.Add(NewItem); end; if RSPrevYear <> '' then begin NewItem := TMenuItem.Create(Self); NewItem.Caption := RSPrevYear; NewItem.OnClick := PopupPrevYear; FDefaultPopup.Items.Add(NewItem); end; end; {=====} procedure TVpMonthView.PopupToday(Sender: TObject); begin Date := Now; end; {=====} procedure TVpMonthView.PopupNextMonth(Sender: TObject); begin mvSpinButtonClick(self, btNext); end; {=====} procedure TVpMonthView.PopupPrevMonth(Sender: TObject); begin mvSpinButtonClick(self, btPrev); end; {=====} procedure TVpMonthView.PopupNextYear(Sender: TObject); var M, D, Y: Word; begin DecodeDate(Date, Y, M, D); Date := EncodeDate(Y + 1, M, 1); end; {=====} procedure TVpMonthView.PopupPrevYear(Sender: TObject); var M, D, Y: Word; begin DecodeDate(Date, Y, M, D); Date := EncodeDate(Y - 1, M, 1); 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: mvSpinButtonClick(self, btNext); VK_PRIOR: mvSpinButtonClick(self, btPrev); VK_LEFT: if ssCtrl in Shift then mvSpinButtonClick(self, btPrev) else Date := Date - 1; VK_RIGHT: if ssCtrl in Shift then mvSpinButtonClick(self, btNext) else Date := Date + 1; VK_HOME: begin DecodeDate(Date, Y, M, D); if D = 1 then mvSpinButtonClick(self, btPrev) 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.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 = 2} procedure TVpMonthView.ScaleFontsPPI(const AToPPI: Integer; const AProportion: Double); begin inherited; DoScaleFontPPI(DayHeadAttributes.Font, 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(EventFont, Aproportion); DoScaleFontPPI(HeadAttributes.Font, AProportion); DoScaleFontPPI(HolidayAttributes.Font, AProportion); DoScaleFontPPI(TodayAttributes.Font, AProportion); DoScaleFontPPI(WeekendAttributes.Font, AProportion); end; {$ENDIF} end.