pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

tvplanit: Add ISO week numbers to GanttView column headers

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8499 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2022-09-21 22:50:43 +00:00
parent e05d47afc0
commit b6753c216d
7 changed files with 349 additions and 67 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
components/tvplanit/languages/demo.de.po
View File

@ -306,3 +306,4 @@ msgstr "Erledigte Aufgaben verbergen"
#: tmainform.titlelbl.caption
msgid "TitleLbl"
msgstr ""

1
components/tvplanit/languages/demo.en.po
View File

@ -303,3 +303,4 @@ msgstr "Hide completed tasks"
#: tmainform.titlelbl.caption
msgid "TitleLbl"
msgstr "TitleLbl"

3
components/tvplanit/languages/vpsr.de.po
View File

@ -1095,7 +1095,7 @@ msgstr "Druckformat-Designer"
msgid "Print order"
msgstr ""
"Druck-\n"
"Reihenfolge"
"Reihenfolge\n"
#: vpsr.rsprintprvcancel
msgctxt "vpsr.rsprintprvcancel"
@ -1813,3 +1813,4 @@ msgstr "Unbekannte Achsen-Spezifikation: %s"
#: vpsr.sxmldecnotatbeg
msgid "The XML declaration must appear before the first element"
msgstr "Die XML-Deklaration muss vor dem ersten Element erscheinen"

1
components/tvplanit/languages/vpsr.en.po
View File

@ -1792,3 +1792,4 @@ msgstr "Unknown axis specifier: %s"
#: vpsr.sxmldecnotatbeg
msgid "The XML declaration must appear before the first element"
msgstr "The XML declaration must appear before the first element"

170
components/tvplanit/source/vpganttview.pas
View File

@ -37,6 +37,12 @@ type
Rect: TRect;
end;
TVpGanttWeekRec = record
WeekNo: Integer;
Date: TDateTime;
Rect: TRect;
end;
TVpGanttMonthRec = record
Date: TDateTime;
Rect: TRect;
@ -67,18 +73,27 @@ type
property EventFont: TVpFont read FEventFont write SetEventFont;
end;
TVpGanttColHeaderKind = (gchMonth, gchWeek, gchDay);
TVpGanttColHeaderKinds = set of TVpGanttColHeaderKind;
TVpGanttColHeaderAttributes = class(TVpGanttHeaderAttributes)
private
FDayFont: TVpFont;
FMonthFont: TVpFont;
FWeekFont: TVpFont;
FVisible: TVpGanttColHeaderKinds;
procedure SetDayFont(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 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)
@ -112,6 +127,7 @@ type
FFixedColWidth: Integer;
FRowHeight: Integer;
FMonthColHeaderHeight: Integer;
FWeekColHeaderHeight: Integer;
FDayColHeaderHeight: Integer;
FTotalColHeaderHeight: Integer;
FTextMargin: Integer;
@ -149,6 +165,8 @@ type
function GetNumDays: Integer;
function GetNumEvents: Integer;
function GetNumMonths: Integer;
function GetNumWeeks: Integer;
function GetWeekRec(AIndex: Integer): TVpGanttWeekRec;
function IsStoredColWidth: Boolean;
function IsStoredDateFormat(AIndex: Integer): Boolean;
procedure SetActiveCol(AValue: Integer);
@ -175,6 +193,7 @@ type
// Needed by the painter
FEventRecords: array of TVpGanttEventRec;
FDayRecords: array of TVpGanttDayRec;
FWeekRecords: array of TVpGanttWeekRec;
FMonthRecords: array of TVpGanttMonthRec;
{ internal methods }
@ -195,6 +214,7 @@ type
procedure PopulateDayRecords;
procedure PopulateEventRecords;
procedure PopulateMonthRecords;
procedure PopulateWeekRecords;
procedure ScrollDateIntoView(ADate: TDateTime);
procedure ScrollHorizontal(ANumCols: Integer);
procedure ScrollRowIntoView(ARow: Integer);
@ -296,10 +316,12 @@ type
property DayRecords[AIndex: Integer]: TVpGanttDayRec read GetDayRec;
property EventRecords[AIndex: Integer]: TVpGanttEventRec read GetEventRec;
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 NumMonths: Integer read GetNumMonths;
property NumWeeks: Integer read GetNumWeeks;
published
// inherited properties
@ -408,12 +430,15 @@ constructor TVpGanttColHeaderAttributes.Create(AOwner: TVpGanttView);
begin
inherited Create(AOwner);
FDayFont := TVpFont.Create(AOwner);
FWeekFont := TVpFont.Create(AOwner);
FMonthFont := TVpFont.Create(AOwner);
FVisible := [gchMonth, gchDay];
end;
destructor TVpGanttColHeaderAttributes.Destroy;
begin
FDayFont.Free;
FWeekFont.Free;
FMonthFont.Free;
inherited;
end;
@ -438,6 +463,25 @@ begin
end;
end;
procedure TVpGanttColHeaderAttributes.SetVisible(AValue: TVpGanttColHeaderKinds);
begin
if FVisible <> AValue then
begin
FVisible := AValue;
UpdateGanttView;
end;
end;
procedure TVpGanttColHeaderAttributes.SetWeekFont(AValue: TVpFont);
begin
if FWeekFont <> AValue then
begin
FWeekFont := AValue;
FWeekFont.Owner := FGanttView;
UpdateGanttView;
end;
end;
{******************************************************************************}
{ TVpGanttView }
@ -557,14 +601,25 @@ var
h: Integer;
begin
h := GetCanvasTextHeight(Canvas, FColHeaderAttributes.MonthFont);
FMonthColHeaderHeight := h + 2 * FTextMargin;
FMonthColHeaderHeight := h; // + 2 * FTextMargin;
h := GetCanvasTextHeight(Canvas, FColHeaderAttributes.WeekFont);
FWeekColHeaderHeight := 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;
FDayColHeaderHeight := h; // + FTextMargin;
FTotalColHeaderHeight := FMonthColHeaderHeight + FDayColHeaderHeight;
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 FTotalColHeaderHeight > 0 then
inc(FTotalColHeaderHeight, FTextMargin);
end;
procedure TVpGanttView.CalcRowHeight;
@ -818,8 +873,8 @@ begin
end;
end;
{ Determines the date when the earliest event starts, and the date when the
latest event ends. }
{ 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: Integer;
@ -894,6 +949,56 @@ begin
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 (FRealStartDate <> NO_DATE) 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. }
@ -921,6 +1026,11 @@ begin
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;
@ -947,6 +1057,7 @@ begin
FRowCount := GetNumEvents;
PopulateDayRecords;
PopulateWeekRecords;
PopulateMonthRecords;
PopulateEventRecords;
end;
@ -1202,7 +1313,11 @@ var
begin
SetLength(FDayRecords, GetNumDays);
x1 := FixedColWidth;
y1 := FMonthColHeaderHeight;
y1 := 0;
if (gchMonth in FColHeaderAttributes.Visible) then
inc(y1, FMonthColHeaderHeight + FTextMargin);
if (gchWeek in FColHeaderAttributes.Visible) then
inc(y1, FWeekColHeaderHeight + FTextMargin);
y2 := FTotalColHeaderHeight;
for i := 0 to High(FDayRecords) do
begin
@ -1333,6 +1448,49 @@ begin
end;
end;
procedure TVpGanttView.PopulateWeekRecords;
var
i: Integer;
x1, y1, x2, y2: Integer;
d: TVpDayType;
dt1, dt2: TDateTime;
begin
SetLength(FWeekRecords, GetNumWeeks);
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 + (trunc(dt2) - trunc(dt1) + 1) * FColWidth;
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 + (trunc(dt2) - trunc(dt1) + 1) * FColWidth;
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);

