pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

First commit

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3187 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
gbamber
2014-06-17 09:08:16 +00:00
parent 1e5fa19f94
commit 5a04bbbdda
20 changed files with 1675 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

616
components/scrolltext/aboutscrolltextunit.pas Normal file
View File

@ -0,0 +1,616 @@
{ TAboutScrollText and TAboutBox Component License
Copyright (C) 2014 Gordon Bamber minesadorada@charcodelvalle.com
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program 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 Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit AboutScrolltextunit;
{$mode objfpc}{$H+}
interface
uses
Classes, Controls, Dialogs, Forms, Graphics, LResources, SysUtils,
ExtCtrls, StdCtrls, StrUtils,Buttons,PropEdits;
const
C_DEFAULTLICENSEFORMWIDTH = 500;
C_DEFAULTLICENSEFORMWIDTH_LINUX = C_DEFAULTLICENSEFORMWIDTH + 100;
C_DEFAULTLICENSEFORMHEIGHT = 400;
C_DEFAULTLICENSEFORMHEIGHT_LINUX = C_DEFAULTLICENSEFORMHEIGHT + 50;
type
TLicenseType = (abNone, abGPL, abLGPL, abMIT, abModifiedGPL, abProprietry);
TAboutbox = class(TComponent)
private
{ Private declarations }
fDialog: TForm;
fBackgroundbitmap: TBitMap;
fBackgroundResourceName:String;
fDescription: TStrings;
fDialogTitle, fVersion, fAuthorname, fAuthorEmail, fOrganisation,
fComponentName: string;
fDialogHeight, fDialogWidth: integer;
fStretchBackground: boolean;
fFont: TFont;
fColor: TColor;
fLicenseType: TLicenseType;
procedure SetBackgroundBitmap(const AValue: TBitMap);
procedure SetDescriptionStrings(const AValue: TStrings);
procedure SetFont(const AValue: TFont);
procedure ShowLicense(Sender: TObject);
procedure SetDialogTitle(Const AValue:String);
protected
{ Protected declarations }
public
{ Public declarations }
procedure ShowDialog;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
// Set these properties in your component Constructor method
property BackGround: TBitMap read fBackgroundbitmap write SetBackgroundBitmap;
property BackgroundResourceName:String read fBackgroundResourceName write fBackgroundResourceName;
property Description: TStrings read fDescription write SetDescriptionStrings;
property Title: string read fDialogTitle write SetDialogTitle;
property Height: integer read fDialogHeight write fDialogHeight;
property Width: integer read fDialogWidth write fDialogWidth;
property Font: TFont read fFont write SetFont;
property BackGroundColor: TColor read fColor write fColor;
property StretchBackground: boolean read fStretchBackground
write fStretchBackground default False;
property Version: string read fVersion write fVersion;
property Authorname: string read fAuthorname write fAuthorname;
property Organisation: string read fOrganisation write fOrganisation;
property AuthorEmail: string read fAuthorEmail write fAuthorEmail;
property ComponentName: string read fComponentName write fComponentName;
property LicenseType: TLicenseType read fLicenseType write fLicenseType;
end;
TAboutScrollText = class(TGraphicControl)
private
{ Private declarations }
fAboutBox: tAboutBox;
procedure SetMyComponentName(Const Avalue:String);
procedure SetAboutBoxWidth(Const AValue:Integer);
procedure SetAboutBoxHeight(Const AValue:Integer);
procedure SetAboutBoxDescription(Const AValue:String);
procedure SetAboutBoxFontName(Const AValue:String);
procedure SetAboutBoxFontSize(Const AValue:Integer);
procedure SetAboutBoxBitmap(Const AValue:TBitmap);
procedure SetAboutBoxBackgroundColor(Const AValue:TColor);
procedure SetAboutBoxTitle(Const AValue:String);
procedure SetAboutBoxVersion(Const AValue:String);
procedure SetAboutBoxAuthorname(Const AValue:String);
procedure SetAboutBoxOrganisation(Const AValue:String);
procedure SetAboutBoxAuthorEmail(Const AValue:String);
procedure SetAboutBoxBackgroundResourceName(Const AValue:String);
procedure SetAboutBoxLicenseType(Const AValue:String);
procedure SetAboutBoxStretchBackgroundImage(Const AValue:Boolean);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override; // Constructor must be public
destructor Destroy; override; // Destructor must be public
// Set these (hidden) properties in your inherited component's Create procedure
property AboutBoxComponentName:String write SetMyComponentName;
property AboutBoxWidth:Integer write SetAboutBoxWidth;
property AboutBoxHeight:Integer write SetAboutBoxHeight;
property AboutBoxDescription:String write SetAboutBoxDescription;
property AboutBoxFontName:String write SetAboutBoxFontName;
property AboutBoxFontSize:Integer write SetAboutBoxFontSize;
property AboutBoxBackgroundColor:TColor write SetAboutBoxBackgroundColor;
property AboutBoxTitle:String write SetAboutBoxTitle;
property AboutBoxVersion:String write SetAboutBoxVersion;
property AboutBoxAuthorname:String write SetAboutBoxAuthorname;
property AboutBoxOrganisation:String write SetAboutBoxOrganisation;
property AboutBoxAuthorEmail:String write SetAboutBoxAuthorEmail;
property AboutBoxLicenseType:String write SetAboutBoxLicenseType;
property AboutBoxBackgroundResourceName:String write SetAboutBoxBackgroundResourceName;
property AboutBoxStretchBackgroundImage:Boolean write SetAboutBoxStretchBackgroundImage;
published
// The clickable 'About' property will automaticcally appear in any component
// descended from TAboutScrollText
// About this component...
property About: tAboutBox read fAboutBox;
end;
// Declaration for the 'About' property editor
TAboutPropertyEditor = class(TClassPropertyEditor)
public
procedure Edit; override;
function GetAttributes: TPropertyAttributes; override;
end;
procedure Register;
{For i8n if required}
resourcestring
rs_Componentname='Component name';
rs_About='About';
rs_License='License';
rs_By='By';
rs_For='For';
rs_DatafileMissing='Resource datafile license.lrs is missing';
rs_LicenseTextError='There is something wrong with the Licence text';
rs_AboutBoxError = 'Subcomponent TAboutBox Error';
implementation
{ TABoutBox}
constructor TAboutbox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fBackgroundbitmap := TBitMap.Create;
fDescription := TStringList.Create;
fFont := TFont.Create;
fColor := clDefault;
fLicenseType := abNone;
fComponentName:=rs_Componentname;
fDialogTitle:=rs_About + ' ' + fComponentName;
fDialogWidth:=320;
fDialogHeight:=280;
fVersion:='1.0.0.0';
fLicenseType:=abNone;
end;
destructor TAboutbox.Destroy;
begin
FreeAndNil(fFont);
FreeAndNil(fDescription);
FreeAndNil(fBackgroundbitmap);
inherited Destroy;
end;
procedure TAboutbox.SetDialogTitle(Const AValue:String);
begin
fDialogTitle:=rs_About + ' ' + Avalue;
end;
procedure TAboutbox.ShowDialog;
var
OKbutton, LicenseButton: TBitBtn;
lbl_Description: TLabel;
img_BackGround: TImage;
sz: string;
iCount: integer;
r:TLResource;
begin
fDialog := TForm.CreateNew(nil);
try //.. finally FreeAndNil everything
with fDialog do
begin
// Set Dialog properties
position := poScreenCenter;
borderstyle := bsToolWindow;
Caption := fDialogTitle;
formstyle := fsSystemStayOnTop;
color := fColor;
font := fFont;
if (fDialogHeight > 0) then
Height := fDialogHeight
else
Height := 240;
if (fDialogWidth > 0) then
Width := fDialogWidth
else
Width := 320;
// Create a background image
img_BackGround := Timage.Create(fDialog);
with img_BackGround do
// Set img_BackGround properties
begin
Align := alClient;
Stretch := fStretchBackground;
// Bitmap assigned?
if Assigned(fBackgroundbitmap) then
Picture.Assign(fBackgroundbitmap);
// Resource file?
r := LazarusResources.Find(fBackgroundResourceName);
if r <> nil then
img_BackGround.Picture.LoadFromLazarusResource(fBackgroundResourceName);
SendToBack;
parent := fDialog;
end;
// Create a BitBtn button
okbutton := TBitBtn.Create(fDialog);
// Set BitBtn properties
with okButton do
begin
Kind := bkClose;
left := (fDialog.Width div 2) - Width div 2;
top := fDialog.Height - Height - 10;
ParentFont:=False;
parent := fDialog;
end;
// Create a License Button
LicenseButton := TBitBtn.Create(fDialog);
if (fLicenseType <> abNone) then
// Put it on the right
begin
LicenseButton.Top := OKButton.Top;
LicenseButton.Caption := rs_License + '...';
LicenseButton.left := Width - LicenseButton.Width - 10;
LicenseButton.OnClick := @ShowLicense;
LicenseButton.ParentFont:=False;
LicenseButton.Parent := fDialog;
end;
// Create a label control
lbl_Description := Tlabel.Create(fDialog);
// Set label properties
with lbl_Description do
begin
left := 8;
Top := 30;
Width := fDialog.Width - 8;
Height := fDialog.Height - 30;
Autosize := False;
ParentFont := True;
Alignment := taCenter;
end;
// Build up Label text
sz := '';
// Component name
if fComponentName <> '' then
sz += fComponentName + LineEnding;
// Author name (+Email)
if fAuthorname <> '' then
sz += rs_By + ': ' + fAuthorname + LineEnding;
if fAuthorEmail <> '' then
sz += ' (' + fAuthorEmail + ')' + LineEnding
else
sz += LineEnding;
sz += LineEnding;
// Version
if fVersion <> '' then
sz += 'Version: ' + fVersion + LineEnding;
// License
case fLicenseType of
abGPL: sz += rs_License + ': GPL' + LineEnding;
abLGPL: sz += rs_License + ': LGPL' + LineEnding;
abMIT: sz += rs_License + ': M.I.T.' + LineEnding;
abModifiedGPL: sz += rs_License + ': Modified GPL' + LineEnding;
abProprietry: sz += rs_License + ': Proprietry' + LineEnding;
end;
if fOrganisation <> '' then
sz += rs_For + ': ' + fOrganisation + LineEnding;
if fDescription.Count > 0 then
begin
sz += LineEnding;
for iCount := 1 to fDescription.Count do
sz += fDescription[iCount - 1] + LineEnding;
end;
lbl_Description.Caption := sz;
lbl_Description.parent := fDialog;
// Display the dialog modally
ShowModal;
end;
finally
// Free all resources
FreeAndNil(img_BackGround);
FreeAndNil(lbl_Description);
FreeAndNil(LicenseButton);
FreeAndNil(okbutton);
end;
end;
procedure TAboutbox.ShowLicense(Sender: TObject);
// Triggered by License button Click
var
sLicenseString: string;
theList: TStringList;
f: integer;
LicenceForm: TForm;
lblText: TLabel;
closebuttton: TBitBtn;
r: TLResource;
szLicenseFile: string;
begin
// Quit early?
if fLicenseType = abNone then
Exit;
// Set to resource name in license.lrs
case fLicenseType of
abNone: szLicenseFile := '';
abGPL: szLicenseFile := 'gpl.txt';
abLGPL: szLicenseFile := 'lgpl.txt';
abMIT: szLicenseFile := 'mit.txt';
abModifiedgpl: szLicenseFile := 'modifiedgpl.txt';
end;
// Use a string list to split the text file into lines
theList := TStringList.Create;
// Create a window, label and close button on-the-fly
LicenceForm := TForm.Create(nil);
lblText := TLabel.Create(LicenceForm);
closebuttton := TBitBtn.Create(LicenceForm);
// Load up the text into variable 'sLicenseString'
sLicenseString := LineEnding + LineEnding + fComponentName + LineEnding;
try
try
begin
// Load license text from resource string
r := LazarusResources.Find(szLicenseFile);
if r = nil then
raise Exception.Create(rs_DatafileMissing);
thelist.Add(r.Value);
for f := 0 to TheList.Count - 1 do
sLicenseString += TheList[f] + LineEnding;
end;
except
On e: Exception do
MessageDlg(rs_AboutBoxError,
rs_LicenseTextError, mtError, [mbOK], 0);
end;
// Replace boilerplate text if possible
sLicenseString := AnsiReplaceText(sLicenseString, '<year>',
{$I %DATE%}
);
sLicenseString := AnsiReplaceText(sLicenseString, '<name of author>', fAuthorname);
sLicenseString := AnsiReplaceText(sLicenseString, '<contact>',
'(' + fAuthorEmail + ')');
sLicenseString := AnsiReplaceText(sLicenseString, '<copyright holders>',
fOrganisation);
// Make up the form window and controls
with LicenceForm do
begin
// Form
{$IFDEF WINDOWS}
// More compact GUI?
Width := C_DEFAULTLICENSEFORMWIDTH;
Height := C_DEFAULTLICENSEFORMHEIGHT;
{$ELSE WINDOWS}
Width := C_DEFAULTLICENSEFORMWIDTH_LINUX;
Height := C_DEFAULTLICENSEFORMHEIGHT_LINUX;
{$ENDIF}
// autosize:=true;
// If you enable autosize, the button placement goes awry!
// The Modified GPL has an extra clause
if (szLicenseFile = 'modifiedgpl.txt') or
(Pos('As a special exception', sLicenseString) > 0) then
Height := Height + 100;
position := poScreenCenter;
borderstyle := bsToolWindow;
Caption := fComponentName + ': Licensing';
formstyle := fsSystemStayOnTop;
// Label
lblText.Align := alClient;
lblText.Alignment := taCenter;
lblText.Caption := sLicenseString;
lblText.Parent := LicenceForm;
// Close Button
closebuttton.Kind := bkClose;
closebuttton.left := (Width div 2) - closebuttton.Width div 2;
closebuttton.top := Height - closebuttton.Height - 10;
closebuttton.parent := LicenceForm;
// Show modally over the existing modal form
PopupParent := TForm(Sender);
ShowModal;
end;
finally
// Free up all component created resources from memory
FreeAndNil(theList);
FreeAndNil(lblText);
FreeAndNil(closebuttton);
FreeAndNil(LicenceForm);
end;
end;
procedure TAboutbox.SetBackgroundBitmap(const AValue: TBitMap);
begin
if Assigned(AValue) then
fBackgroundbitmap.Assign(AValue);
end;
procedure TAboutbox.SetDescriptionStrings(const AValue: TStrings);
begin
if Assigned(AValue) then
fDescription.Assign(Avalue);
end;
procedure TAboutbox.SetFont(const AValue: TFont);
begin
if Assigned(AValue) then
fFont.Assign(AValue);
end;
{ TAboutScrollText }
procedure Register;
begin
RegisterPropertyEditor(TypeInfo(TAboutbox),
TAboutScrollText, 'About', TAboutPropertyEditor);
end;
procedure TAboutPropertyEditor.Edit;
// Communicate with the component properties
Var
AAboutBox:TAboutBox;
begin
AAboutBox:=TAboutBox(GetObjectValue(TAboutBox));
AABoutBox.ShowDialog;
end;
function TAboutPropertyEditor.GetAttributes: TPropertyAttributes;
// Show the ellipsis
begin
Result := [paDialog, paReadOnly];
end;
// Sets for AboutBox dialog properties
procedure TAboutScrollText.SetMyComponentName(Const Avalue:String);
begin
fAboutBox.ComponentName:=AValue;
fAboutBox.Title:=AValue;
end;
procedure TAboutScrollText.SetAboutBoxWidth(Const AValue:Integer);
begin
fAboutBox.Width:=Avalue;
end;
procedure TAboutScrollText.SetAboutBoxHeight(Const AValue:Integer);
begin
fAboutBox.Height:=Avalue;
end;
procedure TAboutScrollText.SetAboutBoxDescription(Const AValue:String);
begin
fAboutBox.Description.Clear;
fAboutBox.Description.Add(AValue);
end;
procedure TAboutScrollText.SetAboutBoxFontName(Const AValue:String);
begin
fAboutBox.Font.Name:=AValue;
end;
procedure TAboutScrollText.SetAboutBoxFontSize(Const AValue:Integer);
begin
if (AValue > 6) then fAboutBox.Font.Size:=AValue;
end;
procedure TAboutScrollText.SetAboutBoxTitle(Const AValue:String);
begin
fAboutBox.Title:=AValue;
end;
procedure TAboutScrollText.SetAboutBoxBitmap(Const AValue:TBitmap);
begin
If Assigned(Avalue) then fAboutBox.Assign(AValue);
end;
procedure TAboutScrollText.SetAboutBoxBackgroundColor(Const AValue:TColor);
begin
fAboutBox.BackGroundColor:=AValue;;
end;
procedure TAboutScrollText.SetAboutBoxVersion(Const AValue:String);
begin
fAboutBox.Version:=AValue;
end;
procedure TAboutScrollText.SetAboutBoxAuthorname(Const AValue:String);
begin
fAboutBox.Authorname:=AValue;
end;
procedure TAboutScrollText.SetAboutBoxOrganisation(Const AValue:String);
begin
fAboutBox.Organisation:=AValue;
end;
procedure TAboutScrollText.SetAboutBoxAuthorEmail(Const AValue:String);
begin
fAboutBox.AuthorEmail:=AValue;
end;
procedure TAboutScrollText.SetAboutBoxBackgroundResourceName(Const AValue:String);
begin
fAboutBox.BackgroundResourceName:=AValue;
end;
procedure TAboutScrollText.SetAboutBoxLicenseType(Const AValue:string);
begin
Case Upcase(AValue) of
'GPL':fAboutBox.LicenseType:=abGPL;
'LGPL':fAboutBox.LicenseType:=abLGPL;
'MIT':fAboutBox.LicenseType:=abMIT;
'MODIFIEDGPL':fAboutBox.LicenseType:=abModifiedGPL;
'PROPRIETRY':fAboutBox.LicenseType:=abProprietry;
else
fAboutBox.LicenseType:=abNone;
end;
end;
procedure TAboutScrollText.SetAboutBoxStretchBackgroundImage(Const AValue:Boolean);
begin
fAboutBox.StretchBackground:=AValue;
end;
// End Sets
constructor TAboutScrollText.Create(AOwner: TComponent);
var
TempImage: TPicture;
r:TLResource;
begin
// Inherit default properties
inherited Create(AOwner);
// Use tAboutBox as a subcomponent
fAboutBox := tAboutBox.Create(nil);
with fAboutBox do
begin
SetSubComponent(True); // Tell the IDE to store the modified properties
// Default of TAboutScrollText values override TAbouBox.Create defaults
ComponentName := 'TAboutScrollText';
Description.Add('This is to demonstrate'); //TStrings
Description.Add('the use of TAboutScrollText'); //TStrings
Description.Add('Set its properties in your Constructor'); //TStrings
Width := 320; //Integer
Height := 280; //Integer
// Set any Font properties or subproperties here
// Font.Name := 'Arial';
Font.Color := clNavy;
Font.Size:=10;
// BackGroundColor shows if no BackGround image is set
BackGroundColor := clWindow;
Version := '1.0.0.0';
AuthorName := 'Gordon Bamber';
AuthorEmail := 'minesadorada@charcodelvalle.com';
Organisation := 'Public Domain';
//Types available: abNone, abGPL, abLGPL, abMIT, abModifiedGPL, abProprietry
LicenseType := abLGPL;
// BackGround image is optional
// It must be in a resouce file in the initialization section
//== How to set a background image to your About dialog --
// The BackGround property is a TBitmap
// Use a Temporary TPicture to load a JPG.
// NOTE a PNG file will create an error when your component is used in an application!
r := LazarusResources.Find(fAboutBox.BackgroundResourceName);
if r <> nil then
begin
TempImage := TPicture.Create;
// .lrs file is in the initialization section
TempImage.LoadFromLazarusResource(fAboutBox.BackgroundResourceName);
BackGround.Assign(TempImage.Bitmap);
TempImage.Free;
StretchBackground := fAboutBox.StretchBackground; //Boolean
end;
end;
end;
destructor TAboutScrollText.Destroy;
begin
FreeAndNil(fAboutBox);
inherited Destroy;
end;
initialization
{$I license.lrs}
end.

BIN
components/scrolltext/exampleapp/project1.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 134 KiB

96
components/scrolltext/exampleapp/project1.lpi Normal file
View File

@ -0,0 +1,96 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="project1"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N Value="True" LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="scrolltext"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="3">
<Unit0>
<Filename Value="project1.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="project1"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit1>
<Unit2>
<Filename Value="scrolltext.txt"/>
<IsPartOfProject Value="True"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="project1"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

21
components/scrolltext/exampleapp/project1.lpr Normal file
View File

@ -0,0 +1,21 @@
program project1;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

173
components/scrolltext/exampleapp/project1.lps Normal file
View File

@ -0,0 +1,173 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectSession>
<PathDelim Value="\"/>
<Version Value="9"/>
<BuildModes Active="Default"/>
<Units Count="12">
<Unit0>
<Filename Value="project1.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="project1"/>
<EditorIndex Value="0"/>
<WindowIndex Value="0"/>
<TopLine Value="1"/>
<CursorPos X="1" Y="1"/>
<UsageCount Value="24"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
<EditorIndex Value="1"/>
<WindowIndex Value="0"/>
<TopLine Value="2"/>
<CursorPos X="29" Y="32"/>
<UsageCount Value="24"/>
<Loaded Value="True"/>
<LoadedDesigner Value="True"/>
</Unit1>
<Unit2>
<Filename Value="scrolltext.txt"/>
<IsPartOfProject Value="True"/>
<WindowIndex Value="0"/>
<TopLine Value="1"/>
<CursorPos X="25" Y="1"/>
<UsageCount Value="24"/>
<DefaultSyntaxHighlighter Value="None"/>
</Unit2>
<Unit3>
<Filename Value="..\..\..\lcl\forms.pp"/>
<UnitName Value="Forms"/>
<WindowIndex Value="0"/>
<TopLine Value="2007"/>
<CursorPos X="19" Y="2025"/>
<UsageCount Value="10"/>
</Unit3>
<Unit4>
<Filename Value="..\..\..\lcl\include\customform.inc"/>
<WindowIndex Value="0"/>
<TopLine Value="541"/>
<CursorPos X="1" Y="1"/>
<UsageCount Value="10"/>
</Unit4>
<Unit5>
<Filename Value="unit1.lfm"/>
<WindowIndex Value="0"/>
<TopLine Value="1"/>
<CursorPos X="7" Y="11"/>
<UsageCount Value="10"/>
<DefaultSyntaxHighlighter Value="LFM"/>
</Unit5>
<Unit6>
<Filename Value="..\..\aboutdialog\aboutboxunit.pas"/>
<UnitName Value="AboutboxUnit"/>
<EditorIndex Value="4"/>
<WindowIndex Value="0"/>
<TopLine Value="269"/>
<CursorPos X="39" Y="292"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit6>
<Unit7>
<Filename Value="..\..\..\lcl\lresources.pp"/>
<UnitName Value="LResources"/>
<EditorIndex Value="3"/>
<WindowIndex Value="0"/>
<TopLine Value="439"/>
<CursorPos X="35" Y="466"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit7>
<Unit8>
<Filename Value="..\scrollingtext.pas"/>
<UnitName Value="ScrollingText"/>
<IsVisibleTab Value="True"/>
<EditorIndex Value="2"/>
<WindowIndex Value="0"/>
<TopLine Value="112"/>
<CursorPos X="49" Y="129"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit8>
<Unit9>
<Filename Value="..\..\..\lcl\defaulttranslator.pas"/>
<UnitName Value="DefaultTranslator"/>
<WindowIndex Value="0"/>
<TopLine Value="1"/>
<CursorPos X="25" Y="22"/>
<UsageCount Value="10"/>
</Unit9>
<Unit10>
<Filename Value="..\..\lazutils\lazconfigstorage.pas"/>
<UnitName Value="LazConfigStorage"/>
<WindowIndex Value="0"/>
<TopLine Value="106"/>
<CursorPos X="1" Y="1"/>
<UsageCount Value="10"/>
</Unit10>
<Unit11>
<Filename Value="..\..\..\fpc\2.6.2\source\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<WindowIndex Value="0"/>
<TopLine Value="205"/>
<CursorPos X="1" Y="1"/>
<UsageCount Value="10"/>
</Unit11>
</Units>
<General>
<ActiveWindowIndexAtStart Value="0"/>
</General>
<JumpHistory Count="11" HistoryIndex="10">
<Position1>
<Filename Value="unit1.pas"/>
<Caret Line="33" Column="16" TopLine="1"/>
</Position1>
<Position2>
<Filename Value="unit1.pas"/>
<Caret Line="32" Column="10" TopLine="1"/>
</Position2>
<Position3>
<Filename Value="..\scrollingtext.pas"/>
<Caret Line="28" Column="32" TopLine="1"/>
</Position3>
<Position4>
<Filename Value="..\..\..\lcl\lresources.pp"/>
<Caret Line="2" Column="16" TopLine="1"/>
</Position4>
<Position5>
<Filename Value="..\scrollingtext.pas"/>
<Caret Line="166" Column="68" TopLine="140"/>
</Position5>
<Position6>
<Filename Value="..\scrollingtext.pas"/>
<Caret Line="167" Column="1" TopLine="146"/>
</Position6>
<Position7>
<Filename Value="..\scrollingtext.pas"/>
<Caret Line="162" Column="65" TopLine="146"/>
</Position7>
<Position8>
<Filename Value="..\scrollingtext.pas"/>
<Caret Line="166" Column="40" TopLine="146"/>
</Position8>
<Position9>
<Filename Value="..\scrollingtext.pas"/>
<Caret Line="156" Column="92" TopLine="146"/>
</Position9>
<Position10>
<Filename Value="..\scrollingtext.pas"/>
<Caret Line="167" Column="1" TopLine="147"/>
</Position10>
<Position11>
<Filename Value="..\scrollingtext.pas"/>
<Caret Line="132" Column="1" TopLine="104"/>
</Position11>
</JumpHistory>
</ProjectSession>
<EditorMacros Count="0"/>
</CONFIG>

7
components/scrolltext/exampleapp/project1.po Normal file
View File

@ -0,0 +1,7 @@
msgid ""
msgstr "Content-Type: text/plain; charset=UTF-8"
#: unit1.scrolltext
msgid "Hello"
msgstr ""

BIN
components/scrolltext/exampleapp/project1.res Normal file
View File

Binary file not shown.

47
components/scrolltext/exampleapp/scrolling.txt Normal file
View File

@ -0,0 +1,47 @@
TScrollingText
===========
A visual component for Lazarus/fpc
Installation
========
Make a new folder 'scrolltext' in lazarus/components
Unzip this archive into it
In Lazarus open the file 'scrolltext.lpk' as a package project
Click 'Compile' then 'Use/Install'
If asked 'do you want to recompile the IDE?' then click 'Yes'
After the compilation, the ScrollingText component will be on the 'Additional' component palette.
Use
===
Drop a ScrollingText onto a form and set the properties as required
If you want the text to come from an external text file (UseTextFile=TRUE)
then name the file 'scrolling.txt' and deploy it in the same folder as
the executable.
You can set Active=True when designing to see the scrolling text
but remember than any http:// links are only clickable in runtime mode
Download
=======
This component is available at http://www.charcodelvalle.com/scrollingtext/scrollingtext_component.zip
Version
======
This version is 1.0.0.0
License
======
GPL License (see source code)
Works With
=========
Lazarus 1.x fpc 2.6x
If when you click Lazarus Help/'About Lazaus' Contributors tab,
you can see a scrolling screen, then this component is compatible with your IDE
Support
======
minesadorada@charcodelvalle.com
Note the GPL license conditions

1
components/scrolltext/exampleapp/scrolltext.txt Normal file
View File

@ -0,0 +1 @@
This is text

78
components/scrolltext/exampleapp/unit1.lfm Normal file
View File

@ -0,0 +1,78 @@
object Form1: TForm1
Left = 403
Height = 363
Top = 139
Width = 552
BorderStyle = bsToolWindow
Caption = 'Form1'
ClientHeight = 363
ClientWidth = 552
Position = poDesktopCenter
LCLVersion = '1.2.2.0'
object ScrollingText1: TScrollingText
Left = 0
Height = 363
Top = 0
Width = 552
About.Description.Strings = (
'Component that shows a scrolling window.'#13#10'Use Lines property to set text and Active=True'#13#10'to use the component'
)
About.Title = 'About About ScrollingText component'
About.Height = 280
About.Width = 400
About.Font.Color = clNavy
About.Font.Height = -13
About.Font.Name = 'Arial'
About.BackGroundColor = clWindow
About.Version = '1.0.0.0'
About.Authorname = 'Gordon Bamber'
About.Organisation = 'Public Domain'
About.AuthorEmail = 'minesadorada@charcodelvalle.com'
About.ComponentName = 'ScrollingText component'
About.LicenseType = abLGPL
Active = False
Align = alClient
Lines.Strings = (
'This is the ScrollingText scrolling window.'
' '
'This default text is showing because you either:'
' '
'1) Haven''t set any text in the Lines property. or'
'2) TextSource is set to stTextfile and the file'
'''scrolling.txt'' is empty.'
' '
'Note that URL links such as'
'http://wiki.lazarus.freepascal.org/Main_Page'
'mailto:bill_gates@microsoft.com'
'are clickable by the user'
' '
'TScrollingText is released under the GPL license (See About)'
'Code is modified from the Lazarus ''AboutFrm'' code'
' '
'The standalone visual component TScrollingText is available at:'
'http://www.charcodelvalle.com/scrollingtext/scrollingtext_component.zip'
' '
'June 2014'
)
Font.Height = -13
end
object BitBtn1: TBitBtn
Left = 239
Height = 30
Top = 317
Width = 75
DefaultCaption = True
Kind = bkClose
ModalResult = 11
TabOrder = 0
end
object Button1: TButton
Left = 456
Height = 30
Top = 317
Width = 75
Caption = 'Toggle'
OnClick = Button1Click
TabOrder = 1
end
end

43
components/scrolltext/exampleapp/unit1.pas Normal file
View File

@ -0,0 +1,43 @@
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, ScrollingText, Forms, Controls, Graphics,
Dialogs, Buttons, StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
BitBtn1: TBitBtn;
Button1: TButton;
ScrollingText1: TScrollingText;
procedure Button1Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
resourcestring
scrolltext='Hello';
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
begin
ScrollingText1.Active:=NOT ScrollingText1.Active;
end;
end.

72
components/scrolltext/license.lrs Normal file
View File

@ -0,0 +1,72 @@
LazarusResources.Add('gpl.txt','TXT',[
' Copyright (C) <year> <name of author> <contact>'#13#10#13#10' This source'
+' is free software; you can redistribute it and/or modify it under'#13#10' '
+'the terms of the GNU General Public License as published by the Free'#13#10
+' Software Foundation; either version 2 of the License, or (at your option)'
+#13#10' any later version.'#13#10#13#10' This code is distributed in the h'
+'ope that it will be useful, but WITHOUT ANY'#13#10' WARRANTY; without even'
+' the implied warranty of MERCHANTABILITY or FITNESS'#13#10' FOR A PARTICUL'
+'AR PURPOSE. See the GNU General Public License for more'#13#10' details.'
+#13#10#13#10' A copy of the GNU General Public License is available on the '
+'World Wide Web'#13#10' at <http://www.gnu.org/copyleft/gpl.html>. You can '
+'also obtain it by writing'#13#10' to the Free Software Foundation, Inc., 5'
+'9 Temple Place - Suite 330, Boston,'#13#10' MA 02111-1307, USA.'
]);
LazarusResources.Add('lgpl.txt','TXT',[
' Copyright (C) <year> <name of author> <contact>'#13#10#13#10' This librar'
+'y is free software; you can redistribute it and/or modify it'#13#10' under'
+' the terms of the GNU Library General Public License as published by'#13#10
+' the Free Software Foundation; either version 2 of the License, or (at you'
+'r'#13#10' option) any later version.'#13#10#13#10' This program is distri'
+'buted in the hope that it will be useful, but WITHOUT'#13#10' ANY WARRANTY'
+'; without even the implied warranty of MERCHANTABILITY or'#13#10' FITNESS '
+'FOR A PARTICULAR PURPOSE. See the GNU Library General Public License'#13#10
+' for more details.'#13#10#13#10' You should have received a copy of the G'
+'NU Library General Public License'#13#10' along with this library; if not,'
+' write to the Free Software Foundation,'#13#10' Inc., 59 Temple Place - Su'
+'ite 330, Boston, MA 02111-1307, USA.'
]);
LazarusResources.Add('mit.txt','TXT',[
' Copyright (c) <year> <copyright holders>'#13#10#13#10' Permission is here'
+'by granted, free of charge, to any person obtaining a copy'#13#10' of this'
+' software and associated documentation files (the "Software"), to'#13#10' '
+'deal in the Software without restriction, including without limitation the'
+#13#10' rights to use, copy, modify, merge, publish, distribute, sublicense'
+', and/or'#13#10' sell copies of the Software, and to permit persons to who'
+'m the Software is'#13#10' furnished to do so, subject to the following con'
+'ditions:'#13#10#13#10' The above copyright notice and this permission noti'
+'ce shall be included in'#13#10' all copies or substantial portions of the '
+'Software.'#13#10#13#10' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY'
+' OF ANY KIND, EXPRESS OR'#13#10' IMPLIED, INCLUDING BUT NOT LIMITED TO THE'
+' WARRANTIES OF MERCHANTABILITY,'#13#10' FITNESS FOR A PARTICULAR PURPOSE A'
+'ND NONINFRINGEMENT. IN NO EVENT SHALL THE'#13#10' AUTHORS OR COPYRIGHT HOL'
+'DERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER'#13#10' LIABILITY, WHETHER '
+'IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING'#13#10' FROM, OUT OF '
+'OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS'#13#10' IN'
+' THE SOFTWARE.'
]);
LazarusResources.Add('modifiedgpl.txt','TXT',[
' Copyright (C) <year> <name of author> <contact>'#13#10#13#10' This librar'
+'y is free software; you can redistribute it and/or modify it'#13#10' under'
+' the terms of the GNU Library General Public License as published by'#13#10
+' the Free Software Foundation; either version 2 of the License, or (at you'
+'r'#13#10' option) any later version with the following modification:'#13#10
+#13#10' As a special exception, the copyright holders of this library give '
+'you'#13#10' permission to link this library with independent modules to pr'
+'oduce an'#13#10' executable, regardless of the license terms of these inde'
+'pendent modules,and'#13#10' to copy and distribute the resulting executabl'
+'e under terms of your choice,'#13#10' provided that you also meet, for eac'
+'h linked independent module, the terms'#13#10' and conditions of the licen'
+'se of that module. An independent module is a'#13#10' module which is not '
+'derived from or based on this library. If you modify'#13#10' this library,'
+' you may extend this exception to your version of the library,'#13#10' but'
+' you are not obligated to do so. If you do not wish to do so, delete this'
+#13#10' exception statement from your version.'#13#10#13#10' This program '
+'is distributed in the hope that it will be useful, but WITHOUT'#13#10' ANY'
+' WARRANTY; without even the implied warranty of MERCHANTABILITY or'#13#10' '
+' FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public Licen'
+'se'#13#10' for more details.'#13#10#13#10' You should have received a cop'
+'y of the GNU Library General Public License'#13#10' along with this librar'
+'y; if not, write to the Free Software Foundation,'#13#10' Inc., 59 Temple '
+'Place - Suite 330, Boston, MA 02111-1307, USA.'
]);

47
components/scrolltext/readme.txt Normal file
View File

@ -0,0 +1,47 @@
TScrollingText
===========
A visual component for Lazarus/fpc
Installation
========
Make a new folder 'scrolltext' in lazarus/components
Unzip this archive into it
In Lazarus open the file 'scrolltext.lpk' as a package project
Click 'Compile' then 'Use/Install'
If asked 'do you want to recompile the IDE?' then click 'Yes'
After the compilation, the ScrollingText component will be on the 'Additional' component palette.
Use
===
Drop a ScrollingText onto a form and set the properties as required
If you want the text to come from an external text file (UseTextFile=TRUE)
then name the file 'scrolling.txt' and deploy it in the same folder as
the executable.
You can set Active=True when designing to see the scrolling text
but remember than any http:// links are only clickable in runtime mode
Download
=======
This component is available at http://www.charcodelvalle.com/scrollingtext/scrollingtext_component.zip
Version
======
This version is 1.0.0.0
License
======
GPL License (see source code)
Works With
=========
Lazarus 1.x fpc 2.6x
If when you click Lazarus Help/'About Lazaus' Contributors tab,
you can see a scrolling screen, then this component is compatible with your IDE
Support
======
minesadorada@charcodelvalle.com
Note the GPL license conditions

369
components/scrolltext/scrollingtext.pas Normal file
View 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.

11
components/scrolltext/scrollingtext_icon.lrs Normal file
View File

@ -0,0 +1,11 @@
LazarusResources.Add('TScrollingText','PNG',[
#137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#2#0#0#0'o'#21#170#175
+#0#0#0'+tEXtCreation Time'#0'Sun 1 Jun 2014 17:18:36 -0000'#165#132#187'>'#0
+#0#0#7'tIME'#7#222#6#1#16#21#30#2#128'=='#0#0#0#9'pHYs'#0#0#14#195#0#0#14#195
+#1#199'o'#168'd'#0#0#0#4'gAMA'#0#0#177#143#11#252'a'#5#0#0#0'jIDATx'#218#237
+#213'A'#10#0'!'#8#0#192'Uz'#152'O'#215#151#153' ,{*)'#139#130#245'Pt'#25#18
+#211#128#153#159#140#192#20#197#162#248'FD'#195#132#231'T'#222#179#170#14'('
+#0#176'&5'#11#17#153#129#210'n'#180#17#10#22#20'#J'#196#194#182#226'o'#196
+#214#174#213#130#190#221#211#237#164#27#171#246'C'#27#161#224',^0'#143'f'#166
+#173#5#28#247#139'T'#233#177#28#186#248'`'#2'Z'#0#0#0#0'IEND'#174'B`'#130
]);

48
components/scrolltext/scrolltext.lpk Normal file
View File

@ -0,0 +1,48 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="scrolltext"/>
<Author Value="FPC / minesadorada (adaptation)"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Description Value="Graphic surface that scrolls (when Active=True) that can be loaded with a Stringlist"/>
<License Value="LGPL"/>
<Version Major="1" Minor="1"/>
<Files Count="2">
<Item1>
<Filename Value="scrollingtext.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="ScrollingText"/>
</Item1>
<Item2>
<Filename Value="aboutscrolltextunit.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="AboutScrolltextunit"/>
</Item2>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="1">
<Item1>
<PackageName Value="IDEIntf"/>
</Item1>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

24
components/scrolltext/scrolltext.lrs Normal file
View File

@ -0,0 +1,24 @@
LazarusResources.Add('scrolling','TXT',[
'TScrollingText'#13#10'==========='#13#10#13#10'A visual component for Lazaru'
+'s/fpc'#13#10#13#10'Installation'#13#10'========'#13#10'Make a new folder '''
+'scrolltext'' in lazarus/components'#13#10'Unzip this archive into it'#13#10
+'In Lazarus open the file ''scrolltext.lpk'' as a package project'#13#10'Cli'
+'ck ''Compile'' then ''Use/Install'''#13#10'If asked ''do you want to recomp'
+'ile the IDE?'' then click ''Yes'''#13#10#13#10'After the compilation, the S'
+'crollingText component will be on the ''Additional'' component palette.'#13
+#10#13#10'Use'#13#10'==='#13#10'Drop a ScrollingText onto a form and set the'
+' properties as required'#13#10'If you want the text to come from an externa'
+'l text file (UseTextFile=TRUE)'#13#10'then name the file ''scrolling.txt'' '
+'and deploy it in the same folder as'#13#10'the executable.'#13#10#13#10'You'
+' can set Active=True when designing to see the scrolling text'#13#10'but re'
+'member than any http:// links are only clickable in runtime mode'#13#10#13
+#10'Download'#13#10'======='#13#10'This component is available at http://www'
+'.charcodelvalle.com/scrollingtext/scrollingtext_component.zip'#13#10#13#10
+'Version'#13#10'======'#13#10'This version is 1.0.0.0'#13#10#13#10'License'
+#13#10'======'#13#10'GPL License (see source code)'#13#10#13#10'Works With'
+#13#10'========='#13#10'Lazarus 1.x fpc 2.6x'#13#10'If when you click Lazaru'
+'s Help/''About Lazaus'' Contributors tab,'#13#10'you can see a scrolling sc'
+'reen, then this component is compatible with your IDE'#13#10#13#10'Support'
+#13#10'======'#13#10'minesadorada@charcodelvalle.com'#13#10'Note the GPL lic'
+'ense conditions'#13#10
]);

22
components/scrolltext/scrolltext.pas Normal file
View File

@ -0,0 +1,22 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit scrolltext;
interface
uses
ScrollingText, AboutScrolltextunit, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('ScrollingText', @ScrollingText.Register);
RegisterUnit('AboutScrolltextunit', @AboutScrolltextunit.Register);
end;
initialization
RegisterPackage('scrolltext', @Register);
end.

BIN
components/scrolltext/scrolltext100_properties.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 39 KiB

BIN
components/scrolltext/scrolltext_ico.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 274 B