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

tvplanit: Initial attempt for scrolling in TVpGanttView.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8419 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2022-08-27 10:31:14 +00:00
parent 3cc502f29d
commit 4fa25ff2d3
2 changed files with 287 additions and 10 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,7 +5,7 @@ unit VpGanttView;
interface
uses
Classes, SysUtils, Graphics, Types,
LCLType, LCLIntf, LMessages, Classes, SysUtils, Graphics, Types, StdCtrls,
VpConst, VpBase, VpBaseDS, VpData;
type
@ -75,6 +75,14 @@ type
FEndDate: TDateTime; // Date of the last event
FLeftDate: TDateTime; // Date of the left-most event (after scrolling > FStartDate)
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;
@ -100,7 +108,9 @@ type
procedure SetDateFormat(AIndex: Integer; AValue: String);
procedure SetDrawingStyle(AValue: TVpDrawingStyle);
procedure SetFixedColWidth(AValue: Integer);
procedure SetLineColor(Value: TColor);
procedure SetLeftCol(AValue: Integer);
procedure SetLineColor(AValue: TColor);
procedure SetTopRow(AValue: Integer);
protected
// Needed by the painter
@ -111,12 +121,22 @@ type
{ internal methods }
procedure Hookup;
procedure Populate;
procedure ScrollHorizontal(ANumCols: Integer);
procedure ScrollVertical(ANumRows: Integer);
procedure SetHScrollPos;
procedure SetVScrollPos;
{ inherited methods }
procedure CreateParams(var AParams: TCreateParams); override;
function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
class function GetControlClassDefaultSize: TSize; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure Loaded; override;
procedure Paint; override;
procedure Resize; override;
procedure WMHScroll(var Msg: TLMHScroll); message LM_HSCROLL;
procedure WMVScroll(var Msg: TLMVScroll); message LM_VSCROLL;
public
constructor Create(AOwner: TComponent); override;
@ -131,6 +151,12 @@ type
property Date: TDateTime read FDate write SetDate;
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;
published
property Align;
@ -284,6 +310,8 @@ begin
FDateFormat[1] := DEFAULT_MONTHFORMAT;
FDateFormat[2] := DEFAULT_MONTHFORMAT_SHORT;
FScrollBars := ssBoth;
with GetControlClassDefaultSize do
SetInitialBounds(0, 0, CX, CY);
end;
@ -295,6 +323,47 @@ begin
inherited;
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;
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;
class function TVpGanttView.GetControlClassDefaultSize: TSize;
begin
Result.CX := 300;
@ -321,6 +390,51 @@ begin
end;
end;
procedure TVpGanttView.KeyDown(var Key: Word; Shift: TShiftState);
var
PopupPoint : TPoint;
begin
case Key of
VK_DELETE : ; //DeleteActiveEvent(true);
VK_RIGHT : if Shift = [ssShift] then
ScrollHorizontal(FVisibleCols)
else if Shift = [] then
ScrollHorizontal(1);
VK_LEFT : if Shift = [ssShift] then
ScrollHorizontal(-FVisibleCols)
else if Shift = [] then
ScrollHorizontal(-1);
VK_UP : if Shift = [ssShift] then
ScrollVertical(-FVisibleRows)
else if Shift = [] then
ScrollVertical(-1);
VK_DOWN : if Shift = [ssShift] then
ScrollVertical(FVisibleRows)
else
ScrollVertical(1);
(*
VK_INSERT : PopupAddEvent(Self);
{$IFNDEF LCL}
VK_TAB :
if ssShift in Shift then
Windows.SetFocus(GetNextDlgTabItem(GetParent(Handle), Handle, False))
else
Windows.SetFocus(GetNextDlgTabItem(GetParent(Handle), Handle, True));
{$ENDIF}
VK_F10:
if (ssShift in Shift) and not Assigned(PopupMenu) then begin
PopupPoint := GetClientOrigin;
FDefaultPopup.Popup(PopupPoint.x + 10, PopupPoint.y + 10);
end;
VK_APPS:
if not Assigned (PopupMenu) then begin
PopupPoint := GetClientOrigin;
FDefaultPopup.Popup(PopupPoint.x + 10, PopupPoint.y + 10);
end;
*)
end;
end;
function TVpGanttView.IsStoredColWidth: Boolean;
begin
Result := FColWidth <> DEFAULT_COLWIDTH;
@ -376,6 +490,8 @@ begin
gr30Min, // Granularity
False // Display Only
);
SetVScrollPos;
SetHScrollPos;
end;
procedure TVpGanttView.RenderToCanvas(RenderCanvas: TCanvas; RenderIn: TRect;
@ -401,6 +517,18 @@ begin
Invalidate;
end;
procedure TVpGanttView.ScrollHorizontal(ANumCols: Integer);
begin
FLeftCol := FLeftCol + ANumCols;
Invalidate;
end;
procedure TVpGanttView.ScrollVertical(ANumRows: Integer);
begin
TopRow := FTopRow + ANumRows;
Invalidate;
end;
procedure TVpGanttView.SetColor(Value: TColor);
begin
if FColor <> Value then begin
@ -467,13 +595,137 @@ begin
end;
end;
procedure TVpGanttView.SetLineColor(Value: TColor);
procedure TVpGanttView.SetLeftCol(AValue: Integer);
begin
if FLineColor <> Value then begin
FLineColor := Value;
if AValue <> FLeftCol then begin
if AValue + FVisibleCols > FColCount then begin
FLeftCol := FColCount - FVisibleCols - 1;
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.SetHScrollPos;
var
SI: TScrollInfo;
begin
if not HandleAllocated then
Exit;
with SI do
begin
cbSize := SizeOf(SI);
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, SI, True);
end;
procedure TVpGanttView.SetTopRow(AValue: Integer);
begin
if AValue <> FTopRow then begin
if AValue + FVisibleRows > RowCount then begin
FTopRow := FRowCount - FVisibleRows - 1;
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
SI: TScrollInfo;
begin
if not HandleAllocated then
Exit;
with SI do
begin
cbSize := SizeOf(SI);
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 := RowCount
else
nPos := FTopRow;
nTrackPos := nPos;
end;
SetScrollInfo(Handle, SB_VERT, SI, True);
end;
procedure TVpGanttView.WMHScroll(var Msg: TLMHScroll);
begin
{ for simplicity, bail out of editing while scrolling. }
// EndEdit(Self);
// wp: Next line should never happen after EndEdit...
// if (dvInPlaceEditor <> nil) and dvInplaceEditor.Visible then Exit;
case Msg.ScrollCode of
SB_LINELEFT : ScrollHorizontal(-1);
SB_LINERIGHT : ScrollHorizontal(1);
SB_PAGELEFT : ScrollHorizontal(-FVisibleCols);
SB_PAGERIGHT : ScrollHorizontal(FVisibleCols);
SB_THUMBPOSITION, SB_THUMBTRACK : FLeftCol := Msg.Pos;
end;
end;
procedure TVpGanttView.WMVScroll(var Msg: TLMVScroll);
begin
{ for simplicity, bail out of editing while scrolling. }
// EndEdit(Self);
// wp: Next line should never happen after EndEdit...
// if (dvInPlaceEditor <> nil) and dvInplaceEditor.Visible then Exit;
case Msg.ScrollCode of
SB_LINEUP : ScrollVertical(-1);
SB_LINEDOWN : ScrollVertical(1);
SB_PAGEUP : ScrollVertical(-FVisibleRows);
SB_PAGEDOWN : ScrollVertical(FVisibleRows);
SB_THUMBPOSITION, SB_THUMBTRACK : FTopRow := Msg.Pos;
end;
end;
end.

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