233
components/tvplanit/source/vpganttviewpainter.pas
View File

@ -15,6 +15,7 @@ type
FDayFont: TFont;
FMonthFont: TFont;
FWeekFont: TFont;
FEventFont: TFont;
FScaledColWidth: Integer;
@ -39,11 +40,14 @@ type
procedure DrawActiveDate;
procedure DrawBorders;
procedure DrawColHeader;
procedure DrawDayColHeaders;
procedure DrawEvents;
procedure DrawGrid;
procedure DrawMonthColHeaders;
procedure DrawRowHeader;
procedure FixFontHeights;
procedure DrawSpecialDays;
procedure DrawWeekColHeaders;
procedure FixFontHeights;
procedure InitColors;
procedure SetMeasurements; override;
@ -60,7 +64,7 @@ implementation
uses
DateUtils,
VpConst, VpMisc, VpCanvasUtils, VpData;
VpSR, VpConst, VpMisc, VpCanvasUtils, VpData;
constructor TVpGanttViewPainter.Create(AGanttView: TVpGanttView;
ARenderCanvas: TCanvas);
@ -137,14 +141,7 @@ end;
procedure TVpGanttViewPainter.DrawColHeader;
var
i, n: Integer;
R, R1: TRect;
P: TPoint;
monthRec: TVpGanttMonthRec;
dayRec: TVpGanttDayRec;
str: String;
strLen, strH: Integer;
dx: Integer;
begin
RenderCanvas.Brush.Color := RealColHeadAttrColor;
RenderCanvas.Pen.Color := RealLineColor;
@ -179,59 +176,29 @@ begin
TPSLineTo(RenderCanvas, Angle, RenderIn, RealRight, R.Bottom);
end;
// Draw the month column headers
DrawMonthColHeaders;
// Draw the week column headers
DrawWeekColHeaders;
// Draw the day column headers
DrawDayColHeaders;
end;
procedure TVpGanttViewPainter.DrawDayColHeaders;
var
dayRec: TVpGanttDayRec;
dx: Integer;
strH, strLen: Integer;
str: String;
i, n: Integer;
R, R1: TRect;
P: TPoint;
begin
// Offset due to scrolling
dx := FGanttView.LeftCol * FScaledColWidth;
// Draw month rectangles and month captions
RenderCanvas.Font.Assign(FMonthFont);
n := FGanttView.NumMonths;
for i := 0 to n-1 do
begin
monthRec := FGanttView.MonthRecords[i];
R := monthRec.Rect;
R := ScaleRect(R);
OffsetRect(R, -dx , 0);
// Clip at fixed col edge
if R.Left < RealLeft + FScaledFixedColWidth then
R.Left := RealLeft + FScaledFixedColWidth;
// Draw month box
if FGanttView.DrawingStyle = ds3D then
begin
R1 := R;
if i > 0 then
inc(R1.Left);
dec(R1.Bottom);
DrawBevelRect(
RenderCanvas,
TPSRotateRectangle(Angle, RenderIn, R1),
BevelHighlight,
BevelShadow
)
end else
begin
TPSMoveTo(RenderCanvas, Angle, RenderIn, R.Right, R.Top);
TPSLineTo(RenderCanvas, Angle, RenderIn, R.Right, R.Bottom);
end;
// Paint month name. Use short format if space is too small for long format.
str := FormatDateTime(FGanttView.MonthFormat, monthRec.Date);
strLen := RenderCanvas.TextWidth(str);
if strLen > R.Width - 2 * FScaledTextMargin then
begin
str := FormatDateTime(FGanttView.MonthFormat_short, monthRec.Date);
strLen := RenderCanvas.TextWidth(str);
end;
if strLen > R.Width - 2 * FScaledTextMargin then
str := '';
if str <> '' then
begin
P := Point((R.Left + R.Right - strLen) div 2, R.Top + FScaledTextMargin);
TPSTextOut(RenderCanvas, Angle, RenderIn, P.X, P.Y, str);
end;
end;
// Draw day captions (always centered) and dividing lines (always at right side).
RenderCanvas.Font.Assign(FDayFont);
strH := RenderCanvas.TextHeight('Tg');
@ -296,7 +263,6 @@ begin
// strLen := GetCanvasTextWidth(RenderCanvas, FDayFont, str);
// TPSTextRect(RencerCanvas, Angle, RenderIn, R, P.X, P.Y, str);
// BUT: TPSTextRect does not yet exist...
end;
end;
@ -429,6 +395,70 @@ begin
end;
end;
procedure TVpGanttViewPainter.DrawMonthColHeaders;
var
dx: Integer;
i, n: Integer;
monthRec: TVpGanttMonthRec;
R, R1: TRect;
P: TPoint;
str: String;
strLen: Integer;
begin
// Offset due to scrolling
dx := FGanttView.LeftCol * FScaledColWidth;
// Draw month rectangles and month captions
RenderCanvas.Font.Assign(FMonthFont);
n := FGanttView.NumMonths;
for i := 0 to n-1 do
begin
monthRec := FGanttView.MonthRecords[i];
R := monthRec.Rect;
R := ScaleRect(R);
OffsetRect(R, -dx , 0);
// Clip at fixed col edge
if R.Left < RealLeft + FScaledFixedColWidth then
R.Left := RealLeft + FScaledFixedColWidth;
// Draw month box
if FGanttView.DrawingStyle = ds3D then
begin
R1 := R;
if i > 0 then
inc(R1.Left);
dec(R1.Bottom);
DrawBevelRect(
RenderCanvas,
TPSRotateRectangle(Angle, RenderIn, R1),
BevelHighlight,
BevelShadow
)
end else
begin
TPSMoveTo(RenderCanvas, Angle, RenderIn, R.Right, R.Top);
TPSLineTo(RenderCanvas, Angle, RenderIn, R.Right, R.Bottom);
end;
// Paint month name. Use short format if space is too small for long format.
str := FormatDateTime(FGanttView.MonthFormat, monthRec.Date);
strLen := RenderCanvas.TextWidth(str);
if strLen > R.Width - 2 * FScaledTextMargin then
begin
str := FormatDateTime(FGanttView.MonthFormat_short, monthRec.Date);
strLen := RenderCanvas.TextWidth(str);
end;
if strLen > R.Width - 2 * FScaledTextMargin then
str := '';
if str <> '' then
begin
P := Point((R.Left + R.Right - strLen) div 2, R.Top + FScaledTextMargin);
TPSTextOut(RenderCanvas, Angle, RenderIn, P.X, P.Y, str);
end;
end;
end;
procedure TVpGanttViewPainter.DrawRowHeader;
var
R: TRect;
@ -552,10 +582,92 @@ begin
end;
end;
procedure TVpGanttViewPainter.DrawWeekColHeaders;
var
dx: Integer;
i, n: Integer;
weekRec: TVpGanttWeekRec;
weekNo, yearNo: Integer;
R, R1: TRect;
P: TPoint;
str: String;
strLen: Integer;
begin
// Offset due to scrolling
dx := FGanttView.LeftCol * FScaledColWidth;
// Draw week rectangles and week numbers as captions
RenderCanvas.Font.Assign(FWeekFont);
n := FGanttView.NumWeeks;
for i := 0 to n-1 do
begin
weekRec := FGanttView.WeekRecords[i];
R := weekRec.Rect;
R := ScaleRect(R);
OffsetRect(R, -dx , 0);
// Clip at fixed col edge
if R.Left < RealLeft + FScaledFixedColWidth then
R.Left := RealLeft + FScaledFixedColWidth;
// Draw week box
if FGanttView.DrawingStyle = ds3D then
begin
R1 := R;
if i > 0 then
inc(R1.Left);
dec(R1.Bottom);
DrawBevelLine(
RenderCanvas,
TPSRotatePoint(Angle, RenderIn, Point(R.Right, R.Top)),
TPSRotatePoint(Angle, RenderIn, Point(R.Right, R.Bottom)),
BevelShadow,
BevelHighlight
)
(*
DrawBevelRect(
RenderCanvas,
TPSRotateRectangle(Angle, RenderIn, R1),
BevelHighlight,
BevelShadow
)
*)
end else
begin
TPSMoveTo(RenderCanvas, Angle, RenderIn, R.Right, R.Top);
TPSLineTo(RenderCanvas, Angle, RenderIn, R.Right, R.Bottom);
end;
// Paint ISO week number.
weekNo := WeekOfTheYear(weekRec.Date);
yearNo := YearOf(weekRec.Date);
str := Format('%s %d (%d)', [RSCalendarWeekAbbr, weekNo, yearNo]);
strLen := RenderCanvas.TextWidth(str);
if strLen > R.Width - 2 * FScaledTextMargin then
begin
str := Format('%s %d', [RSCalendarWeekAbbr, weekNo]);
strLen := RenderCanvas.TextWidth(str);
end;
if strLen > R.Width - 2 * FScaledTextMargin then
begin
str := IntToStr(weekNo);
strLen := RenderCanvas.TextWidth(str);
end;
if strLen > R.Width - 2 * FScaledTextMargin then
str := '';
if str <> '' then
begin
P := Point((R.Left + R.Right - strLen) div 2, R.Top + FScaledTextMargin);
TPSTextOut(RenderCanvas, Angle, RenderIn, P.X, P.Y, str);
end;
end;
end;
procedure TVpGanttViewPainter.FixFontHeights;
begin
with FGanttView do begin
ColHeaderAttributes.DayFont.Height := GetRealFontHeight(ColHeaderAttributes.DayFont);
ColHeaderAttributes.WeekFont.Height := GetRealFontHeight(ColHeaderAttributes.WeekFont);
ColHeaderAttributes.MonthFont.Height := GetRealFontHeight(ColHeaderAttributes.MonthFont);
RowHeaderAttributes.EventFont.Height := GetRealFontHeight(RowHeaderAttributes.EventFont);
end;
@ -585,6 +697,7 @@ begin
FDayFont := FGanttView.ColHeaderAttributes.DayFont;
FMonthFont := FGanttView.ColHeaderAttributes.MonthFont;
FWeekFont := FGanttView.ColHeaderAttributes.WeekFont;
FEventFont := FGanttView.RowHeaderAttributes.EventFont;
end;

7
components/tvplanit/source/vpmisc.pas
View File

@ -150,6 +150,7 @@ function DatePart(ADateTime: TDateTime): TDateTime; inline;
function TimePart(ADateTime: TDateTime): TDateTime; inline;
function GetJulianDate(Date: TDateTime): Word;
function GetVpDayType(ADate: TDateTime): TVpDayType;
function GetWeekOfYear(ADate: TDateTime): byte;
function IsWeekend(ADate: TDateTime): Boolean;
function SameDate(dt1, dt2: TDateTime): Boolean;
@ -893,6 +894,12 @@ begin
Result := SameTime(t1, t2) or (t1 > t2);
end;
// Determines the TVpDayType for the given date, i.e. dtSunday, dtMonday, etc.
function GetVpDayType(ADate: TDateTime): TVpDayType;
begin
Result := TVpDayType(DayOfWeek(ADate) - 1);
end;
// Calculates ISO week number (checked with Jan 1, 2016, which is in week 53).
function GetWeekOfYear(ADate: TDateTime): byte;
// wp: was in TvWeekView.