You've already forked lazarus-ccr
First commit
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3187 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
gbamber
369
components/scrolltext/scrollingtext.pas
Normal file
369
components/scrolltext/scrollingtext.pas
Normal file
@@ -0,0 +1,369 @@
|
||||
{
|
||||
***************************************************************************
|
||||
* *
|
||||
* This source is free software; you can redistribute it and/or modify *
|
||||
* it under the terms of the GNU General Public License as published by *
|
||||
* the Free Software Foundation; either version 2 of the License, or *
|
||||
* (at your option) any later version. *
|
||||
* *
|
||||
* This code is distributed in the hope that it will be useful, but *
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
||||
* General Public License for more details. *
|
||||
* *
|
||||
* A copy of the GNU General Public License is available on the World *
|
||||
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
||||
* obtain it by writing to the Free Software Foundation, *
|
||||
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
|
||||
* *
|
||||
***************************************************************************
|
||||
}
|
||||
unit ScrollingText;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
|
||||
ExtCtrls, LCLIntf,AboutScrolltextunit;
|
||||
|
||||
const
|
||||
C_TEXTFILENAME = 'scrolling.txt';
|
||||
C_TEXTRESOURCENAME = 'scrolltext'; //Note: LResouces unit needed
|
||||
C_VERSION = '1.0.0.0';
|
||||
|
||||
type
|
||||
TTextSource = (stStringlist, stTextfile, stResource);
|
||||
|
||||
TScrollingText = class(TAboutScrollText)
|
||||
private
|
||||
FActive: boolean;
|
||||
FActiveLine: integer; //the line over which the mouse hovers
|
||||
FBuffer: TBitmap;
|
||||
FEndLine: integer;
|
||||
FLineHeight: integer;
|
||||
FLines: TStrings;
|
||||
FNumLines: integer;
|
||||
FOffset: integer;
|
||||
FStartLine: integer;
|
||||
FStepSize: integer;
|
||||
FTimer: TTimer;
|
||||
FFont: TFont;
|
||||
FBackColor: TColor;
|
||||
fTextFileName: string;
|
||||
fResourceName: string;
|
||||
fVersionString: string;
|
||||
fTextSource: TTextSource;
|
||||
function ActiveLineIsURL: boolean;
|
||||
procedure DoTimer(Sender: TObject);
|
||||
procedure SetActive(const AValue: boolean);
|
||||
procedure Init;
|
||||
procedure DrawScrollingText(Sender: TObject);
|
||||
procedure SetLines(AValue: TStrings);
|
||||
procedure SetFont(AValue: TFont);
|
||||
protected
|
||||
procedure DoOnChangeBounds; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: integer); override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
published
|
||||
// Can be set in design mode. Note URL links are inactive in design mode
|
||||
property Active: boolean read FActive write SetActive;
|
||||
// Inherited property
|
||||
property Align;
|
||||
// Inherited property
|
||||
property Anchors;
|
||||
// Inherited property
|
||||
property BiDiMode;
|
||||
// Inherited property
|
||||
property Constraints;
|
||||
// Inherited property
|
||||
property Enabled;
|
||||
// Inherited property
|
||||
property Borderspacing;
|
||||
// Can be set in design or runtime mode. (TextSource=stStringlist)
|
||||
property Lines: TStrings read FLines write SetLines;
|
||||
// Sets the background color of the window
|
||||
property BackColor: TColor read fBackColor write fBackColor default clWindow;
|
||||
// Sets the font properties of the scrolling text
|
||||
property Font: TFont read fFont write SetFont;
|
||||
// Source of the text to display.
|
||||
// If TextSource=stTextfile 'scrolling.txt' should be in the deployed app folder
|
||||
// if TextSource=stResource be sure to add LResources to your uses clause
|
||||
property TextSource: TTextSource read fTextSource write fTextSource default
|
||||
stStringlist;
|
||||
// Read-only property to remind you of the correct file name
|
||||
property TextFileName: string read fTextFileName;
|
||||
// Read-only property to remind you of the correct resource name
|
||||
property TextResourceName: string read fResourceName;
|
||||
// Version number of this component
|
||||
property Version: string read fVersionString;
|
||||
end;
|
||||
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
{$I scrollingtext_icon.lrs}
|
||||
RegisterComponents('Additional', [TScrollingText]);
|
||||
end;
|
||||
|
||||
procedure TScrollingText.SetFont(AValue: TFont);
|
||||
begin
|
||||
fFont.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TScrollingText.SetLines(AValue: TStrings);
|
||||
begin
|
||||
fLines.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TScrollingText.SetActive(const AValue: boolean);
|
||||
begin
|
||||
FActive := AValue;
|
||||
if FActive then
|
||||
begin
|
||||
Init;
|
||||
FOffset := FBuffer.Height; // Start at the bottom of the window
|
||||
end;
|
||||
FTimer.Enabled := Active;
|
||||
end;
|
||||
|
||||
procedure TScrollingText.Init;
|
||||
var
|
||||
r: TLResource;
|
||||
begin
|
||||
FBuffer.Width := Width;
|
||||
FBuffer.Height := Height;
|
||||
FLineHeight := FBuffer.Canvas.TextHeight('X');
|
||||
FNumLines := FBuffer.Height div FLineHeight;
|
||||
|
||||
if FOffset = -1 then
|
||||
FOffset := FBuffer.Height;
|
||||
|
||||
with FBuffer.Canvas do
|
||||
begin
|
||||
Brush.Color := fBackColor;
|
||||
Brush.Style := bsSolid;
|
||||
FillRect(0, 0, Width, Height);
|
||||
end;
|
||||
if (fTextSource = stTextfile) then
|
||||
if FileExists('scrolling.txt') then
|
||||
begin
|
||||
fLines.Clear;
|
||||
fLines.LoadFromFile('scrolling.txt');
|
||||
end
|
||||
else
|
||||
begin
|
||||
fLines.Clear;
|
||||
fLines.Add('The file ''' + C_TEXTFILENAME + ''' is missing.');
|
||||
fLines.Add('It should be in the same folder as your application');
|
||||
end;
|
||||
if (fTextSource = stResource) then
|
||||
|
||||
// Load text from resource string
|
||||
begin
|
||||
r := LazarusResources.Find(fResourceName);
|
||||
if r = nil then
|
||||
raise Exception.CreateFmt('Resource ''%s'' is missing',[fResourceName])
|
||||
else
|
||||
begin
|
||||
fLines.Clear;
|
||||
fLines.Add(r.Value);
|
||||
end;
|
||||
end;
|
||||
// Are there any lines in the Stringlist?
|
||||
if (fLines.Count = 0) then
|
||||
begin
|
||||
fLines.Add('This is the ScrollingText scrolling window.');
|
||||
fLines.Add(' ');
|
||||
fLines.Add('This default text is showing because you either:');
|
||||
fLines.Add(' ');
|
||||
fLines.Add('1) Haven''t set any text in the Lines property. or');
|
||||
fLines.Add('2) TextSource is set to stTextfile and the file');
|
||||
fLines.Add('''' + C_TEXTFILENAME + ''' is empty.');
|
||||
fLines.Add(' ');
|
||||
fLines.Add('Note that URL links such as');
|
||||
fLines.Add('http://wiki.lazarus.freepascal.org/Main_Page');
|
||||
fLines.Add('mailto:bill_gates@microsoft.com');
|
||||
fLines.Add('are clickable by the user');
|
||||
fLines.Add(' ');
|
||||
fLines.Add('TScrollingText is released under the GPL license (See About)');
|
||||
fLines.Add('Code is modified from the Lazarus ''AboutFrm'' code');
|
||||
fLines.Add(' ');
|
||||
fLines.Add('The standalone visual component TScrollingText is available at:');
|
||||
fLines.Add('http://www.charcodelvalle.com/scrollingtext/scrollingtext_component.zip');
|
||||
fLines.Add(' ');
|
||||
fLines.Add('June 2014');
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TScrollingText.DrawScrollingText(Sender: TObject);
|
||||
begin
|
||||
if Active then
|
||||
Canvas.Draw(0,0, FBuffer);
|
||||
end;
|
||||
|
||||
procedure TScrollingText.DoTimer(Sender: TObject);
|
||||
var
|
||||
w: integer;
|
||||
s: string;
|
||||
i: integer;
|
||||
begin
|
||||
if not Active then
|
||||
Exit;
|
||||
|
||||
Dec(FOffset, FStepSize);
|
||||
|
||||
if FOffSet < 0 then
|
||||
FStartLine := -FOffset div FLineHeight
|
||||
else
|
||||
FStartLine := 0;
|
||||
|
||||
FEndLine := FStartLine + FNumLines + 1;
|
||||
if FEndLine > FLines.Count - 1 then
|
||||
FEndLine := FLines.Count - 1;
|
||||
|
||||
FBuffer.Canvas.FillRect(Rect(0, 0, FBuffer.Width, FBuffer.Height));
|
||||
|
||||
for i := FEndLine downto FStartLine do
|
||||
begin
|
||||
s := Trim(FLines[i]);
|
||||
|
||||
//reset buffer font
|
||||
FBuffer.Canvas.Font := fFont;
|
||||
FBuffer.Canvas.Font.Style := [];
|
||||
FBuffer.Canvas.Font.Color := clBlack;
|
||||
|
||||
//skip empty lines
|
||||
if Length(s) > 0 then
|
||||
begin
|
||||
//check for bold format token
|
||||
if s[1] = '#' then
|
||||
begin
|
||||
s := copy(s, 2, Length(s) - 1);
|
||||
FBuffer.Canvas.Font.Style := [fsBold];
|
||||
end
|
||||
else
|
||||
begin
|
||||
//check for url
|
||||
if (Pos('http://', s) = 1) OR (Pos('mailto:', s) = 1) then
|
||||
begin
|
||||
if i = FActiveLine then
|
||||
begin
|
||||
FBuffer.Canvas.Font.Style := [fsUnderline];
|
||||
FBuffer.Canvas.Font.Color := clRed;
|
||||
end
|
||||
else
|
||||
FBuffer.Canvas.Font.Color := clBlue;
|
||||
end;
|
||||
end;
|
||||
|
||||
w := FBuffer.Canvas.TextWidth(s);
|
||||
FBuffer.Canvas.TextOut((FBuffer.Width - w) div 2, FOffset + i * FLineHeight, s);
|
||||
end;
|
||||
end;
|
||||
|
||||
//start showing the list from the start
|
||||
if FStartLine > FLines.Count - 1 then
|
||||
FOffset := FBuffer.Height;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
function TScrollingText.ActiveLineIsURL: boolean;
|
||||
begin
|
||||
if (FActiveLine > 0) and (FActiveLine < FLines.Count) then
|
||||
Result := (Pos('http://', FLines[FActiveLine]) = 1) OR (Pos('mailto:', FLines[FActiveLine]) = 1)
|
||||
else
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
procedure TScrollingText.DoOnChangeBounds;
|
||||
begin
|
||||
inherited DoOnChangeBounds;
|
||||
Init;
|
||||
end;
|
||||
|
||||
procedure TScrollingText.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer);
|
||||
begin
|
||||
inherited MouseDown(Button, Shift, X, Y);
|
||||
|
||||
if ActiveLineIsURL then
|
||||
OpenURL(FLines[FActiveLine]);
|
||||
end;
|
||||
|
||||
procedure TScrollingText.MouseMove(Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
inherited MouseMove(Shift, X, Y);
|
||||
|
||||
//calculate what line is clicked from the mouse position
|
||||
FActiveLine := (Y - FOffset) div FLineHeight;
|
||||
|
||||
Cursor := crDefault;
|
||||
|
||||
if (FActiveLine >= 0) and (FActiveLine < FLines.Count) and ActiveLineIsURL then
|
||||
Cursor := crHandPoint;
|
||||
end;
|
||||
|
||||
constructor TScrollingText.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
|
||||
ControlStyle := ControlStyle + [csOpaque];
|
||||
|
||||
OnPaint := @DrawScrollingText;
|
||||
FLines := TStringList.Create;
|
||||
FTimer := TTimer.Create(nil);
|
||||
FTimer.OnTimer := @DoTimer;
|
||||
FTimer.Interval := 30;
|
||||
FBuffer := TBitmap.Create;
|
||||
FFont := TFont.Create;
|
||||
FFont.Size := 10;
|
||||
fBackColor := clWindow;
|
||||
|
||||
FStepSize := 1;
|
||||
FStartLine := 0;
|
||||
FOffset := -1;
|
||||
Width := 100;
|
||||
Height := 100;
|
||||
fTextFileName := C_TEXTFILENAME;
|
||||
fResourceName := C_TEXTRESOURCENAME;
|
||||
fVersionString := C_VERSION;
|
||||
fTextSource := stStringlist;
|
||||
SendToBack;
|
||||
|
||||
// About dialog
|
||||
AboutBoxComponentName:='ScrollingText component';
|
||||
AboutBoxWidth:=400;
|
||||
// AboutBoxHeight (integer)
|
||||
AboutBoxDescription:='Component that shows a scrolling window.' + LineEnding +
|
||||
'Use Lines property to set text and Active=True' + LineEnding +
|
||||
'to use the component';
|
||||
AboutBoxBackgroundColor:=clWindow;
|
||||
AboutBoxFontName:='Arial';
|
||||
AboutBoxFontSize:=10;
|
||||
AboutBoxVersion:=C_VERSION;
|
||||
AboutBoxAuthorname:='Gordon Bamber';
|
||||
AboutBoxOrganisation:='Public Domain';
|
||||
AboutBoxAuthorEmail:='minesadorada@charcodelvalle.com';
|
||||
AboutBoxLicenseType:='LGPL';
|
||||
|
||||
end;
|
||||
|
||||
destructor TScrollingText.Destroy;
|
||||
begin
|
||||
FLines.Free;
|
||||
FTimer.Free;
|
||||
FBuffer.Free;
|
||||
FFont.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user