TAChart: Add event OnGetMarkText to TChartSeries providing more parameters. Deprecate OnGetMark. Issue #40647.

components/chmhelp/packages/help/lazhelpchm.pas

@@ -365,7 +365,7 @@ begin
   if Result<>shrSuccess then exit;
 
   if not (csDesigning in ComponentState) and
-    (KeywordPrefix<>'') and
+//    (KeywordPrefix<>'') and
     (LeftStr(HelpKeyword,length(KeywordPrefix))=KeywordPrefix) then
   begin
     // HelpKeyword starts with KeywordPrefix -> add default node

components/tachart/tacustomseries.pas

@@ -131,8 +131,12 @@ type
     property Transparency;
   end;
 
+  TChartSeries = class;
+
   TChartGetMarkEvent = procedure (
     out AFormattedMark: String; AIndex: Integer) of object;
+  TChartGetMarkTextEvent = procedure (ASeries: TChartSeries;
+    APointIndex, AXIndex, AYIndex: Integer; var AFormattedMark: String) of object;
 
   { TChartSeries }
 
@@ -142,6 +146,7 @@ type
     FListener: TListener;
     FMarks: TChartMarks;
     FOnGetMark: TChartGetMarkEvent;
+    FOnGetMarkText: TChartGetMarkTextEvent;
     FSource: TCustomChartSource;
     FStyles: TChartStyles;
     FStylesListener: TListener;
@@ -149,7 +154,8 @@ type
     function GetSource: TCustomChartSource;
     function IsSourceStored: boolean;
     procedure SetMarks(AValue: TChartMarks);
-    procedure SetOnGetMark(AValue: TChartGetMarkEvent);
+    procedure SetOnGetMark(AValue: TChartGetMarkEvent); deprecated;
+    procedure SetOnGetMarkText(AValue: TChartGetMarkTextEvent);
     procedure SetSource(AValue: TCustomChartSource);
     procedure SetStyles(AValue: TChartStyles);
   protected
@@ -222,8 +228,8 @@ type
     procedure EndUpdate;
     function Extent: TDoubleRect; virtual;
     procedure FindYRange(AXMin, AXMax: Double; var AYMin, AYMax: Double); virtual;
-    function FormattedMark(
-      AIndex: Integer; AFormat: String = ''; AYIndex: Integer = 0): String;
+    function FormattedMark(AIndex: Integer; AFormat: String = '';
+      AYIndex: Integer = 0; AXIndex: Integer = 0): String;
     function IsEmpty: Boolean; override;
     function ListSource: TListChartSource;
     property Marks: TChartMarks
@@ -247,7 +253,8 @@ type
     property Title;
     property ZPosition;
   published
-    property OnGetMark: TChartGetMarkEvent read FOnGetMark write SetOnGetMark;
+    property OnGetMark: TChartGetMarkEvent read FOnGetMark write SetOnGetMark; deprecated 'Use OnGetMarkText instead';  // To be removed in Laz 5
+    property OnGetMarkText: TChartGetMarkTextEvent read FOnGetMarkText write SetOnGetMarkText;
   end;
 
   TLabelDirection = (ldLeft, ldTop, ldRight, ldBottom);
@@ -795,6 +802,7 @@ begin
     with TChartSeries(ASource) do begin
       Self.Marks.Assign(FMarks);
       Self.FOnGetMark := FOnGetMark;
+      Self.FOnGetMarkText := FOnGetMarkText;
       Self.Source := FSource;
       Self.Styles := FStyles;
     end;
@@ -888,14 +896,18 @@ begin
   Source.FindYRange(AXMin, AXMax, false, AYMin, AYMax);
 end;
 
-function TChartSeries.FormattedMark(
-  AIndex: Integer; AFormat: String; AYIndex: Integer): String;
+function TChartSeries.FormattedMark(AIndex: Integer; AFormat: String;
+  AYIndex, AXIndex: Integer): String;
 begin
   if Assigned(FOnGetMark) then
     FOnGetMark(Result, AIndex)
   else
+  begin
     Result := Source.FormatItem(
       IfThen(AFormat = '', Marks.Format, AFormat), AIndex, AYIndex);
+    if Assigned(FOnGetMarkText) then
+      FOnGetMarkText(Self, AIndex, AXIndex, AYIndex, Result)
+  end;
 end;
 
 procedure TChartSeries.GetBounds(var ABounds: TDoubleRect);
@@ -1114,6 +1126,13 @@ begin
   UpdateParentChart;
 end;
 
+procedure TChartSeries.SetOnGetMarkText(AValue: TChartGetMarkTextEvent);
+begin
+  if TMethod(FOnGetMarkText) = TMethod(AValue) then exit;
+  FOnGetMarkText := AValue;
+  UpdateParentChart;
+end;
+
 procedure TChartSeries.SetSource(AValue: TCustomChartSource);
 begin
   if AValue = FBuiltinSource then

lcl/dbgrids.pas

@@ -78,8 +78,9 @@ type
   TDbGridOptions = set of TDbGridOption;
 
   TDbGridExtraOption = (
-    dgeAutoColumns,       // if uncustomized columns, add them anyway?
-    dgeCheckboxColumn     // enable the use of checkbox in columns
+    dgeAutoColumns,          // if uncustomized columns, add them anyway?
+    dgeCheckboxColumn,       // enable the use of checkbox in columns
+    dgeMouseWheelPageScroll  // forces the mouse-wheel to scroll by pages
   );
   TDbGridExtraOptions = set of TDbGridExtraOption;
 
@@ -614,6 +615,7 @@ type
     property HeaderPushZones;
     //property ImeMode;
     //property ImeName;
+    property MouseWheelSpeedupKey;
     property Options;
     property Options2;
     property OptionsExtra;
@@ -3070,29 +3072,129 @@ begin
   {$ifdef dbgDBGrid}DebugLnExit('%s.DoExit DONE', [ClassName]);{$endif}
 end;
 
+function SpeedupKeyPressed(Shift: TShiftState; SpeedupKey: TMouseWheelSpeedupKey): Boolean;
+begin
+  case SpeedupKey of
+    mwskNone:
+      Result := false;
+    mwskShift:
+      Result := (Shift = [ssShift]);
+    mwskCtrl:
+      Result := (Shift * [ssCtrl, ssMeta] <> []);   // check also ssMeta for Mac
+    mwskShiftCtrl:
+      Result := (Shift * [ssCtrl, ssMeta] <> []) and (Shift * [ssShift] <> []);
+  end;
+end;
+
+(*
 function TCustomDBGrid.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint
   ): Boolean;
+var
+  delta: Integer;
 begin
   Result := False;
   if Assigned(OnMouseWheelDown) then
     OnMouseWheelDown(Self, Shift, MousePos, Result);
   if not Result and FDatalink.Active then begin
-    FDatalink.MoveBy(1);
+    if (dgeMouseWheelPageScroll in FExtraOptions) or SpeedupKeyPressed(Shift, MouseWheelSpeedupKey) then
+    begin
+      if Row < VisibleRowCount then
+        delta := VisibleRowCount - Row
+      else
+        delta := VisibleRowCount;
+    end else
+      delta := 1;
+    FDatalink.MoveBy(delta);
     Result := True;
   end;
 end;
 
 function TCustomDBGrid.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint
   ): Boolean;
+var
+  delta: Integer;
 begin
   Result := False;
   if Assigned(OnMouseWheelUp) then
     OnMouseWheelUp(Self, Shift, MousePos, Result);
   if not Result and FDatalink.Active then begin
-    FDatalink.MoveBy(-1);
+    if (dgeMouseWheelPageScroll in FExtraOptions) or SpeedupKeyPressed(Shift, MouseWheelSpeedupKey) then
+    begin
+      if Row > 1 then
+        delta := Row - 1
+      else
+        delta := VisibleRowCount;
+    end
+    else
+      delta := 1;
+    FDatalink.MoveBy(-delta);
     Result := True;
   end;
 end;
+*)
+function TCustomDBGrid.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint
+  ): Boolean;
+var
+  delta, row1: Integer;
+  bBack: Boolean;
+begin
+  Result := False;
+  if Assigned(OnMouseWheelDown) then
+    OnMouseWheelDown(Self, Shift, MousePos, Result);
+  if not Result and FDatalink.Active then begin
+    if (dgeMouseWheelPageScroll in FExtraOptions) or SpeedupKeyPressed(Shift, MouseWheelSpeedupKey) then
+    begin
+      row1 := Row;
+      if Row < VisibleRowCount then
+        delta := VisibleRowCount * 2 - Row
+      else
+        delta := VisibleRowCount;
+      bBack := True;
+    end else Begin
+      bBack := False;
+      delta := 1;
+    End;
+    if FDatalink.MoveBy(delta) <> delta then
+    begin
+      FDatalink.MoveBy(1);
+      bBack := False;
+    end;
+    if bBack then
+      FDatalink.MoveBy(-(Row - row1));
+    Result := True;
+  end;
+end;
+
+function TCustomDBGrid.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint
+  ): Boolean;
+var
+  delta, row1: Integer;
+  bBack: Boolean;
+begin
+  Result := False;
+  if Assigned(OnMouseWheelUp) then
+    OnMouseWheelUp(Self, Shift, MousePos, Result);
+  if not Result and FDatalink.Active then begin
+    if (dgeMouseWheelPageScroll in FExtraOptions) or SpeedupKeyPressed(Shift, MouseWheelSpeedupKey) then
+    begin
+      row1 := Row - 1;
+      delta := VisibleRowCount + Row - 1;
+      bBack := True;
+    end else Begin
+      bBack := False;
+      delta := 1;
+    End;
+    if FDatalink.MoveBy(-delta) <> -delta then
+    begin
+      FDatalink.MoveBy(-1);
+      bBack := False;
+    end;
+    if bBack then
+      FDatalink.MoveBy(row1);
+    Result := True;
+  end;
+end;
+
 
 function TCustomDBGrid.GetEditMask(aCol, aRow: Longint): string;
 var

lcl/grids.pas

@@ -146,6 +146,8 @@ type
   TAutoAdvance = (aaNone,aaDown,aaRight,aaLeft, aaRightDown, aaLeftDown,
     aaRightUp, aaLeftUp);
 
+  TMouseWheelSpeedupKey = (mwskNone, mwskShift, mwskCtrl, mwskShiftCtrl);
+
   { Option goRangeSelect: --> select a single range only, or multiple ranges }
   TRangeSelectMode = (rsmSingle, rsmMulti);
 
@@ -843,6 +845,7 @@ type
     FSizing: TSizingRec;
     FRowAutoInserted: Boolean;
     FMouseWheelOption: TMouseWheelOption;
+    FMouseWheelSpeedupKey: TMouseWheelSpeedupKey;
     FSavedHint: String;
     FCellHintPriority: TCellHintPriority;
     FOnGetCellHint: TGetCellHintEvent;
@@ -1277,6 +1280,7 @@ type
     property IsCellSelected[aCol,aRow: Integer]: boolean read GetIsCellSelected;
     property LeftCol:Integer read GetLeftCol write SetLeftCol;
     property MouseWheelOption: TMouseWheelOption read FMouseWheelOption write FMouseWheelOption default mwCursor;
+    property MouseWheelSpeedupKey: TMouseWheelSpeedupKey read FMouseWheelSpeedupKey write FMouseWheelSpeedupKey default mwskCtrl;
     property Options: TGridOptions read FOptions write SetOptions default DefaultGridOptions;
     property Options2: TGridOptions2 read FOptions2 write SetOptions2 default DefaultGridOptions2;
     property RangeSelectMode: TRangeSelectMode read FRangeSelectMode write SetRangeSelectMode default rsmSingle;
@@ -10073,6 +10077,8 @@ begin
   FSpecialCursors[gcsRowHeightChanging] := crVSplit;
   FSpecialCursors[gcsDragging] := crMultiDrag;
 
+  FMouseWheelSpeedupKey := mwskCtrl;
+
   varRubberSpace := Scale96ToScreen(constRubberSpace);
   varCellPadding := Scale96ToScreen(constCellPadding);
   varColRowBorderTolerance := Scale96ToScreen(constColRowBorderTolerance);
@@ -11634,6 +11640,12 @@ begin
           tmpCanvas.Font := Font;
       end;
 
+      if Assigned(FOnPrepareCanvas) then
+      begin
+        FOnPrepareCanvas(self, aCol, i, []);
+        tmpCanvas.Font := Canvas.Font;
+      end;
+
       if (i=0) and (FixedRows>0) and (C<>nil) then
         aText := C.Title.Caption
       else

lcl/lazhelphtml.pas

@@ -244,7 +244,7 @@ begin
   if Result<>shrSuccess then exit;
 
   if not (csDesigning in ComponentState)
-  and (KeywordPrefix<>'')
+  //and (KeywordPrefix<>'')
   and (LeftStr(HelpKeyword,length(KeywordPrefix))=KeywordPrefix) then begin
     // HelpKeyword starts with KeywordPrefix -> add default node
     if FKeywordPrefixNode=nil then