Transperant property driller i hjemmestrikket komponent
hej eksperter :)jeg fandt denne komponent på nettet og valgte at udvidde den med et transparent property.
dog volder det en del problemer for mig at få transperant effekten frem.
min inspiration til transperant koden er hentet fra TCustomLabel og TImage.
hvor er det jeg har overset noget?
på forhånd tak :)
{
Original component by:
TBnVertScrollText version 1.00
author: Benoe (wisnu_aribow[at]hotmail.com)
-- 2001 --
Documentation : TBnVertScrollText.txt
Extended by Glenn Dufke in 2008
(tuxilinx[at]gmail.com)
}
unit VerticalScrollText;
interface
uses
Windows, SysUtils, Classes, Controls, Graphics, Forms, Dialogs,
ExtCtrls, ComCtrls, Messages;
type
TAlign = (alLeft, alCenter, alRight);
TVerticalScrollText = class(TGraphicControl)
private
FLines: TStringList;
FBgBmp: TBitmap;
FInterval: Integer;
FRepeat: Boolean;
FEnabled: Boolean;
FStretch: Boolean;
FAlign: TAlign;
FTransparent: Boolean;
LinePos: Integer;
PosX: Integer;
PosY: Integer;
TextBitmap: TBitmap;
BgBitmap: TBitmap;
CopyBitmap: TBitmap;
SpTimer: TTimer;
procedure SetLines(Value: TStringList);
procedure SetTransparent(Value: Boolean);
procedure SetInterval(Value: Integer);
procedure SetBgBitmap(Value: TBitmap);
procedure SetEnabled(Value: Boolean);
procedure SetAlign(Value: TAlign);
procedure SetStretch(Value: Boolean);
procedure DoTransparent;
procedure Inv;
procedure OnTimer(Sender: TObject);
procedure CMFontChanged(var Msg: TMessage); message CM_FontChanged;
protected
procedure Loaded; override;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Resize; override;
published
property Lines: TStringList read FLines write SetLines;
property Interval: Integer read FInterval write SetInterval;
property BackgroundBitmap: TBitmap read FBgBmp write SetBgBitmap;
property Font;
property ParentFont;
property RepeatScroll: Boolean read FRepeat write FRepeat;
property Enabled: Boolean read FEnabled write SetEnabled;
property Alignment: TAlign read FAlign write SetAlign;
property Stretch: Boolean read FStretch write SetStretch;
property Transparent: Boolean read FTransparent write SetTransparent default False;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TVerticalScrollText]);
end;
constructor TVerticalScrollText.Create(AOwner: TComponent);
begin
inherited;
TextBitmap := TBitmap.Create;
BgBitmap := TBitmap.Create;
CopyBitmap := TBitmap.Create;
FBgBmp := TBitmap.Create;
FLines := TStringList.Create;
SpTimer := TTimer.Create(nil);
TextBitmap.Transparent := True;
FLines.Add('Scrolling text goes here...');
FInterval := 50;
FEnabled := True;
FRepeat := True;
Width := 200;
Height := 100;
PosY := Height;
SpTimer.Interval := FInterval;
SpTimer.OnTimer := OnTimer;
end;
destructor TVerticalScrollText.Destroy;
begin
SpTimer.Free;
FBgBmp.Free;
TextBitmap.Free;
CopyBitmap.Free;
BgBitmap.Free;
FLines.Free;
inherited;
end;
procedure TVerticalScrollText.Loaded;
begin
Inv;
end;
procedure TVerticalScrollText.CMFontChanged(var Msg: TMessage);
begin
inherited;
Inv;
Msg.Result := 1;
end;
procedure TVerticalScrollText.SetLines(Value: TStringList);
begin
if FLines <> Value then
begin
FLines.Assign(Value);
Inv;
end;
end;
procedure TVerticalScrollText.DoTransparent;
begin
if not FTransparent then
ControlStyle := ControlStyle + [csOpaque]
else
ControlStyle := ControlStyle - [csOpaque]
end;
procedure TVerticalScrollText.SetTransparent(Value: Boolean);
begin
if Value <> FTransparent then
begin
FTransParent := Value;
DoTransparent;
end;
end;
procedure TVerticalScrollText.SetInterval(Value: Integer);
begin
if FInterval <> Value then
begin
FInterval := Value;
SpTimer.Interval := Value;
end;
end;
procedure TVerticalScrollText.SetBgBitmap(Value: TBitmap);
begin
with FBgBmp do
begin
FreeImage;
Width := Value.Width;
Height := Value.Height;
Canvas.Draw(0, 0, Value);
end;
Inv;
end;
procedure TVerticalScrollText.SetEnabled(Value: Boolean);
begin
FEnabled := Value;
if FEnabled then
begin
PosY := Height;
SpTimer.Enabled := True;
end
else
begin
SpTimer.Enabled := False;
end;
end;
procedure TVerticalScrollText.SetAlign(Value: TAlign);
begin
FAlign := Value;
Inv;
end;
procedure TVerticalScrollText.SetStretch(Value: Boolean);
begin
FStretch := Value;
Inv;
end;
procedure TVerticalScrollText.OnTimer(Sender: TObject);
begin
if (PosY + LinePos) < 0 then
begin
if FRepeat then
PosY := Height
else
SpTimer.Enabled := False;
end;
Dec(PosY);
Paint;
end;
procedure TVerticalScrollText.Inv;
var
Aa: SmallInt;
begin
with TextBitmap do
begin
Canvas.Font := Self.Font;
Width := Self.Width;
Height := Canvas.TextHeight('Height') * FLines.Count;
if Self.Font.Color = clBlue then
begin
Canvas.Brush.Color := clGreen;
TransparentColor := clGreen;
end
else
begin
Canvas.Brush.Color := clBlue;
TransparentColor := clBlue;
end;
if FTransparent then
begin
Canvas.Brush.Style := bsClear;
end;
Canvas.FillRect(Rect(0, 0, Width, Height));
LinePos := 0;
for Aa := 1 to FLines.Count do
begin
if FAlign = alLeft then
PosX := 0;
if FAlign = alRight then
PosX := Width - Canvas.TextWidth(FLines[Aa - 1 ]);
if FAlign = alCenter then
PosX := Round((Width - Canvas.TextWidth(FLines[Aa - 1])) / 2);
Canvas.TextOut(PosX, LinePos, FLines[Aa - 1]);
LinePos := LinePos + Canvas.TextHeight('Text');
end;
end;
with BgBitmap do
begin
Width := Self.Width;
Height := Self.Height;
FreeImage;
Canvas.FillRect(Rect(0, 0, Width, Height));
if FStretch then
Canvas.StretchDraw(Rect(0, 0, Width, Height), FBgBmp)
else
Canvas.Draw(0, 0, FBgBmp);
if FTransparent then
begin
Canvas.Brush.Style := bsClear;
end;
end;
with CopyBitmap do
begin
Width := Self.Width;
Height := Self.Height;
if FTransparent then
begin
Canvas.Brush.Style := bsClear;
end;
end;
if Parent <> nil then
Paint;
end;
procedure TVerticalScrollText.Paint;
begin
inherited;
BitBlt(CopyBitmap.Canvas.Handle, 0, 0, Width, Height, BgBitmap.Canvas.Handle, 0, 0, SrcCopy);
CopyBitmap.Canvas.Draw(0, PosY, TextBitmap);
BitBlt(Canvas.Handle, 0, 0, Width, Height, CopyBitmap.Canvas.Handle, 0, 0, SrcCopy);
end;
procedure TVerticalScrollText.Resize;
begin
inherited;
Inv;
end;
end.
//Kompliere fint i Delphi 7
