unit VpGanttView; {$mode objfpc}{$H+} interface uses 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_GANTTVIEWOPTIONS = [ gvoActiveDate, gvoHorizGrid, gvoVertGrid, gvoWeekends, gvoHolidays ]; type TVpGanttView = class; TVpGanttEventRec = record Event: TVpEvent; Caption: String; HeadRect: TRect; EventRect: TRect; end; TVpGanttDayRec = record 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; TVpGanttColHeaderAttributes = class(TVpGanttHeaderAttributes) private FDayFont: TVpFont; FMonthFont: TVpFont; procedure SetDayFont(AValue: TVpFont); procedure SetMonthFont(AValue: TVpFont); public constructor Create(AOwner: TVpGanttView); override; destructor Destroy; override; published property DayFont: TVpFont read FDayFont write SetDayFont; property MonthFont: TVpFont read FMonthFont write SetMonthFont; 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 FEndDate: TDateTime; // Date of the last event to be displayed/printed 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; FDayColHeaderHeight: Integer; FTotalColHeaderHeight: Integer; FTextMargin: Integer; FColor: TColor; FHolidayColor: TColor; FLineColor: TColor; FWeekendColor: TColor; FColHeaderAttributes: TVpGanttColHeaderAttributes; FRowHeaderAttributes: TVpGanttRowHeaderAttributes; FComponentHint: TTranslateString; FDateFormat: array[0..2] of String; FDrawingStyle: TVpDrawingStyle; FDefaultPopup: TPopupMenu; FExternalPopup: TPopupMenu; FHintMode: TVpHintMode; FMouseEvent: TVpEvent; FOptions: TVpGanttViewOptions; FSpecialDayMode: TVpGanttSpecialDayMode; FTimeFormat: TVpTimeFormat; FOnAddEvent: TVpOnAddNewEvent; FOnDeletingEvent: TVpOnDeletingEvent; FOnHoliday: TVpHolidayEvent; FOnModifyEvent: TVpOnModifyEvent; FOwnerEditEvent: TVpEditEvent; function GetDateFormat(AIndex: Integer): String; function GetDayRec(AIndex: Integer): TVpGanttDayRec; function GetEventRec(AIndex: Integer): TVpGanttEventRec; function GetMonthRec(AIndex: Integer): TVpGanttMonthRec; function GetNumDays: Integer; function GetNumEvents: Integer; function GetNumMonths: Integer; function IsStoredColWidth: Boolean; function IsStoredDateFormat(AIndex: Integer): 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 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 SetTextMargin(AValue: Integer); procedure SetTopRow(AValue: Integer); procedure SetWeekendColor(AValue: TColor); protected // Needed by the painter FEventRecords: array of TVpGanttEventRec; FDayRecords: array of TVpGanttDayRec; FMonthRecords: array of TVpGanttMonthRec; { internal methods } procedure CalcColHeaderHeight; procedure CalcRowHeight; 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; function GetRowAtCoord(Y: Integer): Integer; function GetRowOfEvent(AEvent: TVpEvent): Integer; procedure GetEventDateRange; function IsEventOnDate(AEvent: TVpEvent; ADate: TDateTime): Boolean; procedure Hookup; procedure Populate; procedure PopulateDayRecords; procedure PopulateEventRecords; procedure PopulateMonthRecords; 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; 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; {$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 to be called by painter function CalcVisibleCols(AWidth, AFixedColWidth, AColWidth: Integer): Integer; function CalcVisibleRows(AHeight, AHeaderHeight, ARowHeight: Integer): Integer; 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 FirstDate: TDateTime read FFirstDate; property LastDate: TDateTime read FLastDate; 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; property RowHeight: Integer read FRowHeight; property DayColHeaderHeight: Integer read FDayColHeaderHeight; property MonthColHeaderHeight: Integer read FMonthColHeaderHeight; property TotalColHeaderHeight: Integer read FTotalColHeaderHeight; property DayRecords[AIndex: Integer]: TVpGanttDayRec read GetDayRec; property EventRecords[AIndex: Integer]: TVpGanttEventRec read GetEventRec; property MonthRecords[AIndex: Integer]: TVpGanttMonthRec read GetMonthRec; property NumDays: Integer read GetNumDays; property NumEvents: Integer read GetNumEvents; property NumMonths: Integer read GetNumMonths; 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 DrawingStyle: TVpDrawingStyle read FDrawingStyle write SetDrawingStyle default ds3d; 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_GANTTVIEWOPTIONS; property PopupMenu: TPopupMenu read GetPopupMenu write SetPopupMenu; property RowHeaderAttributes: TVpGanttRowHeaderAttributes read FRowHeaderAttributes write FRowHeaderAttributes; property SpecialDayMode: TVpGanttSpecialDayMode read FSpecialDayMode write SetSpecialDayMode default sdmColumn; 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; // 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; 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_COLWIDTH = 20; {******************************************************************************} { 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); FDayFont := TVpFont.Create(AOwner); FMonthFont := TVpFont.Create(AOwner); end; destructor TVpGanttColHeaderAttributes.Destroy; begin FDayFont.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.SetMonthFont(AValue: TVpFont); begin if FMonthFont <> AValue then begin FMonthFont := AValue; FMonthFont.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; FRowHeaderAttributes := TVpGanttRowHeaderAttributes.Create(self); FColHeaderAttributes := TVpGanttColHeaderAttributes.Create(self); FDateFormat[0] := DEFAULT_DAYFORMAT; FDateFormat[1] := DEFAULT_MONTHFORMAT; FDateFormat[2] := DEFAULT_MONTHFORMAT_SHORT; FDrawingStyle := ds3d; FScrollBars := ssBoth; FOptions := DEFAULT_GANTTVIEWOPTIONS; // 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 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 trunc(AEvent.StartTime) = trunc(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 + 2 * FTextMargin; // 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 + FTextMargin; FTotalColHeaderHeight := FMonthColHeaderHeight + FDayColHeaderHeight; 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; 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; // dvClickTimer.Enabled := false; FMouseDown := false; //FDragging := 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; FActiveEvent := GetEventAtCoord(FMouseDownPoint.X, FMouseDownPoint.Y); if (FActiveEvent <> nil) then SpawnEventEditDialog(False) else begin dt := GetDateTimeAtCoord(FMouseDownPoint.X); if dt <> NO_DATE then begin startTime := trunc(dt); endTime := startTime + 1.0; ActiveEvent := Datastore.Resource.Schedule.AddEvent( Datastore.GetNextID(EventsTableName), startTime, endTime ); SpawnEventEditDialog(True); end; end; FMouseDownPoint := Point(0, 0); (* if (Msg.XPos > dvRowHeadWidth - 9) and (Msg.YPos > dvColHeadHeight) then begin { The mouse click landed inside the client area } dvSetActiveRowByCoord(Point(Msg.XPos, Msg.YPos), True); { See if we hit an active event } if (FActiveEvent <> nil) and (not ReadOnly) then begin { edit this event } dvSpawnEventEditDialog(False); end else if not ReadOnly then begin if not CheckCreateResource then Exit; if (DataStore = nil) or (DataStore.Resource = nil) then Exit; { otherwise, we must want to create a new event } StartTime := trunc(FDisplayDate + ActiveCol) + dvLineMatrix[ActiveCol, ActiveRow].Time; EndTime := StartTime + dvTimeIncSize * FRowLinesStep; FActiveEvent := DataStore.Resource.Schedule.AddEvent( DataStore.GetNextID(EventsTableName), StartTime, EndTime); { edit this new event } dvSpawnEventEditDialog(True); end; end; *) 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 (Length(FEventRecords) > 0) then begin VisibleRows := CalcVisibleRows(ClientHeight, FTotalColHeaderHeight, FRowHeight); emptyRows := VisibleRows - (Length(FEventRecords) - FTopRow); if emptyRows > 0 then ScrollVertical(-emptyRows); VisibleCols := CalcVisibleCols(ClientWidth, FFixedColWidth, FColWidth); emptyCols := VisibleCols - (Length(FDayRecords) - 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.GetDateOfCol(ACol: Integer): TDateTime; begin Result := FStartDate + ACol; end; function TVpGanttView.GetDateTimeAtCoord(X: Integer): TDateTime; var days: double; begin days := (X - FixedColWidth) / FColWidth + FLeftCol; if (days >= 0) and (days < NumDays) then Result := FStartDate + days else Result := NO_DATE; end; function TVpGanttView.GetDateFormat(AIndex: Integer): String; begin Result := FDateFormat[AIndex]; end; function TVpGanttView.GetDayRec(AIndex: Integer): TVpGanttDayRec; begin Result := FDayRecords[AIndex]; end; function TVpGanttView.GetEventAtCoord(X, Y: Integer): TVpEvent; var idx: Integer; eventRec: TVpGanttEventRec; dt: TDateTime; begin Result := nil; dt := GetDateTimeAtCoord(X); if (dt = -1) 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 < trunc(Result.StartTime)) or (dt > trunc(Result.EndTime) + 1) then Result := nil; end else if (dt < Result.StartTime) or (dt > Result.EndTime) then Result := nil; end; end; { Determines the date when the earliest event starts, and the date when the latest event ends. Stores them in the internal variables FStartdate and FEndDate. } procedure TVpGanttView.GetEventDateRange; var i: Integer; event: TVpEvent; d: TDateTime; begin if (Datastore = nil) or (Datastore.Resource = nil) or (Datastore.Resource.Schedule.EventCount = 0) then begin FFirstDate := NO_DATE; FLastDate := NO_DATE; end else begin event := Datastore.Resource.Schedule.GetEvent(0); FFirstDate := trunc(event.StartTime); FLastDate := -99999; for i := 0 to Datastore.Resource.Schedule.EventCount-1 do begin event := Datastore.Resource.Schedule.GetEvent(i); d := trunc(event.EndTime); if d > FLastDate then FLastDate := d; end; end; if FStartDate = 0 then FStartDate := FFirstDate; if FEndDate = 0 then FEndDate := FLastDate; end; function TVpGanttView.GetEventOfRow(ARow: Integer): TVpEvent; begin Result := EventRecords[ARow].Event; end; function TVpGanttView.GetEventRec(AIndex: Integer): TVpGanttEventRec; begin Result := FEventRecords[AIndex]; end; function TVpGanttView.GetMonthRec(AIndex: Integer): TVpGanttMonthRec; begin Result := FMonthRecords[AIndex]; end; { Determines the number days between the first and last Gantt event. This is the number of day columns in the view. } function TVpGanttView.GetNumDays: Integer; begin if (FStartDate <> NO_DATE) then Result := trunc(FEndDate) - trunc(FStartDate) + 1 else Result := 0; end; { Determines the number of events (= rows) to be displayed in the GanttView. } function TVpGanttView.GetNumEvents: Integer; begin if (Datastore <> nil) and (Datastore.Resource <> nil) then Result := Datastore.Resource.Schedule.EventCount else Result := 0; end; { Determines the number of months (complete or partial) between the first and last Gantt event. } function TVpGanttView.GetNumMonths: Integer; var dm1, dm2: Integer; y1, m1, d1: Word; y2, m2, d2: Word; begin if (FStartDate <> NO_DATE) then begin DecodeDate(FStartDate, y1, m1, d1); DecodeDate(FEndDate, 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; function TVpGanttView.GetRowAtCoord(Y: Integer): Integer; begin Result := (Y - FTotalColHeaderHeight) div FRowHeight + FTopRow; end; function TVpGanttView.GetRowOfEvent(AEvent: TVpEvent): Integer; var i: Integer; begin for i := 0 to High(FEventRecords) do if FEventRecords[i].Event = AEvent then begin Result := i; exit; end; Result := -1; 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; procedure TVpGanttView.Init; begin CalcRowHeight; CalcColHeaderHeight; GetEventDateRange; FColCount := GetNumDays; FRowCount := GetNumEvents; PopulateDayRecords; PopulateMonthRecords; PopulateEventRecords; end; function TVpGanttView.IsEventOnDate(AEvent: TVpEvent; ADate: TDateTime): Boolean; var tEv1, tEv2: TDateTime; begin if AEvent <> nil then begin tEv1 := trunc(AEvent.StartTime); tEv2 := trunc(AEvent.EndTime); Result := (tEv1 <= ADate) and (tEv2 >= ADate); end else Result := false; end; function TVpGanttView.IsHoliday(ADate: TDate; out AHolidayName: String): Boolean; begin AHolidayName := ''; if Assigned(FOnHoliday) then FOnHoliday(Self, ADate, AHolidayName); Result := 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 SetActiveRow(FActiveRow + ADelta); if FActiveRow <= FTopRow then ScrollVertical(FActiveRow - FTopRow) else if FActiveRow >= FTopRow + FVisibleRows then ScrollVertical(FActiveRow - (FTopRow + FVisibleRows) + 1); end; var P: TPoint; begin inherited; case Key of VK_LEFT: ScrollCols(-1); VK_RIGHT: ScrollCols(1); 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; FTopRow := RowCount - FVisibleRows; end else ScrollCols(FVisibleCols); VK_NEXT: if Shift = [ssCtrl] then // ctrl + page down begin ActiveRow := RowCount - 1; ScrollRows(MaxInt); end else ScrollRows(FVisibleRows); // page down VK_PRIOR: if Shift = [ssCtrl] then // ctrl + page up begin ActiveRow := 0; ScrollRows(-MaxInt); end else ScrollRows(-FVisibleRows); // page up VK_F10, VK_APPS: if (ssShift in Shift) then begin P := GetClientOrigin; P.X := P.X + FDayRecords[FActiveCol].Rect.Right; P.Y := P.Y + FDayRecords[FActiveCol].Rect.Top; 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; end; 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 FStartDate, // 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 := FMonthColHeaderHeight; y2 := FTotalColHeaderHeight; for i := 0 to High(FDayRecords) do begin x2 := x1 + ColWidth; FDayRecords[i].Rect := Rect(x1, y1, x2, y2); FDayRecords[i].Date := FStartDate + i; x1 := x2; end; end; procedure TVpGanttView.PopulateEventRecords; var event: TVpEvent; i: Integer; xh1, xh2, y1, xe1, xe2, y2: Integer; t1, t2: TDateTime; totalWidth: Integer; list: TFPList; begin SetLength(FEventRecords, GetNumEvents); if (Datastore = nil) or (DataStore.Resource = nil) then exit; list := TFPList.Create; try // Sort events by date/time for i := 0 to Datastore.Resource.Schedule.EventCount-1 do list.Add(Datastore.Resource.Schedule.GetEvent(i)); list.Sort(@CompareEvents); xh1 := 0; xh2 := FixedColWidth; y1 := FTotalColHeaderHeight; totalWidth := GetNumDays * ColWidth; for i := 0 to High(FEventRecords) do begin event := TVpEvent(list[i]); if event.AllDayEvent then begin t1 := trunc(event.StartTime); t2 := trunc(event.EndTime) + 1; if frac(event.EndTime) = 0 then t2 := t2 + 1; end else begin t1 := event.StartTime; t2 := event.EndTime; end; y2 := y1 + FRowHeight; xe1 := round((t1 - FStartDate) / numDays * totalWidth) + FixedColWidth; xe2 := round((t2 - FStartDate) / numDays * totalWidth) + FixedColWidth; if xe1 = xe2 then xe2 := xe1 + 1; FEventRecords[i].Event := event; FEventRecords[i].Caption := event.Description; FEventRecords[i].HeadRect := Rect(xh1, y1, xh2, y2); FEventRecords[i].EventRect := Rect(xe1, y1, xe2, y2); if event = FActiveEvent then FActiveRow := i; y1 := y2; end; finally list.Free; 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; x1 := FixedColWidth; y1 := 0; y2 := FTotalColHeaderHeight; if n > 1 then begin dm := FStartDate; 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(FEndDate) else nDays := DaysInMonth(dm); if dm + nDays > FEndDate then nDays := trunc(FEndDate) - trunc(dm) + 1; x2 := x1 + nDays * ColWidth; FMonthRecords[i].Rect := Rect(x1, y1, x2, y2); FMonthRecords[i].Date := dm; dm := IncMonth(dm, 1); x1 := x2; end; end else begin nDays := DayOf(FEndDate) - DayOf(FStartDate) + 1; x2 := x1 + nDays * ColWidth; FMonthRecords[0].Rect := Rect(x1, y1, x2, y2); FMonthRecords[0].Date := FStartDate; 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; {$IF VP_LCL_SCALING = 2} procedure TVpGanttView.FixDesignFontsPPI(const ADesignTimePPI: Integer); begin inherited; DoFixDesignFontPPI(ColHeaderAttributes.MonthFont, ADesignTimePPI); DoFixDesignFontPPI(ColHeaderAttributes.DayFont, ADesignTimePPI); DoFixDesignFontPPI(RowHeaderAttributes.EventFont, ADesignTimePPI); end; procedure TVpGanttView.ScaleFontsPPI(const AToPPI: Integer; const AProportion: Double); begin inherited; DoScaleFontPPI(ColHeaderAttributes.MonthFont, AToPPI, AProportion); DoScaleFontPPI(ColHeaderAttributes.DayFont, 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.DayFont, AProportion); DoScaleFontPPI(RowHeadAttributes.EventFont, AProportion); end; {$ENDIF} procedure TVpGanttView.ScrollDateIntoView(ADate: TDateTime); begin if (FStartDate = 0) or (FStartDate = NO_DATE) then exit; if ADate < FStartDate then begin FStartDate := trunc(ADate); FColCount := GetNumDays; SetLeftCol(-MaxInt); end else if ADate > FEndDate then begin FEndDate := trunc(ADate); FColCount := GetNumDays; SetLeftCol(FColCount - 1 - FVisibleCols); end else if ADate < FStartDate + FLeftCol then SetLeftCol(trunc(ADate) - trunc(FStartDate)) else if ADate > FStartDate + VisibleCols then SetLeftCol(trunc(ADate) - VisibleCols) 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; begin if AValue <= 0 then FActiveCol := 0 else if AValue >= ColCount then FActiveCol := ColCount - 1 else FActiveCol := AValue; dt := DayRecords[FActiveCol].Date; dayRect := DayRecords[FActiveCol].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); begin if FActiveDate <> trunc(AValue) then begin FActiveDate := trunc(AValue); if FLoaded then Populate; ScrollDateIntoView(FActiveDate); FActiveCol := trunc(FActiveDate) - trunc(FStartDate); 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; 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; dt := DayRecords[FActiveCol].Date; dayRect := DayRecords[FActiveCol].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.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.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.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 := trunc(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.