unit VpGanttView; {$mode objfpc}{$H+} {$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined} interface uses lazloggerbase, LCLType, LCLIntf, LMessages, Classes, SysUtils, Graphics, Types, Controls, StdCtrls, Menus, Forms, VpConst, VpMisc, VpBase, VpBaseDS, VpData; type TVpGanttViewOption = ( gvoActiveDate, gvoHorizGrid, gvoVertGrid, gvoWeekends, gvoHolidays ); TVpGanttViewOptions = set of TVpGanttViewOption; TVpGanttSpecialDayMode = (sdmColumn, sdmHeader); const DEFAULT_GANTTVIEW_OPTIONS = [ gvoActiveDate, gvoHorizGrid, gvoVertGrid, gvoWeekends, gvoHolidays ]; type TVpGanttView = class; TVpGanttEventRec = record Event: TVpEvent; Caption: String; StartTime, EndTime: TDateTime; HeadRect: TRect; EventRect: TRect; end; PVpGanttEventRec = ^TVpGanttEventRec; TVpGanttEventList = class(TFPList) private FStartDate, FEndDate: TDateTime; function GetItem(AIndex: Integer): PVpGanttEventRec; procedure SetItem(AIndex: Integer; AItem: PVpGanttEventRec); protected procedure ClipDates(AEventRec: PVpGanttEventRec); function FindFirstRecurrence(AEvent: TVpEvent; out AStart, AEnd: TDateTime): Boolean; function FindNextRecurrence(AEvent: TVpEvent; var AStart, AEnd: TDateTime): Boolean; public constructor Create(AStartDate, AEndDate: TDateTime); destructor Destroy; override; function AddSingleEvent(AEvent: TVpEvent): PVpGanttEventRec; procedure AddRecurringEvents(AEvent: TVpEvent); procedure Clear; procedure Delete(AIndex: Integer); property Items[AIndex: Integer]: PVpGanttEventRec read GetItem write SetItem; default; end; TVpGanttHourRec = record Hour: Integer; Date: TDateTime; Rect: TRect; end; TVpGanttDayRec = record Date: TDateTime; Rect: TRect; end; TVpGanttWeekRec = record WeekNo: Integer; Date: TDateTime; Rect: TRect; end; TVpGanttMonthRec = record Date: TDateTime; Rect: TRect; end; TVpGanttHeaderAttributes = class(TPersistent) private FGanttView: TVpGanttView; FColor: TColor; procedure SetColor(AValue: TColor); protected procedure UpdateGanttView; public constructor Create(AOwner: TVpGanttView); virtual; published property Color: TColor read FColor write SetColor default DEFAULT_HEADERCOLOR; end; TVpGanttRowHeaderAttributes = class(TVpGanttHeaderAttributes) private FEventFont: TVpFont; procedure SetEventFont(AValue: TVpFont); protected public constructor Create(AOwner: TVpGanttView); override; destructor Destroy; override; published property EventFont: TVpFont read FEventFont write SetEventFont; end; TVpGanttColHeaderKind = (gchMonth, gchWeek, gchDay, gchHour); TVpGanttColHeaderKinds = set of TVpGanttColHeaderKind; TVpGanttColHeaderAttributes = class(TVpGanttHeaderAttributes) private FHourFont: TVpFont; FDayFont: TVpFont; FMonthFont: TVpFont; FWeekFont: TVpFont; FVisible: TVpGanttColHeaderKinds; procedure SetDayFont(AValue: TVpFont); procedure SetHourfont(AValue: TVpFont); procedure SetMonthFont(AValue: TVpFont); procedure SetVisible(AValue: TVpGanttColHeaderKinds); procedure SetWeekFont(AValue: TVpFont); public constructor Create(AOwner: TVpGanttView); override; destructor Destroy; override; published property DayFont: TVpFont read FDayFont write SetDayFont; property HourFont: TVpFont read FHourFont write SetHourFont; property MonthFont: TVpFont read FMonthFont write SetMonthFont; property Visible: TVpGanttColHeaderKinds read FVisible write SetVisible default [gchMonth, gchDay]; property WeekFont: TVpFont read FWeekFont write SetWeekFont; end; TVpGanttView = class(TVpLinkableControl) private FActiveCol: Integer; // Selected column FActiveRow: Integer; // Selected row FActiveEvent: TVpEvent; // Selected event FActiveDate: TDateTime; // Selected date FFirstDate: TDateTime; // Date of the first event in the resource FLastDate: TDateTime; // Date of the last event in the resource FStartDate: TDateTime; // Date of the first event to be displayed/printed (0 = first event ever) FEndDate: TDateTime; // Date of the last event to be displayed/printed (0 = last event ever) FRealStartDate: TDate; // Date of the first event to be displayed/printed (0 replaced) FRealEndDate: TDate; // Date of the last event to be displayed/printed (0 repalaced) FLeftCol: Integer; // Index of the left-most day column FTopRow: Integer; // Index of the top-most event row FVisibleCols: Integer; FVisibleRows: Integer; FRowCount: Integer; FColCount: Integer; FScrollBars: TScrollStyle; FInLinkHandler: Boolean; FLoaded: Boolean; FPainting: Boolean; FMouseDown: Boolean; FMouseDownPoint: TPoint; FColWidth: Integer; FFixedColWidth: Integer; FRowHeight: Integer; FMonthColHeaderHeight: Integer; FWeekColHeaderHeight: Integer; FDayColHeaderHeight: Integer; FHourColHeaderHeight: Integer; FTotalColHeaderHeight: Integer; FTextMargin: Integer; FColor: TColor; FHolidayColor: TColor; FLineColor: TColor; FWeekendColor: TColor; FColHeaderAttributes: TVpGanttColHeaderAttributes; FRowHeaderAttributes: TVpGanttRowHeaderAttributes; FComponentHint: TTranslateString; FDateFormat: array[0..3] of String; FDrawingStyle: TVpDrawingStyle; FDefaultPopup: TPopupMenu; FExternalPopup: TPopupMenu; FHintMode: TVpHintMode; FMouseEvent: TVpEvent; FOptions: TVpGanttViewOptions; FSpecialDayMode: TVpGanttSpecialDayMode; FTimeFormat: TVpTimeFormat; FWeekStartsOn: TVpDayType; FStartHour: TVpHours; FEndHour: TVpHours; FOnAddEvent: TVpOnAddNewEvent; FOnDeletingEvent: TVpOnDeletingEvent; FOnHoliday: TVpHolidayEvent; FOnModifyEvent: TVpOnModifyEvent; FOwnerEditEvent: TVpEditEvent; function GetDateFormat(AIndex: Integer): String; function GetDayRec(AIndex: Integer): TVpGanttDayRec; function GetEventRec(AIndex: Integer): PVpGanttEventRec; function GetHourRec(AIndex: Integer): TVpGanttHourRec; function GetMonthRec(AIndex: Integer): TVpGanttMonthRec; function GetNumDays: Integer; function GetNumEvents: Integer; function GetNumHours: Integer; function GetNumMonths: Integer; function GetNumWeeks: Integer; function GetWeekRec(AIndex: Integer): TVpGanttWeekRec; function IsStoredColWidth: Boolean; function IsStoredDateFormat(AIndex: Integer): Boolean; function IsStoredEndHour: Boolean; function IsStoredStartHour: Boolean; procedure SetActiveCol(AValue: Integer); procedure SetActiveDate(AValue: TDateTime); procedure SetActiveEvent(AValue: TVpEvent); procedure SetActiveRow(AValue: Integer); procedure SetColor(Value: TColor); reintroduce; procedure SetColWidth(AValue: Integer); procedure SetDateFormat(AIndex: Integer; AValue: String); procedure SetDrawingStyle(AValue: TVpDrawingStyle); procedure SetEndHour(AValue: TVpHours); procedure SetFixedColWidth(AValue: Integer); procedure SetHolidayColor(AValue: TColor); procedure SetLeftCol(AValue: Integer); procedure SetLineColor(AValue: TColor); procedure SetOptions(AValue: TVpGanttViewOptions); procedure SetPopupMenu(AValue: TPopupMenu); procedure SetSpecialDayMode(AValue: TVpGanttSpecialDayMode); procedure SetStartHour(AValue: TVpHours); procedure SetTextMargin(AValue: Integer); procedure SetTopRow(AValue: Integer); procedure SetWeekendColor(AValue: TColor); procedure SetWeekStartsOn(Value: TVpDayType); protected // Needed by the painter FEventRecords: TVpGanttEventList; FHourRecords: array of TVpGanttHourRec; FDayRecords: array of TVpGanttDayRec; FWeekRecords: array of TVpGanttWeekRec; FMonthRecords: array of TVpGanttMonthRec; { internal methods } procedure CalcColHeaderHeight; function CalcDaysWidth(ANumDays: Integer): Integer; procedure CalcRowHeight; function ColToDateIndex(ACol: Integer): Integer; function GetColAtCoord(X: Integer): Integer; function GetDateOfCol(ACol: Integer): TDateTime; function GetDateTimeAtCoord(X: Integer): TDateTime; function GetEventAtCoord(X, Y: Integer): TVpEvent; function GetEventOfRow(ARow: Integer): TVpEvent; procedure GetRealEventDateRange(out AStartDate, AEndDate: TDate); function GetRowAtCoord(Y: Integer): Integer; function GetRowOfEvent(AEvent: TVpEvent): Integer; procedure GetEventDateRange(out AFirstDate, ALastDate: TDate); function IsEventOnDate(AEvent: TVpEvent; ADate: TDate): Boolean; procedure Hookup; procedure Populate; procedure PopulateDayRecords; procedure PopulateEventRecords; procedure PopulateHourRecords; procedure PopulateMonthRecords; procedure PopulateWeekRecords; procedure ScrollDateIntoView(ADate: TDateTime); procedure ScrollHorizontal(ANumCols: Integer); procedure ScrollRowIntoView(ARow: Integer); procedure ScrollVertical(ANumRows: Integer); procedure SetHScrollPos; procedure SetVScrollPos; procedure SpawnEventEditDialog(IsNewEvent: Boolean); { inherited methods } procedure CreateParams(var AParams: TCreateParams); override; procedure DblClick; override; function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override; function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override; procedure DoOnResize; override; class function GetControlClassDefaultSize: TSize; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure Loaded; 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 Paint; override; procedure WMHScroll(var Msg: TLMHScroll); message LM_HSCROLL; procedure WMVScroll(var Msg: TLMVScroll); message LM_VSCROLL; { LCL scaling } {$IF VP_LCL_SCALING <> 0} procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double); override; {$IFEND} { Hints } procedure ShowHintWindow(APoint: TPoint; AEvent: TVpEvent); procedure HideHintWindow; procedure SetHint(const AValue: TTranslateString); override; procedure SetHintMode(const AValue: TVpHintMode); { Popup } function GetPopupMenu: TPopupMenu; override; procedure InitializeDefaultPopup; procedure PopupAddEvent(Sender: TObject); procedure PopupDeleteEvent(Sender: TObject); procedure PopupEditEvent(Sender: TObject); procedure UpdatePopupMenuState; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function BuildEventString(AEvent: TVpEvent; UseAsHint: Boolean): String; procedure DeleteActiveEvent(Prompt: Boolean); function GetControlType: TVpItemType; override; function HourMode: Boolean; function HoursPerDay: Integer; procedure Init; function IsHoliday(ADate: TDate; out AHolidayName: String): Boolean; procedure LoadLanguage; procedure LinkHandler(Sender: TComponent; NotificationType: TVpNotificationType; const Value: Variant); override; procedure RenderToCanvas(RenderCanvas: TCanvas; RenderIn: TRect; Angle: TVpRotationAngle; Scale: Extended; RenderDate: TDateTime; StartLine, StopLine: Integer; UseGran: TVpGranularity; DisplayOnly: Boolean); override; procedure SetDateLimits(AStartDate, AEndDate: TDateTime); {$IF VP_LCL_SCALING = 2} procedure FixDesignFontsPPI(const ADesignTimePPI: Integer); override; procedure ScaleFontsPPI(const AToPPI: Integer; const AProportion: Double); override; {$ELSE} {$IF VP_LCL_SCALING = 1} procedure ScaleFontsPPI(const AProportion: Double); override; {$ENDIF} {$ENDIF} // Methods/properties used by painter. Not meant to be called by user. function CalcVisibleCols(AWidth, AFixedColWidth, AColWidth: Integer): Integer; function CalcVisibleRows(AHeight, AHeaderHeight, ARowHeight: Integer): Integer; property FirstDate: TDateTime read FFirstDate; property LastDate: TDateTime read FLastDate; property RealStartDate: TDateTime read FRealStartDate; property RealEndDate: TDateTime read FRealEndDate; property ActiveCol: Integer read FActiveCol write SetActiveCol; property ActiveEvent: TVpEvent read FActiveEvent write SetActiveEvent; property ActiveDate: TDateTime read FActiveDate write SetActiveDate; property ActiveRow: Integer read FActiveRow write SetActiveRow; property StartDate: TDateTime read FStartDate write FStartDate; property EndDate: TDateTime read FEndDate write FEndDate; property ColCount: Integer read FColCount write FColCount; property RowCount: Integer read FRowCount write FRowCount; property VisibleCols: Integer read FVisibleCols write FVisibleCols; property VisibleRows: Integer read FVisibleRows write FVisibleRows; property LeftCol: Integer read FLeftCol write SetLeftCol; property TopRow: Integer read FTopRow write SetTopRow; // Unscaled dimensions property RowHeight: Integer read FRowHeight; property DayColHeaderHeight: Integer read FDayColHeaderHeight; property HourColHeaderHeight: Integer read FHourColHeaderHeight; property MonthColHeaderHeight: Integer read FMonthColHeaderHeight; property TotalColHeaderHeight: Integer read FTotalColHeaderHeight; property DayRecords[AIndex: Integer]: TVpGanttDayRec read GetDayRec; property EventRecords[AIndex: Integer]: PVpGanttEventRec read GetEventRec; property HourRecords[AIndex: Integer]: TVPGanttHourRec read GetHourRec; property MonthRecords[AIndex: Integer]: TVpGanttMonthRec read GetMonthRec; property WeekRecords[AIndex: Integer]: TVpGanttWeekRec read GetWeekRec; property NumDays: Integer read GetNumDays; property NumEvents: Integer read GetNumEvents; property NumHours: Integer read GetNumHours; property NumMonths: Integer read GetNumMonths; property NumWeeks: Integer read GetNumWeeks; published // inherited properties property Align; property Anchors; property BorderSpacing; property ReadOnly; // new properties property ColHeaderAttributes: TVpGanttColHeaderAttributes read FColHeaderAttributes write FColHeaderAttributes; property Color: TColor read FColor write SetColor default DEFAULT_COLOR; property ColWidth: Integer read FColWidth write SetColWidth stored IsStoredColWidth; property DayFormat: String index 0 read GetDateFormat write SetDateFormat stored IsStoredDateFormat; property DayFormat_HourMode: String index 3 read GetDateFormat write SetDateFormat stored IsStoredDateFormat; property DrawingStyle: TVpDrawingStyle read FDrawingStyle write SetDrawingStyle default ds3d; property EndHour: TVpHours read FEndHour write SetEndHour stored IsStoredEndHour; property FixedColWidth: Integer read FFixedColWidth write SetFixedColWidth default 120; property HintMode: TVpHintMode read FHintMode write SetHintMode default hmPlannerHint; property HolidayColor: TColor read FHolidayColor write SetHolidayColor default HOLIDAY_COLOR; property LineColor: TColor read FLineColor write SetLineColor default DEFAULT_LINECOLOR; property MonthFormat: String index 1 read GetDateFormat write SetDateFormat stored IsStoredDateFormat; property MonthFormat_short: String index 2 read GetDateFormat write SetDateFormat stored IsStoredDateFormat; property Options: TVpGanttViewOptions read FOptions write SetOptions default DEFAULT_GANTTVIEW_OPTIONS; property PopupMenu: TPopupMenu read GetPopupMenu write SetPopupMenu; property RowHeaderAttributes: TVpGanttRowHeaderAttributes read FRowHeaderAttributes write FRowHeaderAttributes; property SpecialDayMode: TVpGanttSpecialDayMode read FSpecialDayMode write SetSpecialDayMode default sdmColumn; property StartHour: TVpHours read FStartHour write SetStartHour stored IsStoredStartHour; property TextMargin: Integer read FTextMargin write SetTextMargin default 2; property TimeFormat: TVpTimeFormat read FTimeFormat write FTimeFormat default tf12Hour; property WeekendColor: TColor read FWeekendColor write SetWeekendColor default WEEKEND_COLOR; property WeekStartsOn: TVpDayType read FWeekStartsOn write SetWeekStartsOn default dtSunday; // inherited events property OnClick; // new events property OnAddEvent: TVpOnAddNewEvent read FOnAddEvent write FOnAddEvent; property OnDeletingEvent: TVpOnDeletingEvent read FOnDeletingEvent write FOnDeletingEvent; property OnHoliday: TVpHolidayEvent read FOnHoliday write FOnHoliday; deprecated 'Use TControlLink.OnHoliday instead'; property OnModifyEvent: TVpOnModifyEvent read FOnModifyEvent write FOnModifyEvent; property OwnerEditEvent: TVpEditEvent read FOwnerEditEvent write FOwnerEditEvent; end; implementation uses DateUtils, Math, Dialogs, VpSR, VpGanttViewPainter, VpEvntEditDlg; const DEFAULT_DAYFORMAT = 'd'; DEFAULT_MONTHFORMAT = 'mmmm yyyy'; DEFAULT_MONTHFORMAT_SHORT = 'mmm yyyy'; DEFAULT_DAYFORMAT_HOURMODE = 'dddddd'; // long date format DEFAULT_COLWIDTH = 20; DEFAULT_START_HOUR = h_07; DEFAULT_END_HOUR = h_20; { Compare function for sorting event records: Compares the start times of two events. If the times are equal (within 1 seconds) then end times are compared. The function is used by TVpGanttEventList.Sort. } function CompareEventRecs(Item1, Item2: Pointer): Integer; var eventRec1, eventRec2: PVpGanttEventRec; begin eventRec1 := PVpGanttEventRec(Item1); eventRec2 := PVpGanttEventRec(Item2); if SameValue(eventRec1^.StartTime, eventRec2^.StartTime, TIME_EPS) then Result := CompareValue(eventRec1^.EndTime, eventRec2^.EndTime) else Result := CompareValue(eventRec1^.StartTime, eventRec2^.StartTime); end; {******************************************************************************} { TVpGanttEventList } {******************************************************************************} constructor TVpGanttEventList.Create(AStartDate, AEndDate: TDateTime); begin inherited Create; FStartDate := AStartDate; FEndDate := AEndDate; end; destructor TVpGanttEventList.Destroy; begin Clear; inherited; end; procedure TVpGanttEventList.AddRecurringEvents(AEvent: TVpEvent); var eventRec: PVpGanttEventRec; dt1, dt2: TDateTime; begin if AEvent.AllDayEvent then begin dt1 := DatePart(AEvent.StartTime); dt2 := DatePart(AEvent.EndTime) + 1; if frac(AEvent.EndTime) = 0 then dt2 := dt2 + 1; end else begin dt1 := AEvent.StartTime; dt2 := AEvent.EndTime; end; if FindFirstRecurrence(AEvent, dt1, dt2) then repeat eventRec := AddSingleEvent(AEvent); eventRec^.StartTime := dt1; eventRec^.EndTime := dt2; until not FindNextRecurrence(AEvent, dt1, dt2); end; function TVpGanttEventList.AddSingleEvent(AEvent: TVpEvent): PVpGanttEventRec; const EPS = 1e-9; var eventRec: PVpGanttEventRec; dt1, dt2: TDateTime; begin // Handle the start/end times of all-day events correctly. if AEvent.AllDayEvent then begin dt1 := DatePart(AEvent.StartTime); dt2 := DatePart(AEvent.EndTime) + 1 - EPS; end else begin dt1 := AEvent.StartTime; dt2 := AEvent.EndTime; end; // Populate the event record New(eventRec); eventRec^ := Default(TVpGanttEventRec); eventRec^.Event := AEvent; eventRec^.Caption := AEvent.Description; eventRec^.StartTime := dt1; eventRec^.EndTime := dt2; eventRec^.HeadRect := Rect(-1, -1, -1, -1); eventRec^.EventRect := Rect(-1, -1, -1, -1); ClipDates(eventRec); Result := eventRec; Add(Result); end; procedure TVpGanttEventList.Clear; var eventRec: PVpGanttEventRec; i: Integer; begin for i := 0 to Count-1 do begin eventRec := GetItem(i); Dispose(eventRec); end; inherited; end; procedure TVpGanttEventList.ClipDates(AEventRec: PVpGanttEventRec); begin // The time range of events reaching out of the displayed date range // must be clipped at the edges. if AEventRec^.StartTime < FStartDate then AEventRec^.StartTime := FStartDate; if AEventRec^.EndTime > FEndDate + 1 then AEventRec^.EndTime := FEndDate + 1; end; procedure TVpGanttEventList.Delete(AIndex: Integer); var eventRec: PVpGanttEventRec; begin eventRec := GetItem(AIndex); Dispose(eventRec); inherited; end; // Find date/times of first recurrence of the specified event in the gantt view's // date range. function TVpGanttEventList.FindFirstRecurrence(AEvent: TVpEvent; out AStart, AEnd: TDateTime): Boolean; var delta: Double; d: TDateTime; eventYear, eventMonth, eventDay: Word; startYear, startMonth, startDay: Word; begin Result := false; if AEvent.StartTime >= FEndDate then exit; if (AEvent.RepeatRangeEnd > 0) and (AEvent.RepeatRangeEnd <= FStartDate) then exit; if AEvent.StartTime >= FStartDate then begin AStart := AEvent.StartTime; AEnd := AEvent.EndTime; Result := true; exit; end; DecodeDate(AEvent.StartTime, eventYear, eventMonth, eventDay); DecodeDate(FStartDate, startYear, startMonth, startDay); case AEvent.RepeatCode of rtDaily: AStart := DatePart(FStartDate) + TimePart(AEvent.StartTime); rtWeekly: begin delta := AEvent.StartTime - StartOfTheWeek(AEvent.StartTime); AStart := StartOfTheWeek(FStartDate) + delta; end; rtMonthlyByDay: begin delta := AEvent.StartTime - StartOfTheMonth(AEvent.StartTime); AStart := StartOfTheMonth(FStartDate) + delta; end; rtMonthlyByDate: AStart := EncodeDate(startYear, startMonth, eventDay); rtYearlyByDay: begin delta := AEvent.StartTime - StartofTheYear(AEvent.StartTime); AStart := StartOfTheYear(FStartDate) + delta; end; rtYearlyByDate: if not TryEncodeDate(startYear, eventMonth, eventDay, AStart) then AStart := EncodeDate(startYear, 2, 28); rtCustom: begin AStart := trunc((FStartDate - DatePart(AEvent.StartTime)) / AEvent.CustomInterval) * AEvent.CustomInterval + TimePart(AEvent.StartTime); if AStart < FStartdate then AStart := AStart + AEvent.CustomInterval; end; end; AEnd := AStart + (AEvent.EndTime - AEvent.StartTime); if (AEvent.RepeatRangeEnd > 0) and (AEnd > AEvent.RepeatRangeEnd) then exit; if AStart > FEndDate + 1 then exit; Result := true; end; // Find date/times of next recurrence of the specified event. function TVpGanttEventList.FindNextRecurrence(AEvent: TVpEvent; var AStart, AEnd: TDateTime): Boolean; var delta: Double; begin Result := false; if (AStart >= FEndDate) then exit; case AEvent.RepeatCode of rtDaily: begin AStart := AStart + 1; AEnd := AEnd + 1; end; rtWeekly: begin AStart := AStart + 7; AEnd := AEnd + 7; end; rtMonthlyByDay: begin delta := DatePart(AStart) - StartOfTheMonth(AStart); AStart := AStart + delta; AEnd := AEnd + delta; end; rtMonthlyByDate: begin AStart := IncMonth(AStart, 1); AEnd := IncMonth(AEnd, 1); end; rtYearlyByDay: begin delta := DatePart(AStart) - StartOfTheYear(AStart); AStart := AStart + delta; AEnd := AEnd + delta; end; rtYearlyByDate: begin AStart := IncYear(AStart, 1); AEnd := IncYear(AEnd, 1); end; rtCustom: begin AStart := AStart + AEvent.CustomInterval; AEnd := AEnd + AEvent.CustomInterval; end; end; if (AEvent.RepeatRangeEnd > 0) and (AEnd > AEvent.RepeatRangeEnd) then exit; if AStart > FEndDate + 1 then exit; Result := true; end; function TVpGanttEventList.GetItem(AIndex: Integer): PVpGanttEventRec; begin Result := PVpGanttEventRec(inherited Items[AIndex]); end; procedure TVpGanttEventList.SetItem(AIndex: Integer; AItem: PVpGanttEventRec); begin inherited Items[AIndex] := AItem; end; {******************************************************************************} { TVpGanttHeaderAttributes } {******************************************************************************} constructor TVpGanttHeaderAttributes.Create(AOwner: TVpGanttView); begin inherited Create; FGanttView := AOwner; FColor := DEFAULT_HEADERCOLOR; end; procedure TVpGanttHeaderAttributes.SetColor(AValue: TColor); begin if FColor <> AValue then begin FColor := AValue; UpdateGanttView; end; end; procedure TVpGanttHeaderAttributes.UpdateGanttView; begin if Assigned(FGanttView) then FGanttView.Invalidate; end; {******************************************************************************} { TVpGanttRowHeaderAttributes } {******************************************************************************} constructor TVpGanttRowHeaderAttributes.Create(AOwner: TVpGanttView); begin inherited Create(AOwner); FEventFont := TVpFont.Create(AOwner); end; destructor TVpGanttRowHeaderAttributes.Destroy; begin FEventFont.Free; inherited; end; procedure TVpGanttRowHeaderAttributes.SetEventFont(AValue: TVpFont); begin if FEventFont <> AValue then begin FEventFont := AValue; FEventFont.Owner := FGanttView; UpdateGanttView; end; end; {******************************************************************************} { TVpGanttColHeaderAttributes } {******************************************************************************} constructor TVpGanttColHeaderAttributes.Create(AOwner: TVpGanttView); begin inherited Create(AOwner); FHourFont := TVpFont.Create(AOwner); FDayFont := TVpFont.Create(AOwner); FWeekFont := TVpFont.Create(AOwner); FMonthFont := TVpFont.Create(AOwner); FVisible := [gchMonth, gchDay]; end; destructor TVpGanttColHeaderAttributes.Destroy; begin FHourFont.Free; FDayFont.Free; FWeekFont.Free; FMonthFont.Free; inherited; end; procedure TVpGanttColHeaderAttributes.SetDayFont(AValue: TVpFont); begin if FDayFont <> AValue then begin FDayFont := AValue; FDayFont.Owner := FGanttView; UpdateGanttView; end; end; procedure TVpGanttColHeaderAttributes.SetHourFont(AValue: TVpFont); begin if FHourFont <> AValue then begin FHourFont := AValue; FHourFont.Owner := FGanttView; UpdateGanttView; end; end; procedure TVpGanttColHeaderAttributes.SetMonthFont(AValue: TVpFont); begin if FMonthFont <> AValue then begin FMonthFont := AValue; FMonthFont.Owner := FGanttView; UpdateGanttView; end; end; procedure TVpGanttColHeaderAttributes.SetVisible(AValue: TVpGanttColHeaderKinds); var HourModeChanged: Boolean; d: TDateTime; begin if FVisible <> AValue then begin HourModeChanged := (gchHour in FVisible) <> (gchHour in AValue); FVisible := AValue; if HourModeChanged then begin d := FGanttView.ActiveDate; FGanttView.Init; FGanttView.FActiveDate := 0; // Enforce execution of SetActiveDate FGanttView.SetActiveDate(d); end; UpdateGanttView; end; end; procedure TVpGanttColHeaderAttributes.SetWeekFont(AValue: TVpFont); begin if FWeekFont <> AValue then begin FWeekFont := AValue; FWeekFont.Owner := FGanttView; UpdateGanttView; end; end; {******************************************************************************} { TVpGanttView } {******************************************************************************} constructor TVpGanttView.Create(AOwner: TComponent); begin inherited; ControlStyle := [csCaptureMouse, csOpaque, csClickEvents, csDoubleClicks]; FInLinkHandler := false; FLoaded := false; FPainting := false; FMouseDown := false; SetActiveDate(Now); FColWidth := DEFAULT_COLWIDTH; FFixedColWidth := 120; FTextMargin := 2; FColor := DEFAULT_COLOR; FLineColor := DEFAULT_LINECOLOR; FWeekendColor := WEEKEND_COLOR; FHolidayColor := HOLIDAY_COLOR; FStartHour := DEFAULT_START_HOUR; FEndHour := DEFAULT_END_HOUR; FRowHeaderAttributes := TVpGanttRowHeaderAttributes.Create(self); FColHeaderAttributes := TVpGanttColHeaderAttributes.Create(self); FDateFormat[0] := DEFAULT_DAYFORMAT; FDateFormat[1] := DEFAULT_MONTHFORMAT; FDateFormat[2] := DEFAULT_MONTHFORMAT_SHORT; FDateFormat[3] := DEFAULT_DAYFORMAT_HOURMODE; FDrawingStyle := ds3d; FOptions := DEFAULT_GANTTVIEW_OPTIONS; FScrollBars := ssBoth; FWeekStartsOn := dtSunday; // Popup menu FDefaultPopup := TPopupMenu.Create(Self); FDefaultPopup.Name := 'default'; InitializeDefaultPopup; Self.PopupMenu := FDefaultPopup; // Initial size of the control with GetControlClassDefaultSize do SetInitialBounds(0, 0, CX, CY); Hookup; end; destructor TVpGanttView.Destroy; begin FEventRecords.Free; FRowHeaderAttributes.Free; FColHeaderAttributes.Free; inherited; end; function TVpGanttView.BuildEventString(AEvent: TVpEvent; UseAsHint: Boolean): String; const DATE_FORMAT = 'ddddd'; var timeFmt: String; startDateStr, endDateStr: string; s: String; begin Result := ''; if (AEvent = nil) or (Datastore = nil) or (Datastore.Resource = nil) then exit; if UseAsHint then begin { Usage as hint } startDateStr := FormatDateTime(DATE_FORMAT, AEvent.StartTime); if SameDate(AEvent.StartTime, AEvent.EndTime) then endDateStr := '' else endDateStr := FormatDateTime(DATE_FORMAT, AEvent.EndTime); if AEvent.AllDayEvent then begin if endDateStr <> '' then endDateStr := ' - ' + endDateStr; Result := startDateStr + endDatestr + LineEnding + RSAllDay; end else begin timefmt := GetTimeFormatStr(TimeFormat); startDateStr := startDateStr + ' ' + FormatDateTime(timeFmt, AEvent.StartTime) + ' - '; if endDateStr <> '' then endDateStr := endDateStr + ' '; endDateStr := endDateStr + FormatDateTime(timeFmt, AEvent.EndTime); Result := startDateStr + endDateStr; end; // Event description Result := Result + LineEnding2 + RSEvent + ':' + LineEnding + AEvent.Description; // Event notes if (AEvent.Notes <> '') then begin s := WrapText(AEvent.Notes, MAX_HINT_WIDTH); s := StripLastLineEnding(s); Result := Result + LineEnding2 + RSNotes + ':' + LineEnding + s; end; // Event location if (AEvent.Location <> '') then Result := Result + LineEnding2 + RSLocation + ':' + LineEnding + AEvent.Location; end else { Usage as cell text } Result := ''; end; procedure TVpGanttView.CalcColHeaderHeight; var s: String; h: Integer; begin h := GetCanvasTextHeight(Canvas, FColHeaderAttributes.MonthFont); FMonthColHeaderHeight := h; h := GetCanvasTextHeight(Canvas, FColHeaderAttributes.WeekFont); FWeekColHeaderHeight := h; // A typical date string to measure the text height (line breaks in DayFormat allowed) s := FormatDateTime(DayFormat, EncodeDate(2000, 12, 28)); h := GetCanvasTextHeight(Canvas, FColHeaderAttributes.DayFont, s); FDayColHeaderHeight := h; h := GetCanvasTextHeight(Canvas, FColHeaderAttributes.HourFont); FHourColHeaderHeight := h; FTotalColHeaderHeight := 0; if (gchMonth in FColHeaderAttributes.Visible) then inc(FTotalColHeaderHeight, FMonthColHeaderHeight + FTextMargin); if (gchWeek in FColHeaderAttributes.Visible) then inc(FTotalColHeaderHeight, FWeekColHeaderHeight + FTextMargin); if (gchDay in FColHeaderAttributes.Visible) then inc(FTotalColHeaderHeight, FDayColHeaderHeight + FTextMargin); if (gchHour in FColHeaderAttributes.Visible) then inc(FTotalColHeaderHeight, FHourColHeaderHeight + FTextMargin); if FTotalColHeaderHeight > 0 then inc(FTotalColHeaderHeight, FTextMargin); end; function TvpGanttView.CalcDaysWidth(ANumDays: Integer): Integer; begin Result := ANumDays * FColWidth; if HourMode then Result := Result * HoursPerDay; end; procedure TVpGanttView.CalcRowHeight; var h: Integer; begin h := GetCanvasTextHeight(Canvas, FRowHeaderAttributes.EventFont); FRowHeight := h + 2 * FTextMargin; end; function TVpGanttView.CalcVisibleCols(AWidth, AFixedColWidth, AColWidth: Integer): Integer; var d: Integer = 0; // Result of div m: Integer = 0; // Result of mod begin if AColWidth <> 0 then begin DivMod(AWidth - AFixedColWidth, AColWidth, d, m); if (m = 0) and (d > 1) then dec(d); Result := d; end else Result := 0; end; function TVpGanttView.CalcVisibleRows(AHeight, AHeaderHeight, ARowHeight: Integer): Integer; var d: Integer = 0; // Result of div m: Integer = 0; // Result of mod begin if ARowHeight <> 0 then begin DivMod(AHeight - AHeaderHeight, ARowHeight, d, m); if (m = 0) and (d > 1) then dec(d); Result := d; end else Result := 0; end; function TVpGanttView.ColToDateIndex(ACol: Integer): Integer; begin if HourMode then Result := ACol div HoursPerDay else Result := ACol; end; procedure TVpGanttView.CreateParams(var AParams: TCreateParams); begin inherited CreateParams(AParams); with AParams do begin Style := Style or WS_TABSTOP; if FScrollBars in [ssVertical, ssBoth, ssAutoVertical, ssAutoBoth] then Style := Style or WS_VSCROLL; if FScrollBars in [ssHorizontal, ssBoth, ssAutoHorizontal, ssAutoBoth] then Style := Style or WS_HSCROLL; end; end; procedure TVpGanttView.DblClick; var dt, startTime, endTime: TDateTime; begin inherited; FMouseDown := false; // If the mouse was pressed down in the client area, then select the cell. if not Focused then SetFocus; if ReadOnly then begin FMouseDownPoint := Point(0, 0); exit; end; // Is there an event at the clicked cell? FActiveEvent := GetEventAtCoord(FMouseDownPoint.X, FMouseDownPoint.Y); if (FActiveEvent <> nil) then // yes: edit the event SpawnEventEditDialog(False) else begin // no: add a new event dt := GetDateTimeAtCoord(FMouseDownPoint.X); if dt <> NO_DATE then begin startTime := DatePart(dt); endTime := startTime + 1.0 - OneSecond; FActiveEvent := Datastore.Resource.Schedule.AddEvent( Datastore.GetNextID(EventsTableName), startTime, endTime ); FActiveEvent.AllDayEvent := true; SetActiveEvent(FActiveEvent); SpawnEventEditDialog(True); end; end; FMouseDownPoint := Point(0, 0); end; procedure TVpGanttView.DeleteActiveEvent(Prompt: Boolean); var DoIt: Boolean; begin if ReadOnly then Exit; if (FActiveEvent <> nil) and (not FActiveEvent.CanEdit) then exit; DoIt := not Prompt; if FActiveEvent <> nil then begin if Assigned(FOnDeletingEvent) then begin DoIt := true; FOnDeletingEvent(self, FActiveEvent, DoIt); end else if Prompt then DoIt := (MessageDlg(RSConfirmDeleteEvent + LineEnding2 + RSPermanent, mtConfirmation, [mbYes, mbNo], 0) = mrYes); if DoIt then begin FActiveEvent.Deleted := true; DataStore.PostEvents; Invalidate; end; end; end; {$IF VP_LCL_SCALING <> 0} procedure TVpGanttView.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double); begin inherited; if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then begin ColWidth := round(ColWidth * AXProportion); FixedColWidth := round(FixedColWidth * AXProportion); TextMargin := round(TextMargin * AXProportion); end; end; {$IFEND} function TVpGanttView.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; begin Result := inherited DoMouseWheelDown(Shift, MousePos); if not Result then begin if Shift = [] then ScrollVertical(1) else if Shift = [ssCtrl] then ScrollHorizontal(1) else exit; Result := True; end; end; function TVpGanttView.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; begin Result := inherited DoMouseWheelUp(Shift, MousePos); if not Result then begin if Shift = [] then ScrollVertical(-1) else if Shift = [ssCtrl] then ScrollHorizontal(-1) else exit; Result := True; end; end; procedure TVpGanttView.DoOnResize; var emptyRows, emptyCols: Integer; begin inherited; if (FRowHeight > 0) and Assigned(FEventRecords) and (FEventRecords.Count > 0) then begin VisibleRows := CalcVisibleRows(ClientHeight, FTotalColHeaderHeight, FRowHeight); emptyRows := VisibleRows - (FEventRecords.Count - FTopRow); if emptyRows > 0 then ScrollVertical(-emptyRows); VisibleCols := CalcVisibleCols(ClientWidth, FFixedColWidth, FColWidth); emptyCols := VisibleCols - (ColCount - FLeftCol); if emptyCols > 0 then ScrollHorizontal(-emptyCols); end; Invalidate; end; function TVpGanttView.GetColAtCoord(X: Integer): Integer; begin Result := (X - FixedColWidth) div FColWidth + FLeftCol; end; { Defines the initial size of the control. } class function TVpGanttView.GetControlClassDefaultSize: TSize; begin Result.CX := 300; Result.CY := 200; end; function TVpGanttView.GetControlType: TVpItemType; begin Result := itGanttView; end; function TVpGanttView.GetDateFormat(AIndex: Integer): String; begin Result := FDateFormat[AIndex]; end; function TVpGanttView.GetDateOfCol(ACol: Integer): TDateTime; begin Result := FRealStartDate + ColToDateIndex(ACol); end; function TVpGanttView.GetDateTimeAtCoord(X: Integer): TDateTime; var c: Integer; dayIdx: Integer; dayPos: Integer; dayWidth: Integer; timePart: TTime; begin c := GetColAtCoord(X); if (c >= 0) and (c < ColCount) then begin Result := GetDateOfCol(c); X := X - FFixedColWidth; dayWidth := CalcDaysWidth(1); if HourMode then begin dayIdx := ColToDateIndex(c); dayPos := FDayRecords[dayIdx].Rect.Left - FFixedColWidth; dec(dayPos, FLeftCol * FColWidth); timePart := (((X - dayPos) / dayWidth) * HoursPerDay + ord(FStartHour)) / 24; end else timePart := frac(X / dayWidth); Result := Result + timePart; end else Result := NO_DATE; end; function TVpGanttView.GetDayRec(AIndex: Integer): TVpGanttDayRec; begin Result := FDayRecords[AIndex]; end; function TVpGanttView.GetEventAtCoord(X, Y: Integer): TVpEvent; var idx: Integer; eventRec: PVpGanttEventRec; dt: TDateTime; begin Result := nil; dt := GetDateTimeAtCoord(X); if (dt = NO_DATE) or (FRowHeight = 0) then exit; idx := GetRowAtCoord(Y); if (idx >= 0) and (idx < NumEvents) then begin eventRec := FEventRecords[idx]; Result := eventRec^.Event; if Result.AllDayEvent then begin if (dt < DatePart(eventRec^.StartTime)) or (dt > DatePart(eventRec^.EndTime) + 1) then Result := nil; end else if (dt < eventRec^.StartTime) or (dt > eventRec^.EndTime) then Result := nil; end; end; { Determines the dates when the earliest event in the entire Schedule starts, and when the latest event ends. } procedure TVpGanttView.GetEventDateRange(out AFirstDate, ALastDate: TDate); var i, j: Integer; event: TVpEvent = nil; d: TDateTime; begin AFirstDate := NO_DATE; ALastDate := NO_DATE; if (Datastore = nil) or (Datastore.Resource = nil) or (Datastore.Resource.Schedule.EventCount = 0) then exit; // Find first non-recurring event; recurring events will be accepted only // between FStartDate and FEndDate. i := 0; repeat event := Datastore.Resource.Schedule.GetEvent(i); inc(i); until (event.RepeatCode = rtNone) or (i = DataStore.Resource.Schedule.EventCount); if event <> nil then begin AFirstDate := DatePart(event.StartTime); ALastDate := -99999; for j := i-1 to Datastore.Resource.Schedule.EventCount-1 do begin event := Datastore.Resource.Schedule.GetEvent(j); if event.RepeatCode = rtNone then begin d := DatePart(event.EndTime); if d > ALastDate then ALastDate := d; end; end; end; // To do: handle recurring events end; function TVpGanttView.GetEventOfRow(ARow: Integer): TVpEvent; begin Result := EventRecords[ARow]^.Event; end; function TVpGanttView.GetEventRec(AIndex: Integer): PVpGanttEventRec; begin Result := FEventRecords[AIndex]; end; function TVpGanttView.GetHourRec(AIndex: Integer): TVpGanttHourRec; begin Result := FHourRecords[AIndex]; end; function TVpGanttView.GetMonthRec(AIndex: Integer): TVpGanttMonthRec; begin Result := FMonthRecords[AIndex]; end; { Determines the number of days between the first and last Gantt event. This is the number of day columns in the view. } function TVpGanttView.GetNumDays: Integer; begin Result := 0; if ValidDate(FRealStartDate) and ValidDate(FRealEndDate) then begin Result := trunc(FRealEndDate) - trunc(FRealStartDate) + 1; if Result < 0 then Result := 0; end; end; { Determines the number of events (= rows) to be displayed in the GanttView. } function TVpGanttView.GetNumEvents: Integer; begin if FEventRecords <> nil then Result := FEventRecords.Count else Result := 0; end; { Determines the number of hours between the first and last Gantt event. This is the number of hour columns in the view. } function TVpGanttView.GetNumHours: Integer; begin Result := GetNumDays * HoursPerDay; end; { Determines the number of months (complete or partial) between the first and last Gantt event. } function TVpGanttView.GetNumMonths: Integer; var y1, m1, d1: Word; y2, m2, d2: Word; begin if ValidDate(FRealStartDate) and ValidDate(FRealEndDate) then begin DecodeDate(FRealStartDate, y1, m1, d1); DecodeDate(FRealEndDate, y2, m2, d2); if (y1 = y2) then Result := m2 - m1 + 1 else Result := 13 - m1 + m2 + (y2 - y1 - 1)*12; end else Result := 0; end; { Determines the number of weeks (complete or partial) between the first and last Gantt events. NOTE: Week calculations are based on ISO week numbers only! } function TVpGanttView.GetNumWeeks: Integer; var d1, d2: TVpDayType; dt1, dt2: TDate; wn1, wn2: Integer; begin if ValidDate(FRealStartDate) and ValidDate(FRealEndDate) then begin d1 := GetVpDayType(FRealStartDate); d2 := GetVpDayType(FRealEndDate); if (FRealEndDate - FRealStartDate < 7) then begin wn1 := WeekOfTheYear(FRealStartDate); wn2 := WeekOfTheYear(FRealEndDate); if wn1 = wn2 then Result := 1 else Result := 2; exit; end; if d1 = dtMonday then begin // No partial week at start Result := 0; dt1 := FRealStartDate; end else begin // Partial week at start Result := 1; dt1 := StartOfTheWeek(FRealStartDate) + 7; // Start of next week end; if d2 = dtSunday then // No partial week at end dt2 := FRealEndDate else begin // Partial week at the end Inc(Result); dt2 := StartOfTheWeek(FRealEndDate) - 1; end; Result := Result + (trunc(dt2) - trunc(dt1) + 1) div 7; end else Result := 0; end; { Calculates the first and last date to be displayed in the GanttView. This is necessary because the properties StartDate and EndDate may be 0 which means the very first/last event. } procedure TVpGanttView.GetRealEventDateRange(out AStartDate, AEndDate: TDate); begin if ValidDate(FStartDate) then AStartDate := DatePart(FStartDate) else AStartDate := FFirstDate; if ValidDate(FEndDate) then AEndDate := DatePart(FEndDate) else AEndDate := FLastDate; end; function TVpGanttView.GetRowAtCoord(Y: Integer): Integer; begin Result := (Y - FTotalColHeaderHeight) div FRowHeight + FTopRow; end; function TVpGanttView.GetRowOfEvent(AEvent: TVpEvent): Integer; var i: Integer; eventRec: PVpGanttEventRec; found: Boolean; begin for i := 0 to FEventRecords.Count-1 do begin eventRec := FEventRecords[i]; if (eventRec^.Event = AEvent) then begin if AEvent.RepeatCode = rtNone then found := true else found := (DatePart(eventRec^.StartTime) <= FActiveDate) and (DatePart(eventRec^.EndTime) >= FActiveDate); if found then begin Result := i; exit; end; end; end; Result := -1; end; function TVpGanttView.GetWeekRec(AIndex: Integer): TVpGanttWeekRec; begin Result := FWeekRecords[AIndex]; end; { If the component is being dropped on a form at designtime, then automatically hook up to the first datastore component found. } procedure TVpGanttView.HookUp; var I: Integer; begin 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; function TVpGanttView.HourMode: Boolean; begin Result := (gchHour in FColHeaderAttributes.Visible); end; function TVpGanttView.HoursPerDay: Integer; begin Result := ord(FEndHour) - ord(FStartHour) + 1; end; procedure TVpGanttView.Init; begin CalcRowHeight; CalcColHeaderHeight; GetEventDateRange(FFirstDate, FLastDate); GetRealEventDateRange(FRealStartDate, FRealEndDate); if HourMode then FColCount := GetNumHours else FColCount := GetNumDays; FRowCount := GetNumEvents; PopulateHourRecords; PopulateDayRecords; PopulateWeekRecords; PopulateMonthRecords; PopulateEventRecords; end; { Checks whether the specified date belongs to the specified event. The function returns true if the event begins before or at the date and ends at or after it. } function TVpGanttView.IsEventOnDate(AEvent: TVpEvent; ADate: TDate): Boolean; var dEv1, dEv2: TDate; begin if AEvent <> nil then begin dEv1 := DatePart(AEvent.StartTime); dEv2 := DatePart(AEvent.EndTime); Result := (dEv1 <= ADate) and (ADate <= dEv2); end else Result := false; end; function TVpGanttView.IsHoliday(ADate: TDate; out AHolidayName: String): Boolean; begin AHolidayName := ''; if Assigned(FOnHoliday) then begin FOnHoliday(Self, ADate, AHolidayName); Result := AHolidayName <> ''; end else if Assigned(FControlLink) then Result := FControlLink.IsHoliday(ADate, AHolidayName); end; procedure TVpGanttView.KeyDown(var Key: Word; Shift: TShiftState); procedure ScrollCols(ADelta: Integer); begin SetActiveCol(FActiveCol + ADelta); if FActiveCol <= FLeftCol then ScrollHorizontal(FActiveCol - FLeftCol) else if FActiveCol >= FLeftCol + FVisibleCols then ScrollHorizontal(FActiveCol - (FLeftCol + FVisibleCols) + 1); end; procedure ScrollRows(ADelta: Integer); begin FActiveRow := FActiveRow + ADelta; if FActiveRow < 0 then FActiveRow := 0; if FActiveRow >= RowCount then FActiveRow := RowCount-1; // SetActiveRow(FActiveRow + ADelta); if FActiveRow <= FTopRow then ScrollVertical(FActiveRow - FTopRow) else if FActiveRow >= FTopRow + FVisibleRows then ScrollVertical(FActiveRow - (FTopRow + FVisibleRows) + 1); SetActiveRow(FActiveRow); end; var P: TPoint; OneDay: Integer; c: Integer; begin inherited; if HourMode then OneDay := HoursPerDay else OneDay := 1; case Key of VK_LEFT: ScrollCols(-OneDay); VK_RIGHT: ScrollCols(OneDay); VK_DOWN: ScrollRows(1); VK_UP: ScrollRows(-1); VK_HOME: if Shift = [ssCtrl] then begin ActiveCol := 0; FLeftCol := 0; end else if Shift = [ssCtrl, ssShift] then begin ActiveCol := 0; ActiveRow := 0; FLeftCol := 0; FTopRow := 0; end else if Shift = [] then ScrollCols(-FVisibleCols); VK_END: if Shift = [ssCtrl] then begin ActiveCol := ColCount-1; ScrollHorizontal(FLeftCol + FVisibleCols); end else if Shift = [ssCtrl, ssShift] then begin ActiveCol := ColCount-1; ActiveRow := RowCount-1; FLeftCol := ColCount - FVisibleCols; if FLeftCol < 0 then FLeftCol := 0; FTopRow := RowCount - FVisibleRows; if FTopRow < 0 then FTopRow := 0; end else ScrollCols(FVisibleCols); VK_NEXT: if Shift = [ssCtrl] then // ctrl + page down ScrollRows(FRowCount) else ScrollRows(FVisibleRows); // page down VK_PRIOR: if Shift = [ssCtrl] then // ctrl + page up ScrollRows(-FRowCount) else ScrollRows(-FVisibleRows); // page up VK_F10, VK_APPS: if (ssShift in Shift) then begin P := GetClientOrigin; if HourMode then begin P.X := P.X + FHourRecords[FActiveCol].Rect.Right; P.Y := P.Y + FHourRecords[FActiveCol].Rect.Top; end else begin P.X := P.X + FDayRecords[FActiveCol].Rect.Right; P.Y := P.Y + FDayRecords[FActiveCol].Rect.Top; end; PopupMenu.Popup(P.X + 10, P.Y + 10); end; VK_RETURN: PopupEditEvent(Self); VK_INSERT: PopupAddEvent(Self); VK_DELETE: DeleteActiveEvent(true); else exit; end; Invalidate; Key := 0; end; function TVpGanttView.IsStoredColWidth: Boolean; begin Result := FColWidth <> DEFAULT_COLWIDTH; end; function TVpGanttView.IsStoredDateFormat(AIndex: Integer): Boolean; begin case AIndex of 0: Result := FDateFormat[0] <> DEFAULT_DAYFORMAT; 1: Result := FDateFormat[1] <> DEFAULT_MONTHFORMAT; 2: Result := FDateFormat[2] <> DEFAULT_MONTHFORMAT_SHORT; 3: Result := FDateFormat[3] <> DEFAULT_DAYFORMAT_HOURMODE; end; end; function TVpGanttView.IsStoredEndHour: Boolean; begin Result := FEndHour <> DEFAULT_END_HOUR; end; function TVpGanttView.IsStoredStartHour: Boolean; begin Result := FStartHour <> DEFAULT_START_HOUR; end; procedure TVpGanttView.LoadLanguage; var item: TMenuItem; begin for item in FDefaultPopup.Items do if item is TVpMenuItem then TVpMenuItem(item).Translate; end; procedure TVpGanttView.LinkHandler(Sender: TComponent; NotificationType: TVpNotificationType; const Value: Variant); begin FInLinkHandler := true; try case NotificationType of neDateChange : SetActiveDate(Value); neDataStoreChange : Invalidate; neInvalidate : Invalidate; end; finally FInLinkHandler := false; end; end; procedure TVpGanttView.Loaded; begin inherited; FLoaded := true; Populate; end; procedure TVpGanttView.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var dt: TDateTime; begin inherited MouseDown(Button, Shift, X, Y); if not Focused then SetFocus; FMouseDownPoint := Point(X, Y); FActiveCol := GetColAtCoord(X); FActiveRow := GetRowAtCoord(Y); SetActiveEvent(GetEventAtCoord(X, Y)); dt := GetDateTimeAtCoord(X); if dt <> NO_DATE then SetActiveDate(dt); Invalidate; end; procedure TVpGanttView.MouseEnter; begin FMouseEvent := nil; end; procedure TVpGanttView.MouseLeave; begin HideHintWindow; end; procedure TVpGanttView.MouseMove(Shift: TShiftState; X, Y: Integer); var event: TVpEvent; begin inherited MouseMove(Shift, X, Y); if ShowHint then begin event := GetEventAtCoord(X, Y); if event = nil then HideHintWindow else if FMouseEvent <> event then begin ShowHintWindow(Point(X, Y), event); FMouseEvent := event; end; end; end; procedure TVpGanttView.Paint; begin RenderToCanvas( Canvas, // Paint Canvas Rect(0, 0, Width, Height), // Paint Rectangle ra0, // Rotation angle: none 1, // Scale FActiveDate, // Date -1, // Start At -1, // End At gr30Min, // Granularity False // Display Only ); SetVScrollPos; SetHScrollPos; end; procedure TVpGanttView.Populate; begin if DataStore <> nil then DataStore.Date := FActiveDate; end; // Populates the array of TVpGanttRec records containing the date of each day // cell and the *unscrolled* cell rectangle coordinates. procedure TVpGanttView.PopulateDayRecords; var i: Integer; x1, y1, x2, y2: Integer; begin SetLength(FDayRecords, GetNumDays); x1 := FixedColWidth; y1 := 0; if (gchMonth in FColHeaderAttributes.Visible) then inc(y1, FMonthColHeaderHeight + FTextMargin); if (gchWeek in FColHeaderAttributes.Visible) then inc(y1, FWeekColHeaderHeight + FTextMargin); if (gchHour in FColHeaderAttributes.Visible) then y2 := y1 + FDayColHeaderHeight + FTextMargin else y2 := FTotalColHeaderHeight; for i := 0 to High(FDayRecords) do begin x2 := x1 + CalcDaysWidth(1); FDayRecords[i].Rect := Rect(x1, y1, x2, y2); FDayRecords[i].Date := FRealStartDate + i; x1 := x2; end; end; procedure TVpGanttView.PopulateEventRecords; var event: TVpEvent; eventRec: PVpGanttEventRec; i: Integer; xh1, xh2, y1, xe1, xe2, y2: Integer; t1, t2: TDateTime; startHr, endHr: TDateTime; dayWidth, totalWidth: Integer; dayFactor, hourFactor: Double; begin if (Datastore = nil) or (DataStore.Resource = nil) then exit; // The EventRecords list is supposed to collect all events displayed by the // GanttView. FEventRecords.Free; FEventRecords := TVpGanttEventList.Create(FRealStartDate, FRealEndDate); // Consider only events which are, fully or partly, inside the // displayed date range between FRealStartDate and FRealEndDate for i := 0 to Datastore.Resource.Schedule.EventCount-1 do begin event := Datastore.Resource.Schedule.GetEvent(i); if event.RepeatCode <> rtNone then FEventRecords.AddRecurringEvents(event) else begin if DatePart(event.EndTime) < FRealStartDate then continue; if DatePart(event.StartTime) > FRealEndDate then continue; FEventRecords.AddSingleEvent(event); end; end; // Sort events by date/time - this is a general requirement for Gantt FEventRecords.Sort(@CompareEventRecs); // Iterate over all considered events, fill the event record and store it // in the array xh1 := 0; xh2 := FixedColWidth; y1 := FTotalColHeaderHeight; totalWidth := CalcDaysWidth(GetNumDays); dayWidth := CalcDaysWidth(1); startHr := ord(FStartHour) / 24; endHr := (ord(FEndHour) + 1) / 24; // extend to the end of the endhour box dayFactor := totalWidth / GetNumDays; hourFactor := dayWidth / HoursPerDay * 24; for i := 0 to FEventRecords.Count-1 do begin eventRec := FEventRecords[i]; t1 := eventRec^.StartTime; t2 := eventRec^.EndTime; // Store event rectangle coordinates in the EventRec y2 := y1 + FRowHeight; if HourMode then begin // Visible beginning of day at which the event starts xe1 := round((DatePart(t1) - FRealStartDate) * dayFactor) + FixedColWidth; // Add time part if event starts after FStartHour if TimePart(t1) >= startHr then xe1 := xe1 + round((TimePart(t1) - startHr) * hourFactor); // Visible beginning of day at which the event ends xe2 := round((DatePart(t2) - FRealStartDate) * dayFactor) + FixedColWidth; // Add time part of event end, clipped at end of EndHour. if TimePart(t2) <= endHr then xe2 := xe2 + round((TimePart(t2) - startHr) * hourFactor) else xe2 := xe2 + round((endHr - startHr) * hourFactor); end else begin xe1 := round((t1 - FRealStartDate) / numDays * totalWidth) + FixedColWidth; xe2 := round((t2 - FRealStartDate) / numDays * totalWidth) + FixedColWidth; end; if xe1 = xe2 then xe2 := xe1 + 1; eventRec^.HeadRect := Rect(xh1, y1, xh2, y2); eventRec^.EventRect := Rect(xe1, y1, xe2, y2); // Find the active row. This is the row with the active event. if eventRec^.Event = FActiveEvent then begin if FActiveEvent.RepeatCode = rtNone then FActiveRow := i else if (DatePart(eventRec^.StartTime) <= FActiveDate) and (DatePart(eventRec^.EndTime) >= FActiveDate) then FActiveRow := i; end; // Prepare for next row y1 := y2; end; end; // Populates the array of TVpGanttRec records containing the hours of each day // cell and the *unscrolled* cell rectangle coordinates. procedure TVpGanttView.PopulateHourRecords; var i: Integer; x1, y1, x2, y2: Integer; divRes: Integer = 0; modRes: Integer = 0; begin SetLength(FHourRecords, GetNumHours); x1 := FixedColWidth; y1 := 0; if (gchMonth in FColHeaderAttributes.Visible) then inc(y1, FMonthColHeaderHeight + FTextMargin); if (gchWeek in FColHeaderAttributes.Visible) then inc(y1, FWeekColHeaderHeight + FTextMargin); if (gchDay in FColHeaderAttributes.Visible) then inc(y1, FDayColHeaderHeight + FTextMargin); y2 := FTotalColHeaderHeight; for i := 0 to High(FHourRecords) do begin x2 := x1 + ColWidth; FHourRecords[i].Rect := Rect(x1, y1, x2, y2); DivMod(i, HoursPerDay, divRes, modRes); FHourRecords[i].Date := FRealStartDate + divRes; FHourRecords[i].Hour := ord(FStartHour) + modRes; x1 := x2; end; end; procedure TVpGanttView.PopulateMonthRecords; var i, n: Integer; x1, y1, x2, y2: Integer; dm: TDateTime; ndays: Integer; begin n := GetNumMonths; SetLength(FMonthRecords, n); if (Datastore = nil) or (Datastore.Resource = nil) then exit; if not (gchMonth in FColHeaderAttributes.Visible) then exit; x1 := FixedColWidth; y1 := 0; if [gchWeek, gchDay] * FColHeaderAttributes.Visible = [gchWeek, gchDay] then y2 := FMonthColHeaderHeight + FTextMargin else y2 := FTotalColHeaderHeight; if n > 1 then begin // Date interval crosses one or more month boundaries dm := FRealStartDate; for i := 0 to n - 1 do begin if i = 0 then begin nDays := DaysInMonth(dm) - DayOf(dm) + 1; dm := StartOfTheMonth(dm); end else if i = n-1 then nDays := DayOf(FRealEndDate) else nDays := DaysInMonth(dm); if dm + nDays > FRealEndDate then nDays := trunc(FRealEndDate) - trunc(dm) + 1; x2 := x1 + CalcDaysWidth(nDays); FMonthRecords[i].Rect := Rect(x1, y1, x2, y2); FMonthRecords[i].Date := dm; dm := IncMonth(dm, 1); x1 := x2; end; end else begin // Date interval is within the same month nDays := DayOf(FRealEndDate) - DayOf(FRealStartDate) + 1; x2 := x1 + CalcDaysWidth(nDays); FMonthRecords[0].Rect := Rect(x1, y1, x2, y2); FMonthRecords[0].Date := FRealStartDate; end; end; procedure TVpGanttView.PopulateWeekRecords; var i: Integer; x1, y1, x2, y2: Integer; d: TVpDayType; dt1, dt2: TDateTime; begin if not (gchWeek in FColHeaderAttributes.Visible) then begin SetLength(FWeekRecords, 0); exit; end; SetLength(FWeekRecords, GetNumWeeks); if Length(FWeekRecords) = 0 then exit; x1 := FixedColWidth; y1 := 0; if (gchMonth in FColHeaderAttributes.Visible) then inc(y1, FMonthColHeaderHeight + FTextMargin); if (gchDay in FColHeaderAttributes.Visible) then y2 := y1 + FWeekColHeaderHeight + FTextMargin else y2 := FTotalColHeaderHeight; d := GetVpDayType(FRealStartDate); dt1 := FRealStartDate; if d = dtMonday then dt2 := dt1 + 6 else dt2 := StartOfTheWeek(FRealStartDate + 7) - 1; if dt2 > FRealEndDate then dt2 := FRealEndDate; x2 := x1 + CalcDaysWidth(trunc(dt2) - trunc(dt1) + 1); FWeekRecords[0].Rect := Rect(x1, y1, x2, y2); FWeekRecords[0].Date := dt1; FWeekRecords[0].WeekNo := WeekOfTheYear(dt1); for i := 1 to High(FWeekRecords) do begin dt1 := dt2 + 1; dt2 := Min(dt1 + 6, FRealEndDate); x1 := x2; x2 := x1 + CalcDaysWidth(trunc(dt2) - trunc(dt1) + 1); FWeekRecords[i].Rect := Rect(x1, y1, x2, y2); FWeekRecords[i].Date := dt1; FWeekRecords[i].WeekNo := WeekOfTheYear(dt1); end; end; procedure TVpGanttView.RenderToCanvas(RenderCanvas: TCanvas; RenderIn: TRect; Angle: TVpRotationAngle; Scale: Extended; RenderDate: TDateTime; StartLine, StopLine: Integer; UseGran: TVpGranularity; DisplayOnly: Boolean); var painter: TVpGanttViewPainter; begin FPainting := true; painter := TVpGanttViewPainter.Create(Self, RenderCanvas); try painter.RenderToCanvas(RenderIn, Angle, Scale, RenderDate, StartLine, StopLine, UseGran, DisplayOnly); finally painter.Free; FPainting := false; end; end; procedure TVpGanttView.SetDateLimits(AStartDate, AEndDate: TDateTime); var oldDate: TDateTime; begin oldDate := FActiveDate; FStartDate := AStartDate; FEndDate := AEndDate; Init; FActiveDate := 0; SetActiveDate(oldDate); end; {$IF VP_LCL_SCALING = 2} procedure TVpGanttView.FixDesignFontsPPI(const ADesignTimePPI: Integer); begin inherited; DoFixDesignFontPPI(ColHeaderAttributes.MonthFont, ADesignTimePPI); DoFixDesignFontPPI(ColHeaderAttributes.WeekFont, ADesignTimePPI); DoFixDesignFontPPI(ColHeaderAttributes.DayFont, ADesignTimePPI); DoFixDesignFontPPI(ColHeaderAttributes.HourFont, ADesignTimePPI); DoFixDesignFontPPI(RowHeaderAttributes.EventFont, ADesignTimePPI); end; procedure TVpGanttView.ScaleFontsPPI(const AToPPI: Integer; const AProportion: Double); begin inherited; DoScaleFontPPI(ColHeaderAttributes.MonthFont, AToPPI, AProportion); DoScaleFontPPI(ColHeaderAttributes.WeekFont, AToPPI, AProportion); DoScaleFontPPI(ColHeaderAttributes.DayFont, AToPPI, AProportion); DoScaleFontPPI(ColHeaderAttributes.HourFont, AToPPI, AProportion); DoScaleFontPPI(RowHeaderAttributes.EventFont, AToPPI, AProportion); end; {$ELSEIF VP_LCL_SCALING = 1} procedure TVpGantView.ScaleFontsPPI(const AProportion: Double); begin inherited; DoScaleFontPPI(ColHeaderAttributes.MonthFont, AProportion); DoScaleFontPPI(ColHeaderAttributes.WeekFont, AProportion); DoScaleFontPPI(ColHeaderAttributes.DayFont, AProportion); DoScaleFontPPI(ColHeaderAttributes.HourFont, AProportion); DoScaleFontPPI(RowHeadAttributes.EventFont, AProportion); end; {$ENDIF} procedure TVpGanttView.ScrollDateIntoView(ADate: TDateTime); var nCols: Integer; begin if (FRealStartDate = 0) or (FRealStartDate = NO_DATE) then exit; if HourMode then nCols := GetNumHours else nCols := GetNumDays; if ADate < FRealStartDate then begin FRealStartDate := DatePart(ADate); FColCount := nCols; SetLeftCol(-MaxInt); end else if ADate > FRealEndDate then begin FRealEndDate := DatePart(ADate); FColCount := nCols; SetLeftCol(FColCount - 1 - FVisibleCols); end else if ADate < FRealStartDate + FLeftCol then begin if HourMode then SetLeftCol((trunc(ADate) - trunc(FRealStartDate))*HoursPerDay) else SetLeftCol(trunc(ADate) - trunc(FRealStartDate)); end else if ADate > FRealStartDate + FVisibleCols then begin if HourMode then SetLeftCol(trunc(ADate*HoursPerDay) - FVisibleCols) else SetLeftCol(trunc(ADate) - FVisibleCols); end else exit; Invalidate; end; procedure TVpGanttView.ScrollHorizontal(ANumCols: Integer); begin SetLeftCol(FLeftCol + ANumCols); Invalidate; end; procedure TVpGanttView.ScrollRowIntoView(ARow: Integer); begin if (ARow < TopRow) or (ARow >= TopRow + FVisibleRows) then SetTopRow(ARow - FVisibleRows div 2) end; procedure TVpGanttView.ScrollVertical(ANumRows: Integer); begin SetTopRow(FTopRow + ANumRows); Invalidate; end; procedure TVpGanttView.SetActiveCol(AValue: Integer); var R: TRect = (Left:0; Top:0; Right:0; Bottom:0); eventRect, dayRect: TRect; dt: TDateTime; event: TVpEvent; c: Integer; begin if AValue <= 0 then FActiveCol := 0 else if AValue >= ColCount then FActiveCol := ColCount - 1 else FActiveCol := AValue; c := ColToDateIndex(FActiveCol); dt := DayRecords[c].Date; dayRect := DayRecords[c].Rect; event := EventRecords[FActiveRow]^.Event; eventRect := EventRecords[FActiveRow]^.EventRect; dayRect.Top := eventRect.Top; dayRect.Bottom := eventRect.Bottom; if IntersectRect(R, dayRect, eventRect) then SetActiveEvent(event) else SetActiveEvent(nil); SetActiveDate(dt); end; procedure TVpGanttView.SetActiveDate(AValue: TDateTime); var days: Integer; begin if FColHeaderAttributes = nil then // Needed for HourMode exit; if FActiveDate <> DatePart(AValue) then begin FActiveDate := DatePart(AValue); if FLoaded then Populate; ScrollDateIntoView(FActiveDate); days := trunc(FActiveDate) - trunc(FRealStartDate); if HourMode then FActiveCol := days * HoursPerDay else FActiveCol := days; Invalidate; if (not FInLinkHandler) and (ControlLink <> nil) then ControlLink.Notify(self, neDateChange, FActiveDate); end; end; procedure TVpGanttView.SetActiveEvent(AValue: TVpEvent); begin if FActiveEvent <> AValue then begin FActiveEvent := AValue; if FActiveEvent <> nil then begin FActiveRow := GetRowOfEvent(FActiveEvent); ScrollRowIntoView(FActiveRow); end; end; UpdatePopupMenuState; end; procedure TVpGanttView.SetActiveRow(AValue: Integer); var R: TRect = (Left:0; Top:0; Right:0; Bottom:0); eventRect, dayRect: TRect; event: TVpEvent; dt: TDateTime; c: Integer; begin if AValue < 0 then FActiveRow := 0 else if AValue >= RowCount then FActiveRow := RowCount - 1 else FActiveRow := AValue; event := EventRecords[FActiveRow]^.Event; eventRect := EventRecords[FActiveRow]^.EventRect; c := ColToDateIndex(FActiveCol); dt := DayRecords[c].Date; dayRect := DayRecords[c].Rect; dayRect.Top := eventRect.Top; dayRect.Bottom := eventRect.Bottom; if IntersectRect(R, dayRect, eventRect) then SetActiveEvent(event) else SetActiveEvent(nil); SetActiveDate(dt); end; procedure TVpGanttView.SetColor(Value: TColor); begin if FColor <> Value then begin FColor := Value; Invalidate; end; end; procedure TVpGanttView.SetColWidth(AValue: Integer); begin if FColWidth <> AValue then begin FColWidth := AValue; Invalidate; end; end; procedure TVpGanttView.SetDateFormat(AIndex: Integer; AValue: String); begin if FDateFormat[AIndex] <> AValue then begin FDateFormat[AIndex] := AValue; Invalidate; end; end; procedure TVpGanttView.SetDrawingStyle(AValue: TVpDrawingStyle); begin if FDrawingStyle <> AValue then begin FDrawingStyle := AValue; Invalidate; end; end; procedure TVpGanttView.SetEndHour(AValue: TVpHours); begin if FEndHour <> AValue then begin FEndHour := AValue; Invalidate; end; end; procedure TVpGanttView.SetFixedColWidth(AValue: Integer); begin if FFixedColWidth <> AValue then begin FFixedColWidth := AValue; Invalidate; end; end; procedure TVpGanttView.SetHolidayColor(AValue: TColor); begin if FHolidayColor <> AValue then begin FHolidayColor := AValue; Invalidate; end; end; procedure TVpGanttView.SetHScrollPos; var scrollInfo: TScrollInfo; begin if not HandleAllocated then Exit; with scrollInfo do begin cbSize := SizeOf(scrollInfo); fMask := SIF_RANGE or SIF_PAGE or SIF_POS; nMin := 0; nMax := FColCount; if FVisibleCols >= FColCount then nPage := nMax else nPage := FVisibleCols; if FLeftCol = pred(ColCount) - VisibleCols then nPos := ColCount else nPos := FLeftCol; nTrackPos := nPos; end; SetScrollInfo(Handle, SB_HORZ, scrollInfo, True); end; procedure TVpGanttView.SetLeftCol(AValue: Integer); begin if AValue <> FLeftCol then begin if AValue + FVisibleCols >= FColCount then begin FLeftCol := FColCount - FVisibleCols; if FLeftCol < 0 then FLeftCol := 0; // Prevent the control from hanging at the right if (AValue < FLeftCol) and (AValue > 0) then FLeftCol := AValue; end else if AValue < 0 then FLeftCol := 0 else FLeftCol := AValue; Invalidate; SetHScrollPos; end; end; procedure TVpGanttView.SetLineColor(AValue: TColor); begin if FLineColor <> AValue then begin FLineColor := AValue; Repaint; end; end; procedure TVpGanttView.SetOptions(AValue: TVpGanttViewOptions); begin if FOptions <> AValue then begin FOptions := AValue; Invalidate; end; end; procedure TVpGanttView.SetSpecialDayMode(AValue: TVpGanttSpecialDayMode); begin if FSpecialDayMode <> AValue then begin FSpecialDayMode := AValue; Invalidate; end; end; procedure TVpGanttView.SetStartHour(AValue: TVpHours); begin if FStartHour <> AValue then begin FStartHour := AValue; Invalidate; end; end; procedure TVpGanttView.SetTextMargin(AValue: Integer); begin if FTextMargin <> AValue then begin FTextMargin := AValue; Invalidate; end; end; procedure TVpGanttView.SetTopRow(AValue: Integer); begin if AValue <> FTopRow then begin if AValue + FVisibleRows >= RowCount then begin FTopRow := FRowCount - FVisibleRows; if FTopRow < 0 then FTopRow := 0; // Prevent the control from hanging at the bottom if (AValue < FTopRow) and (AValue > 0) then FTopRow := AValue; end else if AValue < 0 then FTopRow := 0 else FTopRow:= AValue; Invalidate; SetVScrollPos; end; end; procedure TVpGanttView.SetVScrollPos; var scrollInfo: TScrollInfo; begin if not HandleAllocated then Exit; with scrollInfo do begin cbSize := SizeOf(scrollInfo); fMask := SIF_RANGE or SIF_PAGE or SIF_POS; nMin := 0; nMax := FRowCount; if FVisibleRows >= FRowCount then nPage := nMax else nPage := FVisibleRows; if FTopRow = pred(RowCount) - VisibleRows then nPos := FRowCount else nPos := FTopRow; nTrackPos := nPos; end; SetScrollInfo(Handle, SB_VERT, scrollInfo, True); end; procedure TVpGanttView.SetWeekendColor(AValue: TColor); begin if FWeekendColor <> AValue then begin FWeekendColor := AValue; Invalidate; end; end; procedure TVpGanttView.SetWeekStartsOn(Value: TVpDayType); begin if FWeekStartsOn <> Value then begin FWeekStartsOn := Value; Invalidate; end; end; procedure TVpGanttView.SpawnEventEditDialog(IsNewEvent: Boolean); var AllowIt: Boolean; EventDlg : TVpEventEditDialog; begin if (DataStore = nil) or (DataStore.Resource = nil) or ReadOnly then Exit; AllowIt := false; if Assigned(FOwnerEditEvent) then FOwnerEditEvent(self, FActiveEvent, IsNewEvent, DataStore.Resource, AllowIt) else begin EventDlg := TVpEventEditDialog.Create(nil); try EventDlg.DataStore := DataStore; AllowIt := EventDlg.Execute(FActiveEvent); finally EventDlg.Free; end; end; if AllowIt then begin FActiveEvent.Changed := true; DataStore.PostEvents; // The new or edited event may be at a different position in the grid. // --> Re-read the events to sort them, find the new active row/col and // scroll them into view PopulateEventRecords; SetActiveDate(FActiveEvent.StartTime); ScrollRowIntoView(FActiveRow); if IsNewEvent and Assigned(FOnAddEvent) then FOnAddEvent(self, FActiveEvent); if not IsNewEvent and Assigned(FOnModifyEvent) then FOnModifyEvent(self, FActiveEvent); end else begin if IsNewEvent then begin FActiveEvent.Deleted := true; DataStore.PostEvents; SetActiveEvent(nil); end; end; Invalidate; end; procedure TVpGanttView.WMHScroll(var Msg: TLMHScroll); begin case Msg.ScrollCode of SB_LINELEFT : ScrollHorizontal(-1); SB_LINERIGHT : ScrollHorizontal(1); SB_PAGELEFT : ScrollHorizontal(-FVisibleCols); SB_PAGERIGHT : ScrollHorizontal(FVisibleCols); SB_THUMBPOSITION, SB_THUMBTRACK : SetLeftCol(Msg.Pos); end; end; procedure TVpGanttView.WMVScroll(var Msg: TLMVScroll); begin case Msg.ScrollCode of SB_LINEUP : ScrollVertical(-1); SB_LINEDOWN : ScrollVertical(1); SB_PAGEUP : ScrollVertical(-FVisibleRows); SB_PAGEDOWN : ScrollVertical(FVisibleRows); SB_THUMBPOSITION, SB_THUMBTRACK : SetTopRow(Msg.Pos); end; end; { Hint support } procedure TVpGanttView.ShowHintWindow(APoint: TPoint; AEvent: TVpEvent); var txt: String; begin HideHintWindow; case FHintMode of hmPlannerHint: begin if (AEvent = nil) or (Datastore = nil) or (Datastore.Resource = nil) then exit; txt := BuildEventString(AEvent, true); end; hmComponentHint: txt := FComponentHint; end; if (txt <> '') and not (csDesigning in ComponentState) then begin Hint := txt; Application.Hint := Hint; Application.ActivateHint(ClientToScreen(APoint), true); end; end; procedure TVpGanttView.HideHintWindow; begin Application.CancelHint; end; procedure TVpGanttView.SetHint(const AValue: TTranslateString); begin inherited; if FHintMode = hmComponentHint then FComponentHint := AValue; end; procedure TVpGanttView.SetHintMode(const AValue: TVpHintMode); begin if AValue = FHintMode then exit; FHintMode := AValue; if FHintMode = hmPlannerHint then FComponentHint := Hint; end; { Popup menu } function TVpGanttView.GetPopupMenu: TPopupMenu; begin if FExternalPopup = nil then Result := FDefaultPopup else Result := FExternalPopup; end; procedure TVpGanttView.SetPopupMenu(AValue: TPopupMenu); begin if (AValue = nil) or (AValue = FDefaultPopup) then FExternalPopup := nil else FExternalPopup := AValue; end; procedure TVpGanttView.InitializeDefaultPopup; var NewItem: TVpMenuItem; canEdit: Boolean; begin canEdit := (FActiveEvent <> nil) and FActiveEvent.CanEdit; FDefaultPopup.Items.Clear; if RSPopupAddEvent <> '' then begin // Add NewItem := TVpMenuItem.Create(Self); NewItem.Kind := mikAddEvent; NewItem.OnClick := @PopupAddEvent; NewItem.Tag := 0; FDefaultPopup.Items.Add(NewItem); end; if RSPopupEditEvent <> '' then begin // Edit NewItem := TVpMenuItem.Create(Self); NewItem.Kind := mikEditEvent; NewItem.Enabled := canEdit; NewItem.OnClick := @PopupEditEvent; NewItem.Tag := 1; FDefaultPopup.Items.Add(NewItem); end; if RSPopupDeleteEvent <> '' then begin // Delete NewItem := TVpMenuItem.Create(Self); NewItem.Kind := mikDeleteEvent; NewItem.Enabled := canEdit; NewItem.OnClick := @PopupDeleteEvent; NewItem.Tag := 1; FDefaultPopup.Items.Add(NewItem); end; end; procedure TVpGanttView.PopupAddEvent(Sender: TObject); var startTime: TDateTime; endTime: TDateTime; begin if ReadOnly or (not CheckCreateResource) or (not Assigned(DataStore)) or (not Assigned(DataStore.Resource)) then Exit; // Create the new event as an all-day event for the clicked day. startTime := DatePart(FActiveDate); endTime := startTime + 1 - OneMilliSecond; FActiveEvent := DataStore.Resource.Schedule.AddEvent( DataStore.GetNextID(EventsTableName), StartTime, EndTime ); FActiveEvent.AllDayEvent := true; // Edit this new event SpawnEventEditDialog(True); end; procedure TVpGanttView.PopupDeleteEvent(Sender: TObject); begin if ReadOnly then Exit; Invalidate; if FActiveEvent <> nil then DeleteActiveEvent(True); end; procedure TVpGanttView.PopupEditEvent(Sender: TObject); begin if ReadOnly then Exit; Invalidate; if FActiveEvent <> nil then // edit this event SpawnEventEditDialog(false); end; procedure TVpGanttView.UpdatePopupMenuState; var i: Integer; begin if Assigned(FActiveEvent) then begin for i := 0 to FDefaultPopup.Items.Count - 1 do FDefaultPopup.Items[i].Enabled := True; end else for i := 0 to FDefaultPopup.Items.Count - 1 do if (FDefaultPopup.Items[i].Tag = 1) or (ReadOnly) then FDefaultPopup.Items[i].Enabled := False; end; end.