El 10/11/15 a les 17:48, Aradeonas ha escrit:
Probably you are somewhere wrong, provide your code so we can check.
Regards,
Ara
Here is the component I adapted from the forum posting. Originally it
used a timer instead of a thread and I have to clean it up once I decide
for one option or the other.
Tomorrow I'll see if I can create a simple application that reproduces
the problem using it.
Bye
--
Luca Olivetti
Wetron Automation Technology http://www.wetron.es/
Tel. +34 93 5883004 (Ext.3010) Fax +34 93 5883007
unit scrollinglabel;
{$mode objfpc}{$H+}
interface
uses
Classes, StdCtrls, ExtCtrls, Controls, LResources, sysutils;
type
{ TScrollingLabel }
TScrollingLabel=class;
{ TScrollThread }
TScrollThread=class(TThread)
private
FOwner:TScrollingLabel;
procedure SyncTimer;
public
constructor Create(AOwner:TScrollingLabel);
procedure Execute;override;
end;
TScrollingLabel=class(TCustomLabel)
private
FOffset: integer;
FScrollRefresh: integer;
FScrolling: boolean;
FStep: integer;
FTimer: TScrollThread;
FNeededWidth:integer;
procedure OnTimer(Sender: TObject);
procedure SetScrolling(AValue: boolean);
procedure SetScrollRefresh(aValue: integer);
procedure EnableTimer(enable:boolean);
protected
procedure Paint; override;
procedure AdjustSize; override;
procedure DoMeasureTextPosition(var TextTop: integer; var TextLeft: integer);
override;
public
constructor Create(anOwner: TComponent);override;
destructor Destroy; override;
published
property ScrollRate: integer read FScrollRefresh write SetScrollRefresh default 500;
property ScrollStep: integer read FStep write FStep default 1;
property Scrolling: boolean read FScrolling write SetScrolling default True;
property Align;
property Alignment;
property Anchors;
//property AutoSize;
property BidiMode;
property BorderSpacing;
property Caption;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FocusControl;
property Font;
property Layout;
property ParentBidiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
property Transparent;
property Visible;
//property WordWrap;
property OnChangeBounds;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
property OnStartDrag;
//property OptimalFill;
end;
procedure register;
implementation
uses Graphics;
procedure register;
begin
RegisterComponents('Additional', [TScrollingLabel]);
end;
{ TScrollThread }
procedure TScrollThread.SyncTimer;
begin
FOwner.OnTimer(nil);
end;
constructor TScrollThread.Create(AOwner: TScrollingLabel);
begin
FOwner:=AOwner;
inherited create(false);
end;
procedure TScrollThread.Execute;
begin
while not terminated do
begin
sleep(FOwner.FScrollRefresh);
Synchronize(@SyncTimer);
end;
end;
procedure TScrollingLabel.OnTimer(Sender: TObject);
begin
Dec(FOffset, FStep);
if FOffset+FNeededwidth<0 then
FOffset:=-FStep;
Invalidate;
end;
procedure TScrollingLabel.SetScrolling(AValue: boolean);
begin
if FScrolling=AValue then Exit;
FScrolling:=AValue;
EnableTimer(FScrolling and (FNeededWidth>Width));
if not FScrolling then
FOffset:=0;
Invalidate;
end;
procedure TScrollingLabel.SetScrollRefresh(aValue: integer);
begin
if FScrollRefresh=aValue then
Exit;
FScrollRefresh:=aValue;
//FTimer.Interval:=FScrollRefresh;
Invalidate;
end;
procedure TScrollingLabel.EnableTimer(enable: boolean);
begin
if enable then
begin
if FTimer=Nil then
FTimer:=TScrollThread.Create(self)
end else
begin
if FTimer<>Nil then
FreeAndNil(FTimer);
end;
end;
procedure TScrollingLabel.Paint;
var
txtStyle : TTextStyle;
R : TRect;
TextLeft, TextTop: integer;
LabelText: string;
OldFontColor: TColor;
scroll: Boolean;
begin
R := Rect(0,0,Width,Height);
with Canvas do
begin
Brush.Color := Self.Color;
if (Color<>clNone) and not Transparent then
begin
Brush.Style:=bsSolid;
FillRect(R);
end;
Brush.Style:=bsClear;
Font := Self.Font;
FillChar(txtStyle,SizeOf(txtStyle),0);
scroll:=FScrolling and (FNeededWidth>Self.Width);
with txtStyle do
begin
if scroll then
Alignment:=BidiFlipAlignment(taLeftJustify, UseRightToLeftAlignment)
else
Alignment := BidiFlipAlignment(Self.Alignment, UseRightToLeftAlignment);
Layout := Self.Layout;
Opaque := (Color<>clNone) and not Transparent;
WordBreak := wordWrap;
SingleLine:= not WordWrap and not HasMultiLine;
Clipping := True;
ShowPrefix := ShowAccelChar;
SystemFont := False;
RightToLeft := UseRightToLeftReading;
ExpandTabs := True;
end;
DoMeasureTextPosition(TextTop, TextLeft);
LabelText := GetLabelText;
if scroll then
LabelText:=LabelText+' '+LabelText;
OldFontColor := Font.Color;
if not IsEnabled then
begin
Font.Color := clBtnHighlight;
TextRect(R, TextLeft + 1 + FOffset, TextTop + 1, LabelText, txtStyle);
Font.Color := clBtnShadow;
end;
TextRect(R, TextLeft, TextTop, LabelText, txtStyle);
Font.Color := OldFontColor;
end;
end;
procedure TScrollingLabel.AdjustSize;
var dummy:integer;
begin
inherited AdjustSize;
if Parent=nil then
exit;
CalculateSize(0,FNeededWidth,dummy);
if FNeededWidth<=Width then
begin
EnableTimer(false);
FOffset:=0;
end else
begin
EnableTimer(FScrolling);
FNeededWidth:=FNeededWidth+Canvas.TextExtent(' ').Cx;
end;
end;
procedure TScrollingLabel.DoMeasureTextPosition(var TextTop: integer;
var TextLeft: integer);
begin
inherited DoMeasureTextPosition(TextTop, TextLeft);
Inc(TextLeft, FOffset);
end;
constructor TScrollingLabel.Create(anOwner: TComponent);
begin
inherited Create(anOwner);
AutoSize:=False;
FScrollRefresh:=500;
FScrolling:=true;
FStep:=1;
EnableTimer(true);
//FTimer:=TScrollThread.Create(Self);
//FTimer.OnTimer:=@OnTimer;
//FTimer.Interval:=FScrollRefresh;
end;
destructor TScrollingLabel.Destroy;
begin
EnableTimer(false);
inherited Destroy;
end;
initialization
{$i scrollinglabel.lrs}
end.
--
_______________________________________________
Lazarus mailing list
[email protected]
http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus
