tvplanit: Add SpecialDayMode for TVpGanttView.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8435 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2022-09-01 09:42:04 +00:00
parent 1c707883ce
commit 2c6c88fa8b
4 changed files with 137 additions and 124 deletions
--- a/components/tvplanit/source/design/vpreg.pas
+++ b/components/tvplanit/source/design/vpreg.pas
@ -686,8 +686,8 @@ begin
    TVpTaskEditDialog,
    TVpPrintFormatEditDialog,
    TVpPrintPreviewDialog,
-    TVpPrintPreview,
    TVpNotificationDialog,
+    TVpPrintPreview,
    TVpLEDLabel,
    TVpClock,
    TVpCalendar,
--- a/components/tvplanit/source/vpabout.lfm
+++ b/components/tvplanit/source/vpabout.lfm
@ -1,18 +1,17 @@
 object frmAbout: TfrmAbout
  Left = 368
-  Height = 387
+  Height = 364
  Top = 312
-  Width = 634
+  Width = 594
  HorzScrollBar.Page = 470
  VertScrollBar.Page = 311
  AutoSize = True
  BorderStyle = bsDialog
  Caption = 'About Visual PlanIt'
-  ClientHeight = 387
-  ClientWidth = 634
+  ClientHeight = 364
+  ClientWidth = 594
  OnActivate = FormActivate
  Position = poScreenCenter
-  LCLVersion = '1.6.4.0'
  object ButtonPanel: TPanel
    AnchorSideLeft.Control = Owner
    AnchorSideTop.Control = Panel1
@ -20,21 +19,21 @@ object frmAbout: TfrmAbout
    AnchorSideRight.Control = Owner
    AnchorSideRight.Side = asrBottom
    Left = 0
-    Height = 55
-    Top = 310
-    Width = 634
+    Height = 53
+    Top = 311
+    Width = 594
    Anchors = [akTop, akLeft, akRight]
    AutoSize = True
    BorderSpacing.Top = 8
    BevelOuter = bvNone
-    ClientHeight = 55
-    ClientWidth = 634
+    ClientHeight = 53
+    ClientWidth = 594
    TabOrder = 0
    object Bevel3: TBevel
      Left = 4
      Height = 8
      Top = 0
-      Width = 626
+      Width = 586
      Align = alTop
      BorderSpacing.Left = 4
      BorderSpacing.Right = 4
@ -46,16 +45,14 @@ object frmAbout: TfrmAbout
      AnchorSideTop.Side = asrCenter
      AnchorSideRight.Control = ButtonPanel
      AnchorSideRight.Side = asrBottom
-      Left = 576
-      Height = 33
-      Top = 14
-      Width = 50
+      Left = 540
+      Height = 29
+      Top = 16
+      Width = 46
      Anchors = [akTop, akRight]
      AutoSize = True
-      BorderSpacing.Top = 8
-      BorderSpacing.Right = 8
-      BorderSpacing.Bottom = 8
-      BorderSpacing.InnerBorder = 4
+      BorderSpacing.Around = 8
+      BorderSpacing.InnerBorder = 2
      Cancel = True
      Caption = 'OK'
      Default = True
@ -69,42 +66,43 @@ object frmAbout: TfrmAbout
      Left = 4
      Height = 30
      Top = 15
-      Width = 539
+      Width = 499
      Anchors = [akTop, akLeft, akRight]
      BorderSpacing.Left = 4
      BorderSpacing.Top = 4
      BorderSpacing.Bottom = 8
      Caption = '(C) Copyright 2001, TurboPower Software Company.'#13#10'All rights reserved.'
+      Color = clDefault
      ParentColor = False
      WordWrap = True
    end
  end
  object Panel1: TPanel
    Left = 0
-    Height = 302
+    Height = 303
    Top = 0
-    Width = 634
+    Width = 594
    Align = alTop
    AutoSize = True
    BevelOuter = bvNone
-    ClientHeight = 302
-    ClientWidth = 634
+    ClientHeight = 303
+    ClientWidth = 594
    TabOrder = 1
    object ImagePanel: TPanel
      Left = 4
-      Height = 290
+      Height = 291
      Top = 8
      Width = 164
      Align = alLeft
      BorderSpacing.Top = 4
      BorderSpacing.Around = 4
      BevelOuter = bvNone
-      ClientHeight = 290
+      ClientHeight = 291
      ClientWidth = 164
      TabOrder = 0
      object Image1: TImage
        Left = 0
-        Height = 290
+        Height = 291
        Top = 0
        Width = 164
        Align = alClient
