文本的平滑移动效果(0分)

  • 主题发起人 主题发起人 formiss
  • 开始时间 开始时间
F

formiss

Unregistered / Unconfirmed
GUEST, unregistred user!
金山词霸的迷你背单词的平滑移动效果,
找了一些控件,大都是从下往上移动的,想问问,有没有可以控制移动方向的。
 
unit ALScrollingText;


interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;


type
TTextLayout = (tlTop, tlCenter, tlBottom);

TTextDirection = (tdLeftToRight, tdRightToLeft);


TALScrollingText = class(TGraphicControl)
private
fText: String;

Timer: TTimer;

fSpeed: Integer;

fBackgroundColor: TColor;

BackBitmap: TBitmap;

DrawnBitmap: TBitmap;

WholeBitmap: TBitmap;

Position: Integer;

fEdgeFade: Boolean;

fEdgeFadeWidth: Integer;

fLayout: TTextLayout;

fTextDirection: TTextDirection;

fPixelJump: Integer;

procedure SetText(const Value: String);

procedure SetSpeed(const Value: Integer);

procedure OnTimer(Sender: TObject);

procedure SetBackgroundColor(const Value: TColor);

procedure CMFontChanged(var Msg: TMessage);
message CM_FontChanged;

procedure InvalidateEverything;

procedure SetEdgeFadeWidth(const Value: Integer);

function CalcColorIndex(StartColor, EndColor: TColor;
Steps, ColorIndex: Integer): TColor;

procedure SetLayout(const Value: TTextLayout);

procedure SetTextDirection(const Value: TTextDirection);

protected
procedure Paint;
override;

procedure Loaded;
override;

public
constructor Create(AOwner: TComponent);
override;

destructor Destroy;
override;

procedure Resize;
override;

published
property Text: String read fText write SetText;

property Speed: Integer read fSpeed write SetSpeed default 50;

property BackgroundColor: TColor read fBackgroundColor write SetBackgroundColor default clBtnFace;

property EdgeFadeWidth: Integer read fEdgeFadeWidth write SetEdgeFadeWidth default 15;

property Layout: TTextLayout read fLayout write SetLayout default tlCenter;

property TextDirection: TTextDirection read fTextDirection write SetTextDirection default tdLeftToRight;

property PixelJump: Integer read fPixelJump write fPixelJump default 1;

property Font;

property Enabled;

property ParentFont;

property Visible;

property OnMouseDown;

property OnMouseUp;

property OnClick;

end;



procedure Register;


implementation

procedure Register;

begin

RegisterComponents('ChoiceSoft', [TALScrollingText]);

end;



{ TALScrollingText }

constructor TALScrollingText.Create(AOwner: TComponent);

begin

inherited;


BackBitmap := TBitmap.Create;

DrawnBitmap := tBitmap.Create;

WholeBitmap := TBitmap.Create;

WholeBitmap.Transparent := True;


Timer := TTimer.Create(nil);

Timer.OnTimer := OnTimer;


Width := 50;

Height := 18;


ParentFont := True;


fText := 'Text';

Speed := 50;

fEdgeFade := True;

fEdgeFadeWidth := 15;

fBackgroundColor := clBtnFace;

fLayout := tlCenter;

fTextDirection := tdLeftToRight;

fPixelJump := 1;

Position := -Width;

Font.Color := clWindowText;

end;



destructor TALScrollingText.Destroy;

begin

Timer.Free;

BackBitmap.Free;

DrawnBitmap.Free;

WholeBitmap.Free;


inherited;

end;



procedure TALScrollingText.Loaded;

begin

inherited;


InvalidateEverything;

if fTextDirection = tdLeftToRight then

Position := -(WholeBitmap.Width - Width)
else

Position := 0;

end;



procedure TALScrollingText.OnTimer(Sender: TObject);

begin

if Enabled then

begin

if fTextDirection = tdLeftToRight then

begin

Inc(Position, fPixelJump);

if Position >= 0 then

Position := -WholeBitmap.Width + Width;

end
else

begin

Dec(Position, fPixelJump);

if Position <= -(WholeBitmap.Width - Width) then

Position := 0;

end;


end;


Paint;

end;



procedure TALScrollingText.Paint;

begin

inherited;


BitBlt(DrawnBitmap.Canvas.Handle, 0, 0, Width, Height, BackBitmap.Canvas.Handle, 0, 0, SrcCopy);

DrawnBitmap.Canvas.Draw(Position, 0, WholeBitmap);


BitBlt(Canvas.Handle, 0, 0, Width, Height, DrawnBitmap.Canvas.Handle, 0, 0, SrcCopy);

end;



procedure TALScrollingText.InvalidateEverything;

var
i: Integer;

begin

with WholeBitmap do

begin

Canvas.Brush.Color := fBackgroundColor;

Canvas.FillRect(Rect(0, 0, Width, Height));

Canvas.Font := Self.Font;

Width := WholeBitmap.Canvas.TextWidth(fText) + (2 * Self.Width);

Height := Self.Height;

if (Self.Font.Color = clGreen) or (fBackgroundColor = clGreen) then

begin

TransparentColor := clRed;

Canvas.Font.Color := clRed;

end
else

begin

TransparentColor := clGreen;

Canvas.Font.Color := clGreen;

end;


if fLayout = tlTop then

Canvas.TextOut(Self.Width, 0, fText)
else
if fLayout = tlCenter then

Canvas.TextOut(Self.Width, (Self.Height div 2) - (Canvas.TextHeight(fText) div 2), fText)
else

Canvas.TextOut(Self.Width, Self.Height - Canvas.TextHeight(fText), fText);

end;



with BackBitmap do

begin

Width := Self.Width;

Height := Self.Height;

Canvas.Brush.Color := Self.Font.Color;

Canvas.FillRect(Rect(0, 0, Self.Width, Self.Height));

if fEdgeFadeWidth > 0 then

begin

for i := 0 to fEdgeFadeWidth-1 do

begin

Canvas.Pen.Color := CalcColorIndex(fBackgroundColor, Self.Font.Color, fEdgeFadeWidth, i+1);

Canvas.MoveTo(i, 0);

Canvas.LineTo(i, Self.Height);

Canvas.MoveTo(Width-i-1, 0);

Canvas.LineTo(Width-i-1, Self.Height);

end;


end;


end;



DrawnBitmap.Width := Width;

DrawnBitmap.Height := Height;

end;



procedure TALScrollingText.CMFontChanged(var Msg: TMessage);

begin

inherited;


InvalidateEverything;

Msg.Result := 1;

end;



procedure TALScrollingText.Resize;

begin

inherited;


InvalidateEverything;

end;



procedure TALScrollingText.SetBackgroundColor(const Value: TColor);

begin

if fBackgroundColor <> Value then

begin

fBackgroundColor := Value;

InvalidateEverything;

end;


end;



procedure TALScrollingText.SetSpeed(const Value: Integer);

begin

if fSpeed <> Value then

begin

fSpeed := Value;

Timer.Interval := Value;

end;


end;



procedure TALScrollingText.SetText(const Value: String);

begin

if fText <> Value then

begin

fText := Value;

InvalidateEverything;

end;


end;



procedure TALScrollingText.SetEdgeFadeWidth(const Value: Integer);

begin

if fEdgeFadeWidth <> Value then

begin

fEdgeFadeWidth := Value;

InvalidateEverything;

end;


end;



procedure TALScrollingText.SetLayout(const Value: TTextLayout);

begin

if fLayout <> Value then

begin

fLayout := Value;

InvalidateEverything;

end;


end;



procedure TALScrollingText.SetTextDirection(const Value: TTextDirection);

begin

if fTextDirection <> Value then

begin

fTextDirection := Value;

if Value = tdLeftToRight then

Position := -(WholeBitmap.Width - Width)
else

Position := 0;

InvalidateEverything;

end;


end;



function TALScrollingText.CalcColorIndex(StartColor, EndColor: TColor;
Steps, ColorIndex: Integer): TColor;

var
begin
RGBValue: Array[0..2] of Byte;

RGBDifference: Array[0..2] of Integer;

Red, Green, Blue: Byte;

NumColors: Integer;

begin

if (ColorIndex < 1) or (ColorIndex > Steps) then

raise ERangeError.Create('ColorIndex can''t be less than 1 or greater than ' + IntToStr(Steps));

NumColors := Steps;

Dec(ColorIndex);

begin
RGBValue[0] := GetRValue(ColorToRGB(StartColor));

begin
RGBValue[1] := GetGValue(ColorToRGB(StartColor));

begin
RGBValue[2] := GetBValue(ColorToRGB(StartColor));

RGBDifference[0] := GetRValue(ColorToRGB(EndColor)) - begin
RGBValue[0];

RGBDifference[1] := GetGValue(ColorToRGB(EndColor)) - begin
RGBValue[1];

RGBDifference[2] := GetBValue(ColorToRGB(EndColor)) - begin
RGBValue[2];


// Calculate the bands color
Red := begin
RGBValue[0] + MulDiv(ColorIndex, RGBDifference[0], NumColors - 1);

Green := begin
RGBValue[1] + MulDiv(ColorIndex, RGBDifference[1], NumColors - 1);

Blue := begin
RGBValue[2] + MulDiv(ColorIndex, RGBDifference[2], NumColors - 1);

Result := RGB(Red, Green, Blue);

end;



end.
 
后退
顶部