518 lines
15 KiB
ObjectPascal
518 lines
15 KiB
ObjectPascal
|
|
{******************************************}
|
|
{ }
|
|
{ FastReport VCL }
|
|
{ ListBox Add-In Object }
|
|
{ }
|
|
{ Copyright (c) 1998-2022 }
|
|
{ by Fast Reports Inc. }
|
|
{ }
|
|
{******************************************}
|
|
|
|
unit frxListBox;
|
|
|
|
interface
|
|
|
|
{$I frx.inc}
|
|
|
|
uses
|
|
{$IFNDEF Linux}
|
|
Windows,
|
|
{$ELSE}
|
|
LCLType, LCLIntf, LCLProc,
|
|
{$ENDIF}
|
|
Classes, Graphics, Types, Controls,
|
|
frxClass, frxListControl;
|
|
|
|
type
|
|
TScrollBoxMousePlace = (cpAbove, cpCenter, cpBelow);
|
|
|
|
TfrxVerticalScrollBar = class(TfrxRightEdge)
|
|
private
|
|
FContentHeight: Extended;
|
|
FControlHeight: Extended;
|
|
FContentLineCount: Integer;
|
|
FTopLineIndex: Integer;
|
|
FDownTopLineIndex: Integer;
|
|
FMouseCaptured: Boolean;
|
|
FDownPlace: TScrollBoxMousePlace;
|
|
FDownY: Integer;
|
|
FCurrentY: Integer;
|
|
FScrollBoxTop: Extended;
|
|
FScrollBoxBottom: Extended;
|
|
FScrollBoxStep: Extended;
|
|
FMaxTopLineIndex: Integer;
|
|
FWheelStepNumber: Integer;
|
|
FInitialized: Boolean;
|
|
|
|
procedure SetTopLineIndex(const Value: Integer);
|
|
protected
|
|
function CalcPlace(Y: Integer): TScrollBoxMousePlace;
|
|
procedure SquareLineTo(Canvas: TCanvas; X, Y: Integer);
|
|
function MixColor(C1, C2: TColor): TColor;
|
|
public
|
|
procedure Init(AContentHeight, AControlHeight: Extended; Rect: TRect; AContentLineCount: Integer);
|
|
procedure Draw(Canvas: TCanvas; ScaleX, ScaleY: Extended); override;
|
|
function IsVisible: Boolean;
|
|
|
|
function DoMouseDown(X, Y: Integer): Boolean;
|
|
procedure DoMouseUp;
|
|
procedure DoMouseMove(X, Y: Integer);
|
|
function DoMouseWheel(WheelDelta: Integer): Boolean;
|
|
|
|
property MouseCaptured: Boolean read FMouseCaptured;
|
|
property TopLineIndex: Integer read FTopLineIndex write SetTopLineIndex;
|
|
property Initialized: Boolean read FInitialized;
|
|
end;
|
|
|
|
{$IFDEF DELPHI16}
|
|
/// <summary>
|
|
/// The TfrxListBoxObject allows the use of the TfrxListBoxView component in
|
|
/// your report. TfrxListControlObject is an empty component. It is used to
|
|
/// add the frxListBox.pas file to the "uses" list.
|
|
/// </summary>
|
|
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
|
|
{$ENDIF}
|
|
TfrxListBoxObject = class(TComponent) // fake component
|
|
end;
|
|
|
|
/// <summary>
|
|
/// TfrxListBoxView displays a collection of items in a scrollable list.
|
|
/// Use TfrxListBoxView to display a scrollable list of items that users can
|
|
/// select, add, or delete.
|
|
/// </summary>
|
|
TfrxListBoxView = class(TfrxCustomListControlView)
|
|
private
|
|
function GetTopLineIndex: Integer;
|
|
protected
|
|
FContentHeight: Extended;
|
|
FMouseCaptured: Boolean;
|
|
FScrollBar: TfrxVerticalScrollBar;
|
|
|
|
function IsChangeItemIndex(const Y: Integer): Boolean;
|
|
function IsScrollBarAllowed: Boolean;
|
|
function NoScrollBar(Rect: TRect): TRect; override;
|
|
procedure DrawText;
|
|
procedure SetDrawParams(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended);
|
|
procedure FillMemoText(Memo: TfrxCustomMemoView); override;
|
|
|
|
function DoMouseDown(X, Y: Integer; Button: TMouseButton; Shift: TShiftState;
|
|
var EventParams: TfrxInteractiveEventsParams): Boolean; override;
|
|
procedure DoMouseUp(X, Y: Integer; Button: TMouseButton; Shift: TShiftState;
|
|
var EventParams: TfrxInteractiveEventsParams); override;
|
|
procedure DoMouseMove(X, Y: Integer; Shift: TShiftState;
|
|
var EventParams: TfrxInteractiveEventsParams); override;
|
|
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint;
|
|
var EventParams: TfrxInteractiveEventsParams): Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
class function GetDescription: string; override;
|
|
procedure Draw(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended); override;
|
|
|
|
property TopLineIndex: Integer read GetTopLineIndex;
|
|
published
|
|
property AllowExpressions;
|
|
property BrushStyle;
|
|
property Color;
|
|
property Cursor;
|
|
property DataField;
|
|
property DataSet;
|
|
property DataSetName;
|
|
property Editable default [ferAllowInPreview];
|
|
property ExpressionDelimiters;
|
|
property Font;
|
|
property Frame;
|
|
property FillType;
|
|
property Fill;
|
|
property ItemIndex; // hidden
|
|
property Items;
|
|
property ItemsText; // hidden
|
|
property ParentFont;
|
|
property TagStr;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
Math,
|
|
{$IfDef DELPHI16}System.UITypes,{$EndIf}
|
|
frxListBoxRTTI, frxDsgnIntf, frxCustomEditors, frxListControlEditor, frxRes,
|
|
frxHelpers, frxAnaliticGeometry, frxUtils;
|
|
|
|
const
|
|
meCompleted = True;
|
|
PlaceShift: array[TScrollBoxMousePlace] of integer = (-1, 0, 1);
|
|
|
|
type
|
|
TfrxListBoxEditor = class(TfrxViewEditor)
|
|
private
|
|
public
|
|
function Edit: Boolean; override;
|
|
function HasEditor: Boolean; override;
|
|
end;
|
|
|
|
{ TfrxListBoxEditor }
|
|
|
|
function TfrxListBoxEditor.Edit: Boolean;
|
|
begin
|
|
with TfrxListControlEditorForm.Create(Designer) do
|
|
try
|
|
ListControlView := TfrxListBoxView(Component);
|
|
Caption := frxGet(3940);
|
|
Result := ShowModal = mrOk;
|
|
finally
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
function TfrxListBoxEditor.HasEditor: Boolean;
|
|
begin
|
|
Result := True;
|
|
end;
|
|
|
|
{ Utilities }
|
|
|
|
{ TfrxListBoxView }
|
|
|
|
constructor TfrxListBoxView.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
|
|
FScrollBar := TfrxVerticalScrollBar.Create;
|
|
end;
|
|
|
|
destructor TfrxListBoxView.Destroy;
|
|
begin
|
|
FScrollBar.Free;
|
|
|
|
inherited;
|
|
end;
|
|
|
|
function TfrxListBoxView.DoMouseDown(X, Y: Integer; Button: TMouseButton; Shift: TShiftState; var EventParams: TfrxInteractiveEventsParams): Boolean;
|
|
begin
|
|
Result := IsPreview(EventParams) and IsLeft(Button) and (ferAllowInPreview in Editable);
|
|
|
|
if not Result then
|
|
Result := inherited DoMouseDown(X, Y, Button, Shift, EventParams)
|
|
else
|
|
if FScrollBar.DoMouseDown(XCorrected(X), YCorrected(Y)) then
|
|
EventParams.Refresh := True
|
|
else
|
|
begin
|
|
EventParams.Refresh := IsChangeItemIndex(YCorrected(Y));
|
|
EventParams.Modified := EventParams.Refresh;
|
|
FMouseCaptured := True;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxListBoxView.DoMouseMove(X, Y: Integer; Shift: TShiftState; var EventParams: TfrxInteractiveEventsParams);
|
|
begin
|
|
if IsPreview(EventParams) and (ferAllowInPreview in Editable) then
|
|
begin
|
|
if (FMouseCaptured or FScrollBar.MouseCaptured) and not (ssLeft in Shift) then
|
|
DoMouseUp(X, Y, mbLeft, Shift, EventParams);
|
|
|
|
if FScrollBar.MouseCaptured then
|
|
begin
|
|
FScrollBar.DoMouseMove(XCorrected(X), YCorrected(Y));
|
|
EventParams.Refresh := True;
|
|
end
|
|
else
|
|
begin
|
|
EventParams.Refresh := FMouseCaptured and IsChangeItemIndex(YCorrected(Y));
|
|
EventParams.Modified := EventParams.Refresh;
|
|
end;
|
|
end
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfrxListBoxView.DoMouseUp(X, Y: Integer; Button: TMouseButton; Shift: TShiftState; var EventParams: TfrxInteractiveEventsParams);
|
|
begin
|
|
if IsPreview(EventParams) and IsLeft(Button) and (ferAllowInPreview in Editable) then
|
|
begin
|
|
FScrollBar.DoMouseUp;
|
|
FMouseCaptured := False;
|
|
EventParams.Refresh := True;
|
|
end
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
function TfrxListBoxView.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var EventParams: TfrxInteractiveEventsParams): Boolean;
|
|
begin
|
|
if IsPreview(EventParams) and (ferAllowInPreview in Editable) then
|
|
begin
|
|
EventParams.Refresh := FScrollBar.DoMouseWheel(WheelDelta);
|
|
Result := meCompleted;
|
|
end
|
|
else
|
|
Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos, EventParams);
|
|
end;
|
|
|
|
procedure TfrxListBoxView.Draw(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended);
|
|
begin
|
|
if IsScrollBarAllowed and not FScrollBar.Initialized then
|
|
begin
|
|
BeginDraw(Canvas, ScaleX, ScaleY, OffsetX, OffsetY);
|
|
SetDrawParams(Canvas, ScaleX, ScaleY, OffsetX, OffsetY);
|
|
FScrollBar.Init(FContentHeight, Height, Rect(FX, FY, FX1, FY1), Items.Count);
|
|
end;
|
|
|
|
inherited Draw(Canvas, ScaleX, ScaleY, OffsetX, OffsetY);
|
|
if Color = clNone then
|
|
Canvas.Brush.Style := bsClear;
|
|
DrawText;
|
|
|
|
if IsScrollBarAllowed then
|
|
begin
|
|
FScrollBar.Init(FContentHeight, Height, Rect(FX, FY, FX1, FY1), Items.Count);
|
|
FScrollBar.Draw(Canvas, ScaleX, ScaleY);
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxListBoxView.DrawText;
|
|
begin
|
|
if IsDataField then
|
|
Items.Text := '[' + DataSet.UserName + '."' + DataField + '"]';
|
|
|
|
FDrawText := GetDrawTextObject;
|
|
FDrawText.Lock;
|
|
try
|
|
SetDrawParams(FCanvas, FScaleX, FScaleY, FOffsetX, FOffsetY);
|
|
FDrawText.DrawText(FCanvas, haLeft, vaTop, ulmNone, ItemIndex - TopLineIndex);
|
|
FLineY := FDrawText.GetLineY;
|
|
finally
|
|
FDrawText.Unlock;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxListBoxView.FillMemoText(Memo: TfrxCustomMemoView);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Memo.Lines.Text := Items.Text;
|
|
for i := 0 to TopLineIndex - 1 do
|
|
Memo.Lines.Delete(0);
|
|
end;
|
|
|
|
class function TfrxListBoxView.GetDescription: String;
|
|
begin
|
|
Result := frxResources.Get('obListBox');
|
|
end;
|
|
|
|
function TfrxListBoxView.GetTopLineIndex: Integer;
|
|
begin
|
|
Result := FScrollBar.TopLineIndex;
|
|
end;
|
|
|
|
function TfrxListBoxView.IsChangeItemIndex(const Y: Integer): Boolean;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := False;
|
|
for i := 0 to Items.Count - 1 do
|
|
if (Y >= FLineY[i]) and (Y < FLineY[i + 1]) then
|
|
begin
|
|
Result := i + TopLineIndex <> ItemIndex;
|
|
ItemIndex := i + TopLineIndex;
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
function TfrxListBoxView.IsScrollBarAllowed: Boolean;
|
|
var
|
|
IsPreviewing, IsExporting, IsInteractiveForms: Boolean;
|
|
begin
|
|
IsExporting := csFrxExporting in frComponentState;
|
|
IsPreviewing := not (IsDesigning or IsExporting);
|
|
IsInteractiveForms := csFrxInteractiveForms in frComponentState;
|
|
Result := (IsExporting and IsInteractiveForms and (ferAllowInExport in Editable)) or
|
|
(IsPreviewing and (ferAllowInPreview in Editable));
|
|
end;
|
|
|
|
function TfrxListBoxView.NoScrollBar(Rect: TRect): TRect;
|
|
begin
|
|
if IsScrollBarAllowed and FScrollBar.IsVisible then
|
|
Result := inherited NoScrollBar(Rect)
|
|
else
|
|
Result := Rect;
|
|
end;
|
|
|
|
procedure TfrxListBoxView.SetDrawParams(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended);
|
|
begin
|
|
DrawTextInit;
|
|
DrawTextDimensions(ScaleX, ScaleY, OffsetX, OffsetY);
|
|
|
|
FDrawText.SetText(Items, False {FFirstParaBreak}); // full content height
|
|
FContentHeight := FDrawText.CalcHeight;
|
|
if TopLineIndex > 0 then
|
|
FDrawText.SetText(Items, False {FFirstParaBreak}, TopLineIndex);
|
|
end;
|
|
|
|
{ TfrxVerticalScrollBar }
|
|
|
|
function TfrxVerticalScrollBar.CalcPlace(Y: Integer): TScrollBoxMousePlace;
|
|
begin
|
|
if Y < FScrollBoxTop then
|
|
Result := cpAbove
|
|
else if Y > FScrollBoxBottom then
|
|
Result := cpBelow
|
|
else
|
|
Result := cpCenter;
|
|
end;
|
|
|
|
function TfrxVerticalScrollBar.DoMouseDown(X, Y: Integer): Boolean;
|
|
begin
|
|
Result := IsVisible and IsInside(X, Y);
|
|
if Result then
|
|
begin
|
|
FMouseCaptured := True;
|
|
FDownY := Y;
|
|
FCurrentY := Y;
|
|
FDownPlace := CalcPlace(Y);
|
|
case FDownPlace of
|
|
cpAbove, cpBelow:
|
|
TopLineIndex := TopLineIndex + PlaceShift[FDownPlace];
|
|
cpCenter:
|
|
FDownTopLineIndex := TopLineIndex;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxVerticalScrollBar.DoMouseMove(X, Y: Integer);
|
|
begin
|
|
if not IsVisible then
|
|
Exit;
|
|
|
|
FCurrentY := Y;
|
|
if MouseCaptured then
|
|
case FDownPlace of
|
|
cpAbove, cpBelow:
|
|
if FDownPlace = CalcPlace(Y) then
|
|
TopLineIndex := TopLineIndex + PlaceShift[FDownPlace];
|
|
cpCenter:
|
|
TopLineIndex := FDownTopLineIndex - Round((FDownY - FCurrentY) / FScrollBoxStep);
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxVerticalScrollBar.DoMouseUp;
|
|
begin
|
|
FMouseCaptured := False;
|
|
end;
|
|
|
|
function TfrxVerticalScrollBar.DoMouseWheel(WheelDelta: Integer): Boolean;
|
|
begin
|
|
Inc(FWheelStepNumber);
|
|
if FWheelStepNumber mod 3 = 0 then
|
|
TopLineIndex := TopLineIndex - Sign(WheelDelta);
|
|
Result := meCompleted;
|
|
end;
|
|
|
|
procedure TfrxVerticalScrollBar.Draw(Canvas: TCanvas; ScaleX, ScaleY: Extended);
|
|
const
|
|
Gap = 2;
|
|
var
|
|
Part, ScrollBoxLength, ScrollBoxX: Extended;
|
|
ControlLineCount: Integer;
|
|
begin
|
|
inherited Draw(Canvas, ScaleX, ScaleY);
|
|
|
|
if not IsVisible then
|
|
Exit;
|
|
|
|
Part := FControlHeight / FContentHeight;
|
|
ScrollBoxLength := FControlHeight * Part * ScaleY;
|
|
ControlLineCount := Floor(FContentLineCount * Part);
|
|
|
|
FMaxTopLineIndex := FContentLineCount - ControlLineCount;
|
|
FScrollBoxStep := (FControlHeight * ScaleY - ScrollBoxLength) / FMaxTopLineIndex;
|
|
|
|
Canvas.Pen.Color := IfColor(MouseCaptured,
|
|
Canvas.Font.Color,
|
|
MixColor(Canvas.Brush.Color, Canvas.Font.Color));
|
|
|
|
Canvas.Pen.Width := Round(FRect.Right - FRect.Left) - 2 * Gap;
|
|
|
|
FScrollBoxTop := FRect.Top + IfReal(MouseCaptured and (FDownPlace = cpCenter),
|
|
FScrollBoxStep * FDownTopLineIndex - (FDownY - FCurrentY),
|
|
FScrollBoxStep * TopLineIndex);
|
|
|
|
FScrollBoxTop := Limit(FScrollBoxTop, FRect.Top, FRect.Bottom - ScrollBoxLength);
|
|
FScrollBoxBottom := FScrollBoxTop + ScrollBoxLength;
|
|
|
|
ScrollBoxX := (FRect.Left + FRect.Right) / 2;
|
|
Canvas.MoveTo(Round(ScrollBoxX), Round(FScrollBoxTop + Gap));
|
|
SquareLineTo(Canvas, Round(ScrollBoxX), Round(FScrollBoxBottom - Gap));
|
|
end;
|
|
|
|
procedure TfrxVerticalScrollBar.Init(AContentHeight, AControlHeight: Extended; Rect: TRect; AContentLineCount: Integer);
|
|
begin
|
|
inherited Init(Rect);
|
|
|
|
FContentHeight := AContentHeight;
|
|
FControlHeight := AControlHeight;
|
|
FContentLineCount := AContentLineCount;
|
|
end;
|
|
|
|
function TfrxVerticalScrollBar.IsVisible: Boolean;
|
|
begin
|
|
Result := FContentHeight > FControlHeight;
|
|
end;
|
|
|
|
function TfrxVerticalScrollBar.MixColor(C1, C2: TColor): TColor;
|
|
begin
|
|
Result := RGB(
|
|
Round(GetRValue(C1) / 2 + GetRValue(C2) / 2),
|
|
Round(GetGValue(C1) / 2 + GetGValue(C2) / 2),
|
|
Round(GetBValue(C1) / 2 + GetBValue(C2) / 2));
|
|
end;
|
|
|
|
procedure TfrxVerticalScrollBar.SetTopLineIndex(const Value: Integer);
|
|
begin
|
|
FTopLineIndex := Limit(Value, 0, FMaxTopLineIndex);
|
|
end;
|
|
|
|
procedure TfrxVerticalScrollBar.SquareLineTo(Canvas: TCanvas; X, Y: Integer);
|
|
var
|
|
LG: TLogBrush;
|
|
PenSt: DWORD;
|
|
hP: HPEN;
|
|
OldPen: HGDIOBJ;
|
|
begin
|
|
LG.lbStyle := BS_SOLID;
|
|
LG.lbColor := Canvas.Pen.Color;
|
|
LG.lbHatch := 0;
|
|
PenSt := PS_GEOMETRIC or PS_ENDCAP_FLAT;
|
|
|
|
hP := ExtCreatePen(PenSt, Canvas.Pen.Width, LG, 0, nil);
|
|
if hP = 0 then
|
|
Canvas.LineTo(X, Y)
|
|
else
|
|
begin
|
|
OldPen := SelectObject(Canvas.Handle, Hp);
|
|
Canvas.LineTo(X, Y);
|
|
SelectObject(Canvas.Handle, OldPen);
|
|
DeleteObject(hP);
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
{$IFDEF DELPHI16}
|
|
StartClassGroup(TControl);
|
|
ActivateClassGroup(TControl);
|
|
GroupDescendentsWith(TfrxListBoxObject, TControl);
|
|
{$ENDIF}
|
|
|
|
frxObjects.RegisterObject1(TfrxListBoxView, nil, frxResources.Get('obListBox'), '', 0, 86);
|
|
frxHideProperties(TfrxListBoxView, 'ItemIndex');
|
|
frxHideProperties(TfrxListBoxView, 'ItemsText');
|
|
|
|
frxComponentEditors.Register(TfrxListBoxView, TfrxListBoxEditor);
|
|
|
|
finalization
|
|
frxObjects.UnRegister(TfrxListBoxView);
|
|
|
|
end.
|