@ -1240,26 +1238,27 @@ object frmAbout: TfrmAbout
    end
    object TextPanel: TPanel
      Left = 176
-      Height = 294
+      Height = 295
      Top = 8
-      Width = 458
+      Width = 418
      Align = alClient
      AutoSize = True
      BorderSpacing.Left = 8
      BorderSpacing.Top = 8
      BevelOuter = bvNone
-      ClientHeight = 294
-      ClientWidth = 458
+      ClientHeight = 295
+      ClientWidth = 418
      TabOrder = 1
      object ProgramName: TLabel
        AnchorSideLeft.Control = TextPanel
        AnchorSideTop.Control = TextPanel
        Left = 0
-        Height = 16
+        Height = 17
        Top = 0
-        Width = 80
+        Width = 78
        BorderSpacing.Right = 8
        Caption = 'Visual PlanIt'
+        Color = clDefault
        Font.Height = -13
        Font.Name = 'Default'
        Font.Style = [fsBold]
@ -1274,11 +1273,12 @@ object frmAbout: TfrmAbout
        AnchorSideRight.Side = asrBottom
        Left = 0
        Height = 30
-        Top = 28
+        Top = 29
        Width = 410
        Anchors = [akTop, akLeft, akRight]
        BorderSpacing.Top = 12
        Caption = 'Visual PlanIt was released under the Mozilla 1.1 license in January, 2003. The project is hosted on SourceForge at'
+        Color = clDefault
        ParentColor = False
        WordWrap = True
      end
@ -1289,11 +1289,12 @@ object frmAbout: TfrmAbout
        Cursor = crHandPoint
        Left = 12
        Height = 15
-        Top = 58
+        Top = 59
        Width = 222
        BorderSpacing.Left = 12
        BorderSpacing.Right = 8
        Caption = 'http://sourceforge.net/projects/tpvplanit/'
+        Color = clDefault
        Font.Color = clBlue
        ParentColor = False
        ParentFont = False
@ -1307,11 +1308,12 @@ object frmAbout: TfrmAbout
        AnchorSideTop.Side = asrBottom
        Left = 0
        Height = 15
-        Top = 85
-        Width = 150
+        Top = 86
+        Width = 149
        BorderSpacing.Top = 12
        BorderSpacing.Right = 8
        Caption = 'The Lazarus port is hosted at'
+        Color = clDefault
        ParentColor = False
        WordWrap = True
      end
@ -1322,11 +1324,12 @@ object frmAbout: TfrmAbout
        Cursor = crHandPoint
        Left = 12
        Height = 15
-        Top = 100
+        Top = 101
        Width = 398
        BorderSpacing.Left = 12
        BorderSpacing.Right = 8
        Caption = 'http://sourceforge.net/p/lazarus-ccr/svn/HEAD/tree/components/tvplanit/'
+        Color = clDefault
        Font.Color = clBlue
        ParentColor = False
        ParentFont = False
@ -1342,7 +1345,7 @@ object frmAbout: TfrmAbout
        AnchorSideRight.Side = asrBottom
        Left = 0
        Height = 133
-        Top = 123
+        Top = 124
        Width = 410
        Anchors = [akTop, akLeft, akRight]
        AutoSize = True
@ -1362,6 +1365,7 @@ object frmAbout: TfrmAbout
          BorderSpacing.Top = 4
          BorderSpacing.Right = 4
          Caption = 'Visual PlanIt support groups'
+          Color = clDefault
          ParentColor = False
          ParentFont = False
        end
@ -1375,6 +1379,7 @@ object frmAbout: TfrmAbout
          BorderSpacing.Top = 4
          BorderSpacing.Right = 4
          Caption = 'Help:'
+          Color = clDefault
          ParentColor = False
        end
        object lblHelp: TLabel
@ -1387,6 +1392,7 @@ object frmAbout: TfrmAbout
          BorderSpacing.Left = 16
          BorderSpacing.Right = 4
          Caption = 'http://sourceforge.net/forum/forum.php?forum_id=241880'
+          Color = clDefault
          Font.Color = clBlue
          ParentColor = False
          ParentFont = False
@ -1404,6 +1410,7 @@ object frmAbout: TfrmAbout
          BorderSpacing.Top = 4
          BorderSpacing.Right = 4
          Caption = 'General discussion:'
+          Color = clDefault
          ParentColor = False
        end
        object lblGeneralDiscussion: TLabel
@ -1416,6 +1423,7 @@ object frmAbout: TfrmAbout
          BorderSpacing.Left = 16
          BorderSpacing.Right = 4
          Caption = 'http://sourceforge.net/forum/forum.php?forum_id=241879'