@ -78,7 +78,8 @@ var
dt: TDateTime;
begin
if ADate1 > ADate2 then
raise Exception.Create('[TVpGanttViewPainter.CountMonts] Dates not in order.');
exit;
// raise Exception.Create('[TVpGanttViewPainter.CountMonts] Dates not in order.');
Result := 0;
dt := ADate1;
@ -135,6 +136,7 @@ var
dayRec: TVpGanttDayRec;
str: String;
strLen, strH: Integer;
dx: Integer;
begin
RenderCanvas.Brush.Color := RealColHeadAttrColor;
RenderCanvas.Pen.Color := RealLineColor;
@ -169,12 +171,16 @@ begin
TPSLineTo(RenderCanvas, Angle, RenderIn, RealRight, R.Bottom);
end;
dx := FGanttView.FixedColWidth - FGanttView.LeftCol * FGanttView.ColWidth;
// Draw month rectangles and month captions
for i := 0 to High(TVpGanttViewOpener(FGanttView).FMonthRecords) do
begin
monthRec := TVpGanttViewOpener(FGanttView).FMonthRecords[i];
R := monthRec.Rect;
OffsetRect(R, FGanttView.FixedColWidth, 0);
OffsetRect(R, dx , 0);
if R.Left < FGanttView.FixedColWidth then
R.Left := FGanttView.FixedColWidth;
if FGanttView.DrawingStyle = ds3D then
begin
R1 := R;
@ -215,7 +221,9 @@ begin
for dayRec in TVpGanttViewOpener(FGanttView).FDayRecords do
begin
R := dayRec.Rect;
OffsetRect(R, FGanttView.FixedColWidth, 0);
OffsetRect(R, dx, 0);
if R.Left < FGanttView.FixedColWidth then
Continue;
if (DayOf(dayRec.Date) <> DaysInMonth(dayRec.Date)) then
begin
if FGanttView.DrawingStyle = ds3D then
@ -246,7 +254,10 @@ var
event: TVpEvent;
cat: TVpCategoryInfo;
R: TRect;
dx, dy: Integer;
begin
dx := FGanttView.FixedColWidth - FGanttView.LeftCol * FGanttView.ColWidth;
dy := FColHeadHeightTotal - FGanttView.TopRow * FRowHeight;
for i := 0 to High(TVpGanttViewOpener(FGanttView).FEventRecords) do
begin
eventRec := TVpGanttViewOpener(FGanttView).FEventRecords[i];
@ -256,8 +267,10 @@ begin
RenderCanvas.Brush.Color := cat.BackgroundColor;
R := eventRec.EventRect;
if R.Left = R.Right then R.Right := R.Left + 1;
OffsetRect(R, FGanttView.FixedColWidth, FColHeadHeightTotal);
OffsetRect(R, dx, dy);
InflateRect(R, 0, -2);
if (R.Top < FColHeadHeightTotal) or (R.Left < FGanttView.FixedColWidth) then
Continue;
TPSRectangle(RenderCanvas, Angle, RenderIn, R);
end;
end;
@ -322,6 +335,7 @@ var
strH: Integer;
str: String;
i: Integer;
dy: Integer;
begin
RenderCanvas.Brush.Color := RealRowHeadAttrColor;
@ -347,11 +361,14 @@ begin
RenderCanvas.Font.Assign(FGanttView.RowHeaderAttributes.EventFont);
strH := RenderCanvas.TextHeight('Tg');
RenderCanvas.Pen.Color := RealLineColor;
dy := FColHeadHeightTotal - FGanttView.TopRow * FRowHeight;
for i := 0 to High(TVpGanttViewOpener(FGanttView).FEventRecords) do
begin
str := TVpGanttViewOpener(FGanttView).FEventRecords[i].Caption;
R := TVpGanttViewOpener(FGanttView).FEventRecords[i].HeadRect;
OffsetRect(R, 0, FColHeadHeightTotal);
OffsetRect(R, 0, dy);
if R.Top < FColHeadHeightTotal then
Continue;
if FGanttView.DrawingStyle = ds3D then
begin
R.BottomRight := R.BottomRight - Point(1, 1);
@ -490,6 +507,8 @@ begin
SetLength(TVpGanttViewOpener(FGanttView).FEventRecords, 0);
SetLength(TVpGanttViewOpener(FGanttView).FDayRecords, 0);
SetLength(TVpGanttViewOpener(FGanttView).FMonthRecords, 0);
FGanttView.VisibleRows := 0;
FGanttView.VisibleCols := 0;
end else
begin
eventCount := FGanttView.Datastore.Resource.Schedule.EventCount;
@ -516,6 +535,7 @@ begin
lastDay := trunc(t2);
end;
lastDay := lastDay + 1;
FGanttView.StartDate := firstDay;
FGanttView.EndDate := lastDay;
@ -597,6 +617,11 @@ begin
dt := IncMonth(dt, 1);
x1 := x2;
end;
FGanttView.VisibleCols := (RealRight - RealLeft + FGanttView.FixedColWidth) div FGanttView.ColWidth;
FGanttView.VisibleRows := (RealBottom - RealTop + FColHeadHeightTotal) div FRowHeight;
FGanttView.RowCount := eventCount;
FGanttView.ColCount := numdays;
end;
end;