david
78ab77cd4c
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.jvcl@19 7f62d464-2af8-f54e-996c-e91b33f51cbe
353 lines
10 KiB
ObjectPascal
353 lines
10 KiB
ObjectPascal
{-----------------------------------------------------------------------------
|
|
The contents of this file are subject to the Mozilla Public License
|
|
Version 1.1 (the "License"); you may not use this file except in compliance
|
|
with the License. You may obtain a copy of the License at
|
|
http://www.mozilla.org/MPL/MPL-1.1.html
|
|
|
|
Software distributed under the License is distributed on an "AS IS" basis,
|
|
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
|
|
the specific language governing rights and limitations under the License.
|
|
|
|
The Original Code is: JvScrollBox.PAS, released on 2001-02-28.
|
|
|
|
The Initial Developer of the Original Code is Sébastien Buysse [sbuysse att buypin dott com]
|
|
Portions created by Sébastien Buysse are Copyright (C) 2001 Sébastien Buysse.
|
|
All Rights Reserved.
|
|
|
|
Contributor(s): Michael Beck [mbeck att bigfoot dott com].
|
|
|
|
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
|
|
located at http://jvcl.delphi-jedi.org
|
|
|
|
Known Issues:
|
|
-----------------------------------------------------------------------------}
|
|
// $Id: JvScrollBox.pas 12461 2009-08-14 17:21:33Z obones $
|
|
|
|
unit JvScrollBox;
|
|
|
|
{$I jvcl.inc}
|
|
{$I vclonly.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF UNITVERSIONING}
|
|
JclUnitVersioning,
|
|
{$ENDIF UNITVERSIONING}
|
|
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
|
|
JvExControls, JvExForms, JvJVCLUtils;
|
|
|
|
type
|
|
TEraseBackgroundEvent = procedure(Sender: TObject; Canvas: TCanvas; var Result: Boolean) of object;
|
|
|
|
TJvScrollBoxFillMode = (sfmTile, sfmStretch, sfmNone);
|
|
|
|
TJvScrollBox = class(TJvExScrollBox)
|
|
private
|
|
FHotTrack: Boolean;
|
|
FOnHorizontalScroll: TNotifyEvent;
|
|
FOnVerticalScroll: TNotifyEvent;
|
|
FOnPaint: TNotifyEvent;
|
|
FCanvas: TCanvas;
|
|
FOnEraseBackground: TEraseBackgroundEvent;
|
|
FBackground: TJvPicture;
|
|
FBackgroundFillMode: TJvScrollBoxFillMode;
|
|
procedure SetHotTrack(const Value: Boolean);
|
|
procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
|
|
procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;
|
|
procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;
|
|
procedure SetBackground(const Value: TPicture);
|
|
procedure SetBackgroundFillMode(const Value: TJvScrollBoxFillMode);
|
|
function GetBackground: TPicture;
|
|
protected
|
|
procedure GetDlgCode(var Code: TDlgCodes); override;
|
|
procedure MouseEnter(Control: TControl); override;
|
|
procedure MouseLeave(Control: TControl); override;
|
|
procedure WndProc(var Msg: TMessage); override;
|
|
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
|
|
procedure PaintWindow(DC: HDC); override;
|
|
procedure Paint; virtual;
|
|
function DoEraseBackground(Canvas: TCanvas; Param: Integer): Boolean; override;
|
|
procedure PaintBackground;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
property Canvas: TCanvas read FCanvas;
|
|
published
|
|
property Background: TPicture read GetBackground write SetBackground;
|
|
property BackgroundFillMode: TJvScrollBoxFillMode read FBackgroundFillMode write SetBackgroundFillMode default sfmTile;
|
|
property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
|
|
property HintColor;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnParentColorChange;
|
|
property OnVerticalScroll: TNotifyEvent read FOnVerticalScroll write FOnVerticalScroll;
|
|
property OnHorizontalScroll: TNotifyEvent read FOnHorizontalScroll write FOnHorizontalScroll;
|
|
property OnKeyDown;
|
|
property OnKeyPress;
|
|
property OnKeyUp;
|
|
property TabStop;
|
|
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
|
|
property OnEraseBackground: TEraseBackgroundEvent read FOnEraseBackground write FOnEraseBackground;
|
|
end;
|
|
|
|
{$IFDEF UNITVERSIONING}
|
|
const
|
|
UnitVersioning: TUnitVersionInfo = (
|
|
RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/tags/JVCL3_39/run/JvScrollBox.pas $';
|
|
Revision: '$Revision: 12461 $';
|
|
Date: '$Date: 2009-08-14 19:21:33 +0200 (ven., 14 août 2009) $';
|
|
LogPath: 'JVCL\run'
|
|
);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
implementation
|
|
|
|
uses
|
|
JvThemes;
|
|
|
|
constructor TJvScrollBox.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FHotTrack := False;
|
|
ControlStyle := ControlStyle + [csAcceptsControls];
|
|
IncludeThemeStyle(Self, [csNeedsBorderPaint]);
|
|
FCanvas := TControlCanvas.Create;
|
|
TControlCanvas(FCanvas).Control := Self;
|
|
|
|
// We use a TJvPicture to allow silent migration from TJvgScrollBox
|
|
// where background was a TBitmap.
|
|
FBackground := TJvPicture.Create;
|
|
FBackgroundFillMode := sfmTile;
|
|
end;
|
|
|
|
destructor TJvScrollBox.Destroy;
|
|
begin
|
|
FCanvas.Free;
|
|
FBackground.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJvScrollBox.WMHScroll(var Msg: TWMHScroll);
|
|
begin
|
|
inherited;
|
|
if Assigned(FOnHorizontalScroll) then
|
|
FOnHorizontalScroll(Self);
|
|
end;
|
|
|
|
procedure TJvScrollBox.WMVScroll(var Msg: TWMVScroll);
|
|
begin
|
|
inherited;
|
|
if Assigned(FOnVerticalScroll) then
|
|
FOnVerticalScroll(Self);
|
|
end;
|
|
|
|
procedure TJvScrollBox.MouseEnter(Control: TControl);
|
|
begin
|
|
if csDesigning in ComponentState then
|
|
Exit;
|
|
if not MouseOver then
|
|
begin
|
|
if FHotTrack then
|
|
Ctl3D := True;
|
|
inherited MouseEnter(Control);
|
|
end;
|
|
end;
|
|
|
|
procedure TJvScrollBox.MouseLeave(Control: TControl);
|
|
begin
|
|
if MouseOver then
|
|
begin
|
|
if FHotTrack then
|
|
Ctl3D := False;
|
|
inherited MouseLeave(Control);
|
|
end;
|
|
end;
|
|
|
|
procedure TJvScrollBox.SetHotTrack(const Value: Boolean);
|
|
begin
|
|
FHotTrack := Value;
|
|
if Value then
|
|
Ctl3D := False;
|
|
end;
|
|
|
|
procedure TJvScrollBox.SetBackground(const Value: TPicture);
|
|
begin
|
|
FBackground.Assign(Value);
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TJvScrollBox.SetBackgroundFillMode(const Value: TJvScrollBoxFillMode);
|
|
begin
|
|
if FBackgroundFillMode <> Value then
|
|
begin
|
|
FBackgroundFillMode := Value;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
function TJvScrollBox.GetBackground: TPicture;
|
|
begin
|
|
// Required because FBackground is a TJvPicture and as such cannot be
|
|
// used directly in the property declaration.
|
|
Result := FBackground;
|
|
end;
|
|
|
|
procedure TJvScrollBox.GetDlgCode(var Code: TDlgCodes);
|
|
begin
|
|
Code := [dcWantAllKeys, dcWantArrows];
|
|
end;
|
|
|
|
procedure TJvScrollBox.WndProc(var Msg: TMessage);
|
|
begin
|
|
if Msg.Msg = WM_LBUTTONDOWN then
|
|
if not Focused and not (csDesigning in ComponentState) then
|
|
SetFocus;
|
|
inherited WndProc(Msg);
|
|
end;
|
|
|
|
procedure TJvScrollBox.KeyDown(var Key: Word; Shift: TShiftState);
|
|
begin
|
|
inherited KeyDown(Key, Shift);
|
|
if Key <> 0 then
|
|
case Key of
|
|
VK_UP:
|
|
Perform(WM_VSCROLL, SB_LINEUP, 0);
|
|
VK_DOWN:
|
|
Perform(WM_VSCROLL, SB_LINEDOWN, 0);
|
|
VK_LEFT:
|
|
Perform(WM_HSCROLL, SB_LINELEFT, 0);
|
|
VK_RIGHT:
|
|
Perform(WM_HSCROLL, SB_LINERIGHT, 0);
|
|
VK_NEXT:
|
|
if ssShift in Shift then
|
|
Perform(WM_HSCROLL, SB_PAGERIGHT, 0)
|
|
else
|
|
Perform(WM_VSCROLL, SB_PAGEDOWN, 0);
|
|
VK_PRIOR:
|
|
if ssShift in Shift then
|
|
Perform(WM_HSCROLL, SB_PAGELEFT, 0)
|
|
else
|
|
Perform(WM_VSCROLL, SB_PAGEUP, 0);
|
|
VK_HOME:
|
|
if ssCtrl in Shift then
|
|
Perform(WM_VSCROLL, SB_TOP, 0)
|
|
else
|
|
Perform(WM_HSCROLL, SB_LEFT, 0);
|
|
VK_END:
|
|
if ssCtrl in Shift then
|
|
Perform(WM_VSCROLL, SB_BOTTOM, 0)
|
|
else
|
|
Perform(WM_HSCROLL, SB_RIGHT, 0);
|
|
end;
|
|
end;
|
|
|
|
procedure TJvScrollBox.PaintWindow(DC: HDC);
|
|
begin
|
|
FCanvas.Lock;
|
|
try
|
|
FCanvas.Handle := DC;
|
|
try
|
|
TControlCanvas(FCanvas).UpdateTextFlags;
|
|
Paint;
|
|
finally
|
|
FCanvas.Handle := 0;
|
|
end;
|
|
finally
|
|
FCanvas.Unlock;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvScrollBox.WMPaint(var Msg: TWMPaint);
|
|
begin
|
|
ControlState := ControlState + [csCustomPaint];
|
|
inherited;
|
|
ControlState := ControlState - [csCustomPaint];
|
|
end;
|
|
|
|
function TJvScrollBox.DoEraseBackground(Canvas: TCanvas; Param: Integer): Boolean;
|
|
begin
|
|
Result := False;
|
|
if Assigned(FOnEraseBackground) then
|
|
FOnEraseBackground(Self, Canvas, Result);
|
|
if not Result then
|
|
Result := inherited DoEraseBackground(Canvas, Param);
|
|
|
|
PaintBackground;
|
|
end;
|
|
|
|
procedure TJvScrollBox.Paint;
|
|
begin
|
|
if Assigned(FOnPaint) then
|
|
FOnPaint(Self);
|
|
end;
|
|
|
|
procedure TJvScrollBox.PaintBackground;
|
|
var
|
|
R: TRect;
|
|
X: Integer;
|
|
Y: Integer;
|
|
BackgroundHeight: Integer;
|
|
BackgroundWidth: Integer;
|
|
XOffset: Integer;
|
|
YOffset: Integer;
|
|
SavedYOffset: Integer;
|
|
begin
|
|
if Assigned(Background.Graphic) and not Background.Graphic.Empty then
|
|
begin
|
|
case BackgroundFillMode of
|
|
sfmTile:
|
|
begin
|
|
R := ClientRect;
|
|
BackgroundHeight := FBackground.Height;
|
|
BackgroundWidth := FBackground.Width;
|
|
|
|
XOffset := HorzScrollBar.Position - Trunc(HorzScrollBar.Position / BackgroundWidth) * BackgroundWidth;
|
|
YOffset := VertScrollBar.Position - Trunc(VertScrollBar.Position / BackgroundHeight) * BackgroundHeight;
|
|
SavedYOffset := YOffset;
|
|
X := R.Left;
|
|
while X < R.Right do
|
|
begin
|
|
Y := R.Top;
|
|
while Y < R.Bottom do
|
|
begin
|
|
Canvas.Draw(X - XOffset, Y - YOffset, Background.Graphic);
|
|
|
|
Inc(Y, BackgroundHeight - YOffset);
|
|
YOffset := 0;
|
|
end;
|
|
Inc(X, BackgroundWidth - XOffset);
|
|
XOffset := 0;
|
|
YOffset := SavedYOffset;
|
|
end;
|
|
end;
|
|
sfmStretch:
|
|
begin
|
|
R := ClientRect;
|
|
if HorzScrollBar.Range > R.Right then
|
|
R.Right := HorzScrollBar.Range - R.Left;
|
|
if VertScrollBar.Range > R.Bottom then
|
|
R.Bottom := VertScrollBar.Range - R.Top;
|
|
OffsetRect(R, -HorzScrollBar.Position, -VertScrollBar.Position);
|
|
|
|
Canvas.StretchDraw(R, Background.Graphic);
|
|
end;
|
|
sfmNone:
|
|
begin
|
|
Canvas.Draw(0, 0, Background.Graphic);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF UNITVERSIONING}
|
|
|
|
initialization
|
|
RegisterUnitVersion(HInstance, UnitVersioning);
|
|
|
|
finalization
|
|
UnregisterUnitVersion(HInstance);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
end.
|