+          Color = clDefault
          Font.Color = clBlue
          ParentColor = False
          ParentFont = False
@ -1433,6 +1441,7 @@ object frmAbout: TfrmAbout
          BorderSpacing.Top = 4
          BorderSpacing.Right = 4
          Caption = 'Lazarus port:'
+          Color = clDefault
          ParentColor = False
        end
        object lblLazForumLink: TLabel
@ -1445,6 +1454,7 @@ object frmAbout: TfrmAbout
          BorderSpacing.Left = 16
          BorderSpacing.Bottom = 8
          Caption = 'http://forum.lazarus.freepascal.org/'
+          Color = clDefault
          Font.Color = clBlue
          ParentColor = False
          ParentFont = False
@ -1458,10 +1468,11 @@ object frmAbout: TfrmAbout
        AnchorSideTop.Side = asrBottom
        Left = 0
        Height = 15
-        Top = 264
+        Top = 265
        Width = 193
        BorderSpacing.Top = 8
        Caption = 'Internally used icons are provided by'
+        Color = clDefault
        ParentColor = False
      end
      object lblLazPortLink1: TLabel
@ -1471,11 +1482,12 @@ object frmAbout: TfrmAbout
        Cursor = crHandPoint
        Left = 12
        Height = 15
-        Top = 279
+        Top = 280
        Width = 96
        BorderSpacing.Left = 12
        BorderSpacing.Right = 8
        Caption = 'http://icons8.com'
+        Color = clDefault
        Font.Color = clBlue
        ParentColor = False
        ParentFont = False
--- a/components/tvplanit/source/vpganttview.pas
+++ b/components/tvplanit/source/vpganttview.pas
@ -15,6 +15,8 @@ type
  );
  TVpGanttViewOptions = set of TVpGanttViewOption;

+  TVpGanttSpecialDayMode = (sdmColumn, sdmHeader);
+
 const
  DEFAULT_GANTTVIEWOPTIONS = [
    gvoActiveDate, gvoHorizGrid, gvoVertGrid, gvoWeekends, gvoHolidays
@ -124,6 +126,7 @@ type
    FDefaultPopup: TPopupMenu;
    FExternalPopup: TPopupMenu;
    FOptions: TVpGanttViewOptions;
+    FSpecialDayMode: TVpGanttSpecialDayMode;

    FOnAddEvent: TVpOnAddNewEvent;
    FOnDeletingEvent: TVpOnDeletingEvent;
@ -154,6 +157,7 @@ type
    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);
@ -275,6 +279,7 @@ type
    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 WeekendColor: TColor read FWeekendColor write SetWeekendColor default WEEKEND_COLOR;
    // inherited events
@ -1415,6 +1420,15 @@ begin
  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
--- a/components/tvplanit/source/vpganttviewpainter.pas
+++ b/components/tvplanit/source/vpganttviewpainter.pas
@ -31,11 +31,11 @@ type
    procedure DrawActiveDate;
    procedure DrawBorders;
    procedure DrawColHeader;
-    procedure DrawDays;
    procedure DrawEvents;
    procedure DrawGrid;
    procedure DrawRowHeader;
    procedure FixFontHeights;
+    procedure DrawSpecialDays;
    procedure InitColors;
    procedure SetMeasurements; override;

@ -256,6 +256,29 @@ begin
    if R.Left < FGanttView.FixedColWidth then
      Continue;

+    // In sdmHeader SpecialDayMode we must repaint the background of the
+    // day cells in the color of the special day (weekend/holiday)
+    if (FGanttView.SpecialDayMode = sdmHeader) then
+    begin
+      R1 := R;
+      if FGanttView.DrawingStyle = ds3D then
+      begin
+        inc(R1.Left, 2);
+        dec(R1.Bottom);
+      end else
+        inc(R1.Left);
+      if (gvoWeekends in FGanttView.Options) and IsWeekend(dayRec.Date) then
+      begin;
+        RenderCanvas.Brush.Color := FGanttView.Weekendcolor;
+        TPSFillRect(RenderCanvas, Angle, RenderIn, R1);
+      end else
+      if (gvoHolidays in FGanttView.Options) and FGanttView.IsHoliday(dayRec.Date, str) then
+      begin
+        RenderCanvas.Brush.Color := FGanttView.HolidayColor;
+        TPSFillRect(RenderCanvas, Angle, RenderIn, R1);
+      end;
+    end;
+
    // No dividing line at last day of month because it already has been
    // drawn as the month divider.
    if (DayOf(dayRec.Date) <> DaysInMonth(dayRec.Date)) then
@ -289,85 +312,6 @@ begin
  end;
 end;

-procedure TVpGanttViewPainter.DrawDays;
-var
-  i, j1, j2, nDays, nEvents: Integer;
-  x1, y1, x2, y2: Integer;
-  dx, dy: Integer;
-  clr: TColor;
-  dayRec: TVpGanttDayRec;
-  holiday: String;
-begin
-  with FGanttView do
-  begin
-    if (StartDate = NO_DATE) then
-      exit;
-
-    nEvents := NumEvents;
-    nDays := NumDays;
-    dx := LeftCol * ColWidth;
-    dy := TopRow * RowHeight;
-    y1 := TotalColHeaderHeight;
-    y2 := EventRecords[nEvents-1].HeadRect.Bottom - dy;
-
-    RenderCanvas.Brush.style := bsSolid;
-    for i := 0 to nDays-1 do
-    begin
-      dayRec := DayRecords[i];
-      clr := clNone;
-      if (gvoWeekends in Options) and IsWeekend(dayRec.Date) then
-        clr := WeekendColor
-      else
-      if (gvoHolidays in Options) and IsHoliday(dayRec.Date, holiday) then
-        clr := HolidayColor;
-      if clr <> clNone then
-      begin
-        RenderCanvas.Brush.Color := clr;
-        x1 := dayRec.Rect.Left - dx;
-        x2 := dayRec.Rect.Right - dx;
-        RenderCanvas.FillRect(x1, y1, x2, y2);
-      end;
-    end;
-  end;
-  (*
-
-
-
-      begin
-        j1 := i;
-        break;
-      end;
-  end;
-
-  if y2 > RealBottom then
-    y2 := RealBottom;
-
-  if (gvoWeekends in FGanttView.Options) then
-  begin
-    RenderCanvas.Brush.Color := FGanttView.WeekendColor;
-    RenderCanvas.Brush.Style := bsSolid;
-
-    while j1 < nDays do
-    begin
-      if j1 < nDays-1 then
-        j2 := j1 + 1
-      else
-        j2 := j1;
-      x2 := FGanttView.DayRecords[j2].Rect.Right - dx;
-      if x2 >= FGanttView.FixedColWidth then
-      begin
-        x1 := FGanttView.DayRecords[j1].Rect.Left - dx;
-        if x1 < FGanttView.FixedColWidth then
-          x1 := FGanttView.FixedColWidth;
-        RenderCanvas.FillRect(x1, y1, x2, y2);
-      end;
-
-      inc(j1, 7);
-    end;
-  end;
-  *)
-end;
-
 procedure TVpGanttViewPainter.DrawEvents;
 var
  i: Integer;
@ -540,6 +484,49 @@ begin
  end;
 end;

+procedure TVpGanttViewPainter.DrawSpecialDays;
+var
+  i, nDays, nEvents: Integer;
+  x1, y1, x2, y2: Integer;
+  dx, dy: Integer;
+  clr: TColor;
+  dayRec: TVpGanttDayRec;
+  holiday: String;
+begin
+  with FGanttView do
+  begin
+    if (StartDate = NO_DATE) or (SpecialDayMode <> sdmColumn) then
+      exit;
+
+    nEvents := NumEvents;
+    nDays := NumDays;
+    dx := LeftCol * ColWidth;
+    dy := TopRow * RowHeight;
+
+    y1 := TotalColHeaderHeight;
+    y2 := EventRecords[nEvents-1].HeadRect.Bottom - dy;
+
+    RenderCanvas.Brush.style := bsSolid;
+    for i := 0 to nDays-1 do
+    begin
+      dayRec := DayRecords[i];
+      clr := clNone;
+      if (gvoWeekends in Options) and IsWeekend(dayRec.Date) then
+        clr := WeekendColor
+      else
+      if (gvoHolidays in Options) and IsHoliday(dayRec.Date, holiday) then
+        clr := HolidayColor;
+      if clr <> clNone then
+      begin
+        RenderCanvas.Brush.Color := clr;
+        x1 := dayRec.Rect.Left - dx;
+        x2 := dayRec.Rect.Right - dx;
+        RenderCanvas.FillRect(x1, y1, x2, y2);
+      end;
+    end;
+  end;
+end;
+
 procedure TVpGanttViewPainter.FixFontHeights;
 begin
  with FGanttView do begin
@ -603,8 +590,8 @@ begin
    DrawRowHeader;
    DrawColHeader;

-    { Draw weekends }
-    DrawDays;
+    { Draw weekends and holidays }
+    DrawSpecialDays;

    { Draw grid }
    DrawGrid;