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

* Initial commit of smnetgradient (version 2.0.5)

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1073 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
blikblum
2009-12-22 21:06:14 +00:00
parent 266d65ee1b
commit c6b64473fe
9 changed files with 1184 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
components/smnetgradient/changelog.txt Normal file
View File

@ -0,0 +1,14 @@
Changes between 2.0.4 and 2.0.5 (By Luiz Américo)
* Correctly set the version info in the package description
* Removed About property since does not make sense at all
* Made SubCaption a read only property
* Removed unused variables and fields
* Commented SbCapOffs since is not being used currently
* Add const keyword for read only string parameters
* Check is new value is equal to old one in set property methods
* Comment initialization of fields with default values (False, 0)
* Remove DestroyObjects function: was being used to destroy only one object
* Format the code (remove excess of spaces) for more consistency
* Added BeginUpdate and EndUpdate: protects against handle creation while loading
* Published BorderSpacing
* Fixed memory leaks

72
components/smnetgradient/demo/project1.lpi Normal file
View File

@ -0,0 +1,72 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="7"/>
<General>
<Flags>
<AlwaysBuild Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<TargetFileExt Value=".exe"/>
<UseXPManifest Value="True"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="smnetgradientlaz"/>
<MinVersion Major="1" Valid="True"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="project1.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="project1"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="MainForm"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="8"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)\"/>
<UnitOutputDirectory Value="out"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>

17
components/smnetgradient/demo/project1.lpr Normal file
View File

@ -0,0 +1,17 @@
program project1;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1;
begin
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.

151
components/smnetgradient/demo/unit1.lfm Normal file
View File

@ -0,0 +1,151 @@
object MainForm: TMainForm
Left = 406
Height = 397
Top = 215
Width = 322
Caption = 'NetGradient Demo'
ClientHeight = 397
ClientWidth = 322
LCLVersion = '0.9.29'
object NetGradient1: TNetGradient
Left = 6
Height = 39
Top = 3
Width = 313
CaptionAlignment = taLeftJustify
CaptionLayout = tlTop
BevelInner = bvLowered
BevelOuter = bvNone
BeginColor = clLime
EndColor = 10841401
Font.Style = [fsBold]
Caption = 'Caption'
TextTop = 0
TextLeft = 0
end
object NetGradient2: TNetGradient
Left = 6
Height = 32
Top = 45
Width = 312
CaptionAlignment = taCenter
BevelInner = bvLowered
BevelOuter = bvLowered
BeginColor = clSkyBlue
EndColor = clTeal
Font.Style = [fsBold]
Caption = 'Caption'
TextTop = 0
TextLeft = 0
end
object NetGradient3: TNetGradient
Left = 6
Height = 47
Top = 78
Width = 312
CaptionAlignment = taLeftJustify
CaptionLayout = tlTop
BevelInner = bvLowered
BeginColor = clSilver
EndColor = 10841401
Font.CharSet = ANSI_CHARSET
Font.Color = clMenuHighlight
Font.Height = -16
Font.Name = 'Arial'
Font.Pitch = fpVariable
Font.Quality = fqDraft
Font.Style = [fsBold]
Caption = 'Caption'
TextTop = 0
TextLeft = 5
end
object NetGradient4: TNetGradient
Left = 6
Height = 60
Top = 216
Width = 313
CaptionAlignment = taLeftJustify
BevelInner = bvRaised
BevelOuter = bvLowered
BeginColor = clRed
EndColor = clYellow
Font.Style = [fsBold]
Caption = 'Caption'
TextTop = 0
TextLeft = 2
end
object NetGradient5: TNetGradient
Left = 6
Height = 44
Top = 126
Width = 312
CaptionAlignment = taLeftJustify
CaptionLayout = tlTop
BevelInner = bvLowered
BeginColor = clSilver
EndColor = 10841401
Font.CharSet = ANSI_CHARSET
Font.Color = clMenuHighlight
Font.Height = -16
Font.Name = 'Arial'
Font.Pitch = fpVariable
Font.Quality = fqDraft
Font.Style = [fsBold]
Caption = 'Caption'
TextTop = 0
TextLeft = 20
end
object NetGradient6: TNetGradient
Left = 6
Height = 44
Top = 171
Width = 312
CaptionAlignment = taRightJustify
CaptionLayout = tlTop
BevelInner = bvLowered
BeginColor = clSilver
EndColor = 10841401
Font.CharSet = ANSI_CHARSET
Font.Color = clMenuHighlight
Font.Height = -16
Font.Name = 'Arial'
Font.Pitch = fpVariable
Font.Quality = fqDraft
Font.Style = [fsBold]
Caption = 'Caption'
TextTop = 0
TextLeft = -20
end
object NetGradient8: TNetGradient
Left = 5
Height = 60
Top = 336
Width = 313
CaptionAlignment = taLeftJustify
BevelInner = bvRaised
BevelOuter = bvLowered
BeginColor = clRed
EndColor = clYellow
FillDirection = ftBottomToTop
Font.Style = [fsBold]
Caption = 'Caption'
TextTop = -20
TextLeft = 2
end
object NetGradient9: TNetGradient
Left = 6
Height = 60
Top = 276
Width = 313
CaptionAlignment = taLeftJustify
BevelInner = bvRaised
BevelOuter = bvLowered
BeginColor = clRed
EndColor = clYellow
FillDirection = ftTopToBottom
Font.Style = [fsBold]
Caption = 'Caption'
TextTop = -20
TextLeft = 2
end
end

39
components/smnetgradient/demo/unit1.pas Normal file
View File

@ -0,0 +1,39 @@
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
SMNetGradient;
type
{ TMainForm }
TMainForm = class(TForm)
NetGradient1: TNetGradient;
NetGradient2: TNetGradient;
NetGradient3: TNetGradient;
NetGradient4: TNetGradient;
NetGradient5: TNetGradient;
NetGradient6: TNetGradient;
NetGradient8: TNetGradient;
NetGradient9: TNetGradient;
private
{ private declarations }
public
{ public declarations }
end;
var
MainForm: TMainForm;
implementation
initialization
{$I unit1.lrs}
end.

25
components/smnetgradient/register_smnetgradient.pas Normal file
View File

@ -0,0 +1,25 @@
unit register_smnetgradient;
{$mode objfpc}{$H+}
interface
uses
Classes, LazarusPackageIntf, SMNetGradient;
procedure Register;
implementation
procedure RegisterUnitSMNetGradient;
begin
RegisterComponents('SMACE', [TNetGradient]);
end;
procedure Register;
begin
RegisterUnit('SMNetGradient', @RegisterUnitSMNetGradient);
end;
end.

796
components/smnetgradient/smnetgradient.pas Normal file
View File

@ -0,0 +1,796 @@
{ ----------------------------------------------------------------------------}
{ A Gradient Fill component for Delphi. }
{ TGradientFill, Copyright 1995, Curtis White. All Rights Reserved. }
{ TNetGradient, Copyright 1997, Heiko Webers. All Rights Reserved. }
{ This component can be freely used and distributed in commercial and private }
{ environments, provided this notice is not modified in any way. }
{ ----------------------------------------------------------------------------}
{ Feel free to contact me if you have any questions, comments or suggestions }
{ at cwhite@teleport.com }
{ Or me at heikowebers@usa.net }
{ ----------------------------------------------------------------------------}
{ Date last modified: 18/10/2009 }
{ ----------------------------------------------------------------------------}
{ ----------------------------------------------------------------------------}
{ TNetGradient v2.05 }
{ ----------------------------------------------------------------------------}
{ Description: }
{ A gradient fill like in the new Netscape Communicator Options Box. }
{ Features: }
{ The begin and end colors can be any colors. }
{ The fill direction can be set to Right-To-Left or Left-To-Right. }
{ The number of colors, between 1 and 255 can be set for the fill. }
{ The Caption can be anything and anywhere on TNetGradient. }
{ ----------------------------------------------------------------------------}
{ ----------------------------------------------------------------------------}
{ Revision History: }
{ 1.00: Initial release }
{ 1.00: Changed to TNetGradient }
{ 1.01: Border Update by Enzo Scozzaro www.scozzaro.it www.thefox.it }
{ 2.00: +Caption Alignment, +Layout, +DataSource }
{ 2.01: +SubCaption, +Font, +MarginLeft, +MarginTop, +SubCapField }
{ 2.03: -Bug TextLetf }
{ 2.04: FillDirection: +ftTopToBottom, +ftBottomToTop }
{ 2.05: +Begin/EndUpdate, Fix crash in frames, Fix memory leaks, Cleanup }
{ ----------------------------------------------------------------------------}
unit SMNetGradient;
{$MODE Delphi}
interface
uses
LCLIntf, LCLType, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, GraphType, Db, DBCtrls;
Const
DefaultStyle = DT_SINGLELINE or DT_END_ELLIPSIS or DT_EXPANDTABS;
type
{ Direction of fill }
TFillDirection = (fdLeftToRight, fdRightToLeft, ftTopToBottom, ftBottomToTop);
{ Range of valid colors }
TNumberOfColors = 1..255;
TLabelBevel = TBevelCut;
TMargin = 0..MaxInt;
TNetGradient = class;
TSubCaption = class(TPersistent)
private
{ Private-Deklarationen }
Parent: TNetGradient;
FCaption: TCaption;
FFont: TFont;
FHotTrack: Boolean;
FMarginLeft: Integer;
FMarginTop: Integer;
FVisible: Boolean;
procedure OnFontChanged(Sender: TObject);
protected
{ Protected declarations }
procedure SetCaption(const Value: TCaption); virtual;
procedure SetFont(Value: TFont); virtual;
procedure SetMarginLeft(Value: Integer); virtual;
procedure SetMarginTop(Value: Integer); virtual;
procedure SetVisible(Value: Boolean); virtual;
public
{ Public declarations }
constructor Create(AOwner: TNetGradient); overload;
destructor Destroy; override;
published
{ Published-Deklarationen }
property Caption: TCaption read FCaption write SetCaption;
property HotTrack: Boolean read FHotTrack write FHotTrack default False;
property MarginLeft: Integer read FMarginLeft write SetMarginLeft default 5;
property MarginTop: Integer read FMarginTop write SetMarginTop default 0;
property Font: TFont read FFont write SetFont;
property Visible: Boolean read FVisible write SetVisible default True;
end;
{ TNetGradient }
TNetGradient = class(TCustomControl)
private
//*** Enzo *** Bordi
FBevelInner: TLabelBevel;
FBevelOuter: TLabelBevel;
//*** Emzp *** Allineamento Caption
FAlignment : TAlignment;
FLayout : TTextLayout;
//*** Enzo *** Data Source - Field
FDataLink : TFieldDataLink;
//FMargin: TMargin;
{ Variables for properties }
FDirection: TFillDirection;
FBeginColor: TColor;
FEndColor: TColor;
// FCenter: Boolean;
FNumberOfColors: TNumberOfColors;
FFont : TFont;
FCaption : TCaption;
FTextTop : Integer;
FTextLeft: Integer;
FSubCapField: Boolean;
FSubCaption: TSubCaption;
FUpdateCount: Integer;
procedure OnFontChanged(Sender: TObject);
procedure Changed;
{ Procedures for setting property values }
procedure SetFillDirection(Value: TFillDirection);
procedure SetBeginColor(Value: TColor);
procedure SetEndColor(Value: TColor);
procedure SetNumberOfColors(Value: TNumberOfColors);
procedure SetFont(AFont: TFont);
procedure SetCaption(const Value: String);
procedure SetTextTop(Value: Integer);
procedure SetTextLeft(Value: Integer);
{ Fill procedure }
procedure GradientFill;
//*** Enzo *** Data Source
function GetSubCapField: Boolean;
Procedure SetSubCapField(Value:Boolean);
procedure SetDataField (const Value : String);
function GetDataField: String;
function GetDataSource: TDataSource;
procedure SetDataSource (Value: TDataSource);
function GetField: TField;
procedure DataChange(Sender: TObject);
protected
procedure Paint; override;
procedure SetAlignment(Value: TAlignment);
procedure SetLayout(Value: TTextLayout); virtual;
procedure SetBevelInner(Value: TLabelBevel);
procedure SetBevelOuter(Value: TLabelBevel);
// procedure DataChange(Sender:TObject);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure BeginUpdate;
procedure EndUpdate;
published
property CaptionAlignment: TAlignment read FAlignment write SetAlignment;
property CaptionLayout: TTextLayout read FLayout write SetLayout default tlCenter;
property BevelInner: TLabelBevel read FBevelInner write SetBevelInner default bvNone;
property BevelOuter: TLabelBevel read FBevelOuter write SetBevelOuter default bvRaised;
{ Starting color of fill }
property BeginColor: TColor read FBeginColor write SetBeginColor
default clBlue;
{ Ending color of fill }
property EndColor: TColor read FEndColor write SetEndColor default clBlack;
{ Direction of fill }
property FillDirection: TFillDirection read FDirection write SetFillDirection default fdLeftToRight;
{ Number of colors to use in the fill (1 - 256) - default is 255. If 1 }
{ then it uses the Begin Color. }
property NumberOfColors: TNumberOfColors read FNumberOfColors write SetNumberOfColors default 255;
{ Enable standard properties }
property Font: TFont read FFont write SetFont;
property Caption: String read FCaption write SetCaption;
property TextTop: Integer read FTextTop write SetTextTop;
property TextLeft: Integer read FTextLeft write SetTextLeft;
property Align;
property BorderSpacing;
property DragCursor;
property DragMode;
property Enabled;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
//*** Enzo ***
property SubCapField: Boolean read FSubCapField write SetSubCapField default false;
property DataField: String Read GetDataField write SetDataField;
property DataSource: TDataSource read GetDataSource write SetDataSource;
property SubCaption: TSubCaption read FSubCaption;
end;
implementation
{ TNetGradient }
{ Override the constructor to initialize variables }
constructor TNetGradient.Create(AOwner: TComponent);
begin
{ Inherit original constructor }
inherited Create(AOwner);
{ Add new initializations }
FLayout := tlCenter;
FBevelInner := bvNone;
FBevelOuter := bvRaised;
Height := 25;
Width := 400;
FBeginColor := clSilver;
FEndColor := $00A56D39;
FDirection := fdLeftToRight;
FNumberOfColors:= 255;
//FTextLeft:= 0;
//FTextTop:= 0;
FFont := TFont.Create;
FFont.Style:= [fsbold];
FFont.OnChange := OnFontChanged;
FSubCaption := TSubCaption.Create(Self);
//Caption := Name;
//FCaption := AOwner.Name;
//ShowMessage((AOwner as TComponent).);
//FCaption:= 'test';
//*** Enzo ***
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
(*
FDataLink.OnUpdateData := @UpdateData;
FDataLink.OnActiveChange := @ActiveChange;
FDataLink.OnLayoutChange := @LayoutChange;
*)
end;
destructor TNetGradient.Destroy;
begin
FSubCaption.Destroy;
FFont.Destroy;
FDataLink.Destroy;
inherited Destroy;
end;
{ Set begin color when property is changed }
procedure TNetGradient.SetBeginColor(Value: TColor);
begin
if Value <> FBeginColor then
begin
FBeginColor := Value;
Changed;
end;
end;
{ Set end color when property is changed }
procedure TNetGradient.SetEndColor(Value: TColor);
begin
if Value <> FEndColor then
begin
FEndColor := Value;
Changed;
end;
end;
{ Set the number of colors to be used in the fill }
procedure TNetGradient.SetNumberOfColors(Value: TNumberOfColors);
begin
if Value <> FNumberOfColors then
begin
FNumberOfColors := Value;
Changed;
end;
end;
// Set the Font
procedure TNetGradient.SetFont(AFont: TFont);
begin
if AFont <> FFont then
begin
FFont.Assign(AFont);
Changed;
end;
end;
// Set the Caption on NG
procedure TNetGradient.SetCaption(const Value: String);
begin
if Value <> FCaption then
begin
FCaption := Value;
Changed;
end;
end;
// Set the Position of the Caption (Top)
procedure TNetGradient.SetTextTop(Value: Integer);
begin
if Value <> FTextTop then
begin
FTextTop := Value;
Changed;
end;
end;
// Set the Position of the Caption (Left)
procedure TNetGradient.SetTextLeft(Value: Integer);
begin
if Value <> FTextLeft then
begin
FTextLeft := Value;
Changed;
end;
end;
{ Perform the fill when paint is called }
procedure TNetGradient.Paint;
begin
GradientFill;
end;
{ Gradient fill procedure - the actual routine }
procedure TNetGradient.GradientFill;
var
{ Set up working variables }
BeginRGBValue : array[0..2] of Byte; { Begin RGB values }
RGBDifference : array[0..2] of integer; { Difference between begin and end }
{ RGB values }
ColorBand , rp,cr: TRect; { Color band rectangular coordinates }
I , x : Integer; { Color band index }
R : Byte; { Color band Red value }
G : Byte; { Color band Green value }
B : Byte; { Color band Blue value }
WorkBmp : TBitmap; { Off screen working bitmap }
DrawStyle : LongInt;
TS : TTextStyle;
GlyphOffs : Integer;
//SbCapOffs : Integer;
procedure DoDrawText(const Text: string; ACanvas: TCanvas; AFont: TFont; var Rect: TRect; Flags: LongInt);
begin
with ACanvas do
begin
Font.Assign(AFont);
Rect.Left:=Rect.Left; //**
if not(Enabled) then
begin
OffsetRect(Rect, 1, 1);
Font.Color := clBtnHighlight;
DrawText(Handle, PChar(Text), Length(Text), Rect, Flags);
OffsetRect(Rect, -1, -1); //**
Font.Color := clBtnShadow;
DrawText(Handle, PChar(Text), Length(Text), Rect, Flags);
end
else
DrawText(Handle, PChar(Text), Length(Text), Rect, Flags);
end;
end;
begin
{ Create the working bitmap and set its width and height }
WorkBmp := TBitmap.Create;
WorkBmp.Width := Width;
WorkBmp.Height := Height;
{ Use working bitmap to draw the gradient }
with WorkBmp do
begin
Rp := GetClientRect;
{ Extract the begin RGB values }
case FDirection of
fdLeftToRight,ftTopToBottom: begin
{ Set the Red, Green and Blue colors }
BeginRGBValue[0] := GetRValue (ColorToRGB (FBeginColor));
BeginRGBValue[1] := GetGValue (ColorToRGB (FBeginColor));
BeginRGBValue[2] := GetBValue (ColorToRGB (FBeginColor));
{ Calculate the difference between begin and end RGB values }
RGBDifference[0] := GetRValue (ColorToRGB (FEndColor)) -
BeginRGBValue[0];
RGBDifference[1] := GetGValue (ColorToRGB (FEndColor)) -
BeginRGBValue[1];
RGBDifference[2] := GetBValue (ColorToRGB (FEndColor)) -
BeginRGBValue[2];
end;
fdRightToLeft,ftBottomToTop: begin
{ Set the Red, Green and Blue colors }
BeginRGBValue[0] := GetRValue (ColorToRGB (FEndColor));
BeginRGBValue[1] := GetGValue (ColorToRGB (FEndColor));
BeginRGBValue[2] := GetBValue (ColorToRGB (FEndColor));
{ Calculate the difference between begin and end RGB values }
RGBDifference[0] := GetRValue (ColorToRGB (FBeginColor)) -
BeginRGBValue[0];
RGBDifference[1] := GetGValue (ColorToRGB (FBeginColor)) -
BeginRGBValue[1];
RGBDifference[2] := GetBValue (ColorToRGB (FBeginColor)) -
BeginRGBValue[2];
end;
end;
{ Set the pen style and mode }
Canvas.Pen.Style := psSolid;
Canvas.Pen.Mode := pmCopy;
case FDirection of
{ Calculate the color band's left and right coordinates }
{ for LeftToRight and RightToLeft fills }
fdLeftToRight, fdRightToLeft:
begin
ColorBand.Top := 0;
ColorBand.Bottom := Height;
end;
ftTopToBottom, ftBottomToTop:
begin
ColorBand.Left := 0;
ColorBand.Right := Width;
end;
end;
{ Perform the fill }
for I := 0 to FNumberOfColors do
begin
case FDirection of
{ Calculate the color band's left and right coordinates }
fdLeftToRight, fdRightToLeft:
begin
ColorBand.Left := MulDiv (I , Width, FNumberOfColors);
ColorBand.Right := MulDiv (I + 1, Width, FNumberOfColors);
end;
ftTopToBottom, ftBottomToTop:
begin
ColorBand.Top := MulDiv (I , Height, FNumberOfColors);
ColorBand.Bottom := MulDiv (I + 1, Height, FNumberOfColors);
end;
end;
{ Calculate the color band's color }
if FNumberOfColors > 1 then
begin
R := BeginRGBValue[0] + MulDiv (I, RGBDifference[0], FNumberOfColors - 1);
G := BeginRGBValue[1] + MulDiv (I, RGBDifference[1], FNumberOfColors - 1);
B := BeginRGBValue[2] + MulDiv (I, RGBDifference[2], FNumberOfColors - 1);
end
else
{ Set to the Begin Color if set to only one color }
begin
R := BeginRGBValue[0];
G := BeginRGBValue[1];
B := BeginRGBValue[2];
end;
{ Select the brush and paint the color band }
Canvas.Brush.Color := RGB (R, G, B);
Canvas.FillRect (ColorBand);
end;
end;
{ Copy the working bitmap to the main canvas }
Canvas.Draw(0, 0, WorkBmp);
// <TextOut>
Canvas.Brush.Style:= bsClear;
Canvas.Font.Assign(FFont);
//Canvas.Textout(FTextLeft, FTextTop, FCaption); *** Enzo *** Implemetation
Canvas.Frame3D(Rp, 1,FBevelOuter);
Canvas.Frame3d(rp, 1, FBevelInner);
if Caption <> '' then begin
Font.Assign(Self.Font);
Rp := GetClientRect;
Inc(Rp.Left, FTextLeft); //5=FMargin
//if FGlyph.DisplayAlign = daLeft then
// Inc(Rp.Left, GlyphOffs)
//else
// Dec(R.Right, GlyphOffs);
//Dec(R.Right, SbCapOffs);
case FAlignment of
taLeftJustify : begin
DrawStyle := DefaultStyle or DT_LEFT;
Inc(Rp.Left, FTextLeft);
end;
taRightJustify : begin
DrawStyle := DefaultStyle or DT_RIGHT;
Inc(Rp.Right, FTextLeft);
end;
taCenter : begin
DrawStyle := DefaultStyle or DT_CENTER;
Inc(Rp.Left, FTextLeft);
end;
end;
//DrawStyle := DefaultStyle or FAlignment; //Enzo DT_LEFT;
TS := Canvas.TextStyle;
TS.Alignment:= CaptionAlignment;
//TS.Layout:= tlCenter;
TS.Opaque:= false;
TS.Clipping:= false;
TS.SystemFont:=Canvas.Font.IsDefault;
CR := Rp;
//cr.left := cr.Left + FTextLeft;
//rp.left :=rp.left + FTextLeft;
rp.Top:= rp.Top + FTextTop;
if FLayout <> tlTop then begin
X := Canvas.TextHeight('W');
DoDrawText(Caption, WorkBmp.Canvas, Self.Font, CR, DrawStyle or DT_CALCRECT);
if FLayout = tlBottom then OffsetRect(Rp, 0, Height - CR.Bottom-2)
else OffsetRect(Rp, 0, (Height - CR.Bottom) div 2);
end;
// if Rp.Right - Rp.Left >= Canvas.TextWidth(Caption[1]) then
Canvas.TextRect(rp, rp.Left, rp.Top, Caption, TS);
end;
//*** Enzo **** SubCaption
if (FSubCaption.Caption <> '') then begin
GlyphOffs := 0;
//SbCapOffs := 0;
Canvas.Font.Assign(FSubCaption.Font);
Rp := GetClientRect;
//DrawStyle := DefaultStyle or DT_RIGHT;
// if FLayout <> tlTop then begin
// rp:=GetClientRect;
X := canvas.TextHeight('W');
Inc(Rp.Left, ClientWidth - canvas.TextWidth(FSubCaption.Caption) - FSubCaption.MarginLeft);
if Rp.Left < SubCaption.FMarginLeft + GlyphOffs then Rp.Left := SubCaption.FMarginLeft + GlyphOffs;
//SbCapOffs := Rp.Right - Rp.Left;
CR := Rp;
Inc(cr.Left, SubCaption.FMarginLeft);
rp.Top:= rp.Top+SubCaption.FMarginTop;
DoDrawText(FSubCaption.Caption, WorkBmp.Canvas, Self.Font, CR, DT_CALCRECT);
if FLayout = tlBottom then begin
OffsetRect(Rp, 0, Height - X - Abs(canvas.TextHeight('W') - X) div 2);
end else if FLayout = tlTop then begin
Font.Assign(Self.Font);
end else
OffsetRect(Rp, 0, (Height - CR.Bottom) div 2);
Canvas.TextRect(rp, rp.Left, rp.Top, FSubCaption.Caption);
end;
// Border Outer and Inner
// Canvas.Frame3d(rp, 1, bvRaised);
// </TextOut>
{ Release the working bitmap resources }
WorkBmp.Free;
end;
{ Set the fill direction }
procedure TNetGradient.SetFillDirection(Value: TFillDirection);
begin
if Value <> FDirection then
begin
FDirection := Value;
Changed;
end;
end;
//*** Enzo ***
procedure TNetGradient.SetAlignment(Value: TAlignment);
begin
if FAlignment <> Value then
begin
FAlignment := Value;
Changed;
end;
end;
procedure TNetGradient.SetLayout(Value: TTextLayout);
begin
if Value <> FLayout then
begin
FLayout := Value;
Changed;
end;
end;
procedure TNetGradient.SetBevelInner(Value: TLabelBevel);
begin
if Value <> FBevelInner then begin
FBevelInner := Value;
Changed;
end;
end;
procedure TNetGradient.SetBevelOuter(Value: TLabelBevel);
begin
if Value <> FBevelOuter then
begin
FBevelOuter := Value;
Changed;
end;
end;
//*** Enzo ***
function TNetGradient.GetSubCapField: Boolean;
begin
Result := FSubCapField;
end;
procedure TNetGradient.SetSubCapField(Value: Boolean);
begin
FSubCapField := Value;
end;
function TNetGradient.GetDataField: STring;
begin
Result := FDataLink.FieldName;
end;
procedure TNetGradient.SetDataField (const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TNetGradient.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TNetGradient.SetDataSource (Value: TDataSource);
procedure ChangeDataSource(AControl: TControl; Link: TDataLink;
NewDataSource: TDataSource);
begin
if Link.DataSource=NewDataSource then exit;
if Link.DataSource<>nil then
Link.DataSource.RemoveFreeNotification(AControl);
Link.DataSource:=NewDataSource;
if Link.DataSource<>nil then
Link.DataSource.FreeNotification(AControl);
end;
begin
//* enzo
//FDataLink.DataSource := Value;
ChangeDataSource(Self, FDataLink, Value);
// useless e
{if Value <> nil then
Value.FreeNotification (Value);}
end;
function TNetGradient.GetField: TField;
begin
Result := FDataLink.Field;
end;
// data link event handler
procedure TNetGradient.DataChange (Sender: TObject);
begin
if FDataLink.DataSet.Active = true then begin
//enzo
if FSubCapField = False Then begin
Caption := FDataLink.Field.AsString;
end else begin
fSubCaption.SetCaption( FDataLink.Field.DisplayText);
//fSubCaption.SetCaption( FDataLink.Field.AsString);
end;
end;
end;
procedure TNetGradient.OnFontChanged(Sender: TObject);
begin
Changed;
end;
procedure TNetGradient.BeginUpdate;
begin
Inc(FUpdateCount);
end;
procedure TNetGradient.Changed;
begin
if (FUpdateCount = 0) and not (csLoading in ComponentState) then
begin
Invalidate;
end;
end;
procedure TNetGradient.EndUpdate;
begin
if FUpdateCount > 0 then
Dec(FUpdateCount);
Changed;
end;
//**********
constructor TSubCaption.Create(AOwner: TNetGradient);
begin
inherited Create;
Parent := AOwner;
//FCaption := '';
FFont := TFont.Create;
FFont.OnChange := OnFontChanged;
//FHotTrack := False;
FMarginLeft := 5;
//FMarginTop := 0;
FVisible := True;
end;
destructor TSubCaption.Destroy;
begin
FFont.Destroy;
inherited Destroy;
end; // Destroy
procedure TSubCaption.SetCaption(const Value: TCaption);
begin
if Value <> FCaption then
begin
FCaption := Value;
Parent.Changed;
end
end;
procedure TSubCaption.SetFont(Value: TFont);
begin
FFont.Assign(Value);
end;
procedure TSubCaption.OnFontChanged(Sender: TObject);
begin
Parent.Changed;
end;
procedure TSubCaption.SetMarginLeft(Value: Integer);
begin
if Value <> FMarginLeft then
begin
FMarginLeft := Value;
Parent.Changed;
end;
end;
procedure TSubCaption.SetMarginTop(Value: Integer);
begin
if Value <> FMarginTop then
begin
FMarginTop := Value;
Parent.Changed;
end;
end;
procedure TSubCaption.SetVisible(Value: Boolean);
begin
if Value <> FVisible then
begin
FVisible := Value;
Parent.Changed;
end;
end;
end.

49
components/smnetgradient/smnetgradientlaz.lpk Normal file
View File

@ -0,0 +1,49 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="3">
<Name Value="smnetgradientlaz"/>
<Author Value="Curtis White &amp; Heiko Webers (converted for lazarus by barko)"/>
<CompilerOptions>
<Version Value="8"/>
<SearchPaths>
<UnitOutputDirectory Value="lib"/>
</SearchPaths>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Description Value="A gradient fill like in the new Netscape Communicator Options Box."/>
<License Value="This component can be freely used and distributed in commercial and private environments, provided this notice is not modified in any way."/>
<Version Major="2" Release="5"/>
<Files Count="2">
<Item1>
<Filename Value="smnetgradient.pas"/>
<UnitName Value="SMNetGradient"/>
</Item1>
<Item2>
<Filename Value="register_smnetgradient.pas"/>
<HasRegisterProc Value="True"/>
<AddToUsesPkgSection Value="False"/>
<UnitName Value="register_smnetgradient"/>
</Item2>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)/"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<DestinationDirectory Value="/home/barko/tempo/"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
</Package>
</CONFIG>

21
components/smnetgradient/smnetgradientlaz.pas Normal file
View File

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