//鼠标移入开始淡入
procedure TAALinkLabel.CMMouseEnter(var Message: TMessage);
begin
if Enabled then
begin
FMouseIn := True;
DrawMem;
DrawHot;
if HotLink.Fade then
begin
FadeStyle := fsIn;
end else
Progress := csMaxProgress;
end;
inherited;
end;
//鼠标称出开始淡出
procedure TAALinkLabel.CMMouseLeave(var Message: TMessage);
begin
if Enabled then
begin
if HotLink.Fade then
begin
FadeStyle := fsOut;
end else
Progress := 0;
FMouseIn := False;
end;
inherited;
end;
//点击控件
procedure TAALinkLabel.Click;
var
Wnd: THandle;
begin
if HotLink.URL <> EmptyStr then
begin
if Parent is TForm then
Wnd := Parent.Handle
else
Wnd := 0; //NULL;
ShellExecute(Wnd, nil, PChar(HotLink.URL), nil, nil, SW_SHOWNORMAL);
end;
inherited;
end;
//属性已装载
procedure TAALinkLabel.LoadedEx;
begin
inherited;
Reset;
end;
//设置淡入淡出进度
procedure TAALinkLabel.SetProgress(const Value: TProgress);
begin
if FProgress <> Value then
begin
FProgress := Value;
Blend(BlendBmp, MemBmp, HotBmp, Progress);
Paint;
end;
end;
//设置启用
procedure TAALinkLabel.SetEnabled(Value: Boolean);
begin
inherited;
if not Value then
begin
FadeStyle := fsNone;
Progress := 0;
end;
end;
//设置淡入淡出
procedure TAALinkLabel.SetFadeStyle(const Value: TFadeStyle);
begin
if FFadeStyle <> Value then
begin
FFadeStyle := Value;
FadeTimer.Enabled := FFadeStyle <> fsNone;
end;
end;
//设置链接参数
procedure TAALinkLabel.SetHotLink(const Value: THotLink);
begin
FHotLink.Assign(Value);
end;
//调整尺寸
procedure TAAText.CalcSize;
var
i, j: Integer;
DispLines: TStrings;
WrapLines: TStrings;
CurrText: string;
CurrAlign: TAlignment;
TextWidth: Integer;
TextHeight: Integer;
AWidth, AHeight: Integer;
xFree, yFree: Boolean;
MaxCol: Integer;
begin
BeginUpdate;
DispLines := nil;
WrapLines := nil;
try
DispLines := TStringList.Create; //临时文本
WrapLines := TStringList.Create;
with FText do
begin
xFree := not WordWrap and AutoSize and (Align in [alNone, alLeft, alRight]);
yFree := AutoSize and (Align in [alNone, alTop, alBottom]);
if xFree then AWidth := 0
else AWidth := ClientWidth;
if yFree then AHeight := 0
else AHeight := ClientHeight;
if xFree or yFree then
begin
DispLines.Clear;
DispLines.AddStrings(Lines);
AAFont.Canvas := Canvas;
AAFont.Effect.Assign(FText.FontEffect);
Canvas.Font.Assign(Font);
for i := 0 to DispLines.Count - 1 do
begin
CurrText := DispLines; //当前处理字符串
if LabelEffect = leOnlyALine then
begin
Canvas.Font.Assign(Font);
AAFont.Effect.Assign(FText.FontEffect);
end;
Fonts.Check(CurrText, Canvas.Font, AAFont.Effect); //检查字体标签
Labels.Check(CurrText, CurrAlign); //检查用户标签
TextWidth := AAFont.TextWidth(CurrText);
if WordWrap and (TextWidth > AWidth) then //自动换行
begin
MaxCol := AWidth * Length(CurrText) div TextWidth;
while AAFont.TextWidth(Copy(CurrText, 1, MaxCol)) > AWidth do
Dec(MaxCol);
WrapText(CurrText, WrapLines, MaxCol);
end else if CurrText <> '' then
WrapLines.Text := CurrText
else
WrapLines.Text := ' ';
if xFree and (TextWidth > AWidth) then //确定宽度
begin
AWidth := TextWidth;
end;
if yFree then //确定高度
begin
for j := 0 to WrapLines.Count - 1 do
begin
CurrText := WrapLines[j];
TextHeight := AAFont.TextHeight(CurrText + ' ');
Inc(AHeight, TextHeight);
if (i < DispLines.Count - 1) or (j < WrapLines.Count - 1) then
Inc(AHeight, Round(TextHeight * RowPitch / 100));
end;
end;
end;
if xFree then ClientWidth := AWidth + 2 * Border;
if yFree then ClientHeight := AHeight + 2 * Border;
end;
end;
finally
DispLines.Free;
WrapLines.Free;
EndUpdate;
end;
end;
//创建显示文本
procedure TAAText.CreateText;
begin
CalcSize;
TextBmp.Canvas.Brush.Color := Color;
TextBmp.Canvas.Brush.Style := bsSolid;
TextBmp.Width := ClientWidth;
TextBmp.Height := ClientHeight;
if FText.Transparent then //透明
begin
CopyParentImage(TextBmp.Canvas); //复制父控件画布
end else if not FText.IsBackEmpty then
begin //绘制背景图
DrawBackGround(TextBmp.Canvas, Rect(0, 0, TextBmp.Width, TextBmp.Height),
FText.BackGround.Graphic, FText.BackGroundMode);
end else
begin //填充背景色
TextBmp.Canvas.FillRect(ClientRect);
end;
TextBmp.Canvas.Brush.Style := bsClear;
DrawCanvas(TextBmp.Canvas);
end;
//释放
destructor TAAText.Destroy;
begin
TextBmp.Free;
FText.Free;
inherited;
end;
//绘制
procedure TAAText.DrawCanvas(ACanvas: TCanvas);
var
i, j: Integer;
DispLines: TStrings;
WrapLines: TStrings;
CurrText: string;
CurrAlign: TAlignment;
x, y: Integer;
TextWidth: Integer;
TextHeight: Integer;
MaxCol: Integer;
begin
BeginUpdate;
DispLines := nil;
WrapLines := nil;
try
DispLines := TStringList.Create; //临时文本
WrapLines := TStringList.Create;
with FText do
begin
DispLines.AddStrings(Lines);
ACanvas.Brush.Color := Color;
ACanvas.Brush.Style := bsClear;
ACanvas.Font.Assign(Font);
AAFont.Canvas := ACanvas;
AAFont.Effect.Assign(FText.FontEffect);
CurrAlign := Alignment; //默认对齐方式
y := Border;
for i := 0 to DispLines.Count - 1 do
begin
if y > ClientHeight - Border then
Break;
CurrText := DispLines; //当前处理字符串
if LabelEffect = leOnlyALine then
begin
ACanvas.Font.Assign(Font);
AAFont.Effect.Assign(FText.FontEffect);
CurrAlign := Alignment;
end;
Fonts.Check(CurrText, ACanvas.Font, AAFont.Effect); //检查字体标签
Labels.Check(CurrText, CurrAlign); //检查用户标签
TextWidth := AAFont.TextWidth(CurrText);
if WordWrap and (TextWidth > ClientWidth - 2 * Border) then //自动换行
begin
MaxCol := (ClientWidth - 2 * Border) * Length(CurrText) div TextWidth;
while AAFont.TextWidth(Copy(CurrText, 1, MaxCol)) > ClientWidth - 2
* Border do
Dec(MaxCol);
WrapText(CurrText, WrapLines, MaxCol);
end else if CurrText <> '' then
WrapLines.Text := CurrText
else
WrapLines.Text := ' ';
for j := 0 to WrapLines.Count - 1 do
begin
CurrText := WrapLines[j];
TextHeight := AAFont.TextHeight(CurrText + ' ');
TextWidth := AAFont.TextWidth(CurrText);
case CurrAlign of //对齐方式
taLeftJustify: x := Border;
taCenter: x := (ClientWidth - TextWidth) div 2;
taRightJustify: x := ClientWidth - Border - TextWidth;
else x := 0;
end;
AAFont.TextOut(x, y, CurrText);
y := y + Round(TextHeight * (1 + RowPitch / 100));
end;
end;
AAFont.Effect.Assign(FText.FontEffect);
end;
finally
DispLines.Free;
WrapLines.Free;
EndUpdate;
end;
end;
//控件属性已装载
procedure TAAText.LoadedEx;
begin
inherited;
Reset;
end;
//绘制画布
procedure TAAText.PaintCanvas;
begin
if Text.Transparent then
TransparentPaint //透明
else
Bitblt(Canvas.Handle, 0, 0, Width, Height, TextBmp.Canvas.Handle, 0, 0,
SRCCOPY);
end;
//复位
procedure TAAText.Reset;
begin
if not Text.Transparent then
CreateText;
inherited;
end;
//设置文本
procedure TAAText.SetText(const Value: TTextParam);
begin
Text.Assign(Value);
end;
//透明绘制
procedure TAAText.TransparentPaint;
begin
CalcSize;
DrawCanvas(Canvas);
end;
//默认文本创建默认标签
function TAAText.UseDefaultLabels: Boolean;
begin
Result := not FText.IsLinesStored;
end;
//透明混合
procedure DrawFade(y: Integer; Transparency: Integer);
const
MaxPixelCount = 32768;
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..MaxPixelCount] of TRGBTriple;
var
Row: PRGBTripleArray;
x: Integer;
begin
Row := CurrBmp.ScanLine[y];
for x := 0 to CurrBmp.Width - 1 do
begin
if Row[x].rgbtRed <> BkRed then
Row[x].rgbtRed := Transparency * (Row[X].rgbtRed - BkRed) shr 8 + BkRed;
if Row[x].rgbtGreen <> BkGreen then
Row[x].rgbtGreen := Transparency * (Row[X].rgbtGreen - BkGreen) shr 8 + BkGreen;
if Row[x].rgbtBlue <> BkBlue then
Row[x].rgbtBlue := Transparency * (Row[X].rgbtBlue - BkBlue) shr 8 + BkBlue;
end;
end;
procedure DrawFade1(y: Integer; Transparency: Integer);
const
MaxPixelCount = 32768;
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..MaxPixelCount] of TRGBTriple;
var
Row: PRGBTripleArray;
x: Integer;
begin
Row := CurrBmp.ScanLine[y];
for x := 0 to FText.FadeHeight do
begin
if Row[x].rgbtRed <> BkRed then
Row[x].rgbtRed := Transparency * (Row[X].rgbtRed - BkRed) shr 8 + BkRed;
if Row[x].rgbtGreen <> BkGreen then
Row[x].rgbtGreen := Transparency * (Row[X].rgbtGreen - BkGreen) shr 8 + BkGreen;
if Row[x].rgbtBlue <> BkBlue then
Row[x].rgbtBlue := Transparency * (Row[X].rgbtBlue - BkBlue) shr 8 + BkBlue;
if Row[width-x].rgbtRed <> BkRed then
Row[width-x].rgbtRed := Transparency * (Row[width-x].rgbtRed - BkRed) shr 8 + BkRed;
if Row[width-x].rgbtGreen <> BkGreen then
Row[width-x].rgbtGreen := Transparency * (Row[width-x].rgbtGreen - BkGreen) shr 8 + BkGreen;
if Row[width-x].rgbtBlue <> BkBlue then
Row[width-x].rgbtBlue := Transparency * (Row[width-x].rgbtBlue - BkBlue) shr 8 + BkBlue;
end;
end;
begin
CurrBmp.Height := Height;
CurrBmp.Width := Width;
//绘制到控件画布
if FUpMode then
begin
if FCurrPos + Height <= TextBmp.Height then //完整显示
BitBlt(CurrBmp.Canvas.Handle, 0, 0, Width, Height, TextBmp.Canvas.Handle, 0,
FCurrPos, SRCCopy)
else
begin //首尾相接
BitBlt(CurrBmp.Canvas.Handle, 0, 0, Width, TextBmp.Height - FCurrPos,
TextBmp.Canvas.Handle, 0, FCurrPos, SRCCopy);
BitBlt(CurrBmp.Canvas.Handle, 0, TextBmp.Height - FCurrPos, Width, Height -
(TextBmp.Height - FCurrPos), TextBmp.Canvas.Handle, 0, 0, SRCCopy);
end;
if FText.Fade then //淡入淡出
begin
tBkColor := ColorToRGB(Color);
BkRed := GetRValue(tBkColor);
BkGreen := GetGValue(tBkColor);
BkBlue := GetBValue(tBkColor);
for i := 0 to FText.FadeHeight - 1 do
begin
DrawFade(i, 255 * i div (FText.FadeHeight - 1));
DrawFade(Height - 1 - i, 255 * i div (FText.FadeHeight - 1));
end;
end;
end else
begin
if FCurrPos + Width <= TextBmp.Width then //完整显示
BitBlt(CurrBmp.Canvas.Handle, 0, 0, Width, Height, TextBmp.Canvas.Handle,FCurrPos,0, SRCCopy)
else
begin //首尾相接
BitBlt(CurrBmp.Canvas.Handle, 0, 0, TextBmp.Width - FCurrPos,Height,
TextBmp.Canvas.Handle, FCurrPos,0, SRCCopy);
BitBlt(CurrBmp.Canvas.Handle, TextBmp.Width - FCurrPos,0, Width -
(TextBmp.Width - FCurrPos),Height, TextBmp.Canvas.Handle, 0, 0, SRCCopy);
end;
if FText.Fade then //淡入淡出
begin
tBkColor := ColorToRGB(Color);
BkRed := GetRValue(tBkColor);
BkGreen := GetGValue(tBkColor);
BkBlue := GetBValue(tBkColor);
for i := 0 to Height - 1 do
begin
DrawFade1(i, 255 * i div (Height - 1));
//DrawFade1(Height - 1 - i, 255 * i div (FText.FadeHeight - 1));
end;
end;
end;
CurrBmp.Transparent:=FTransparent;// Chw 2006
CurrBmp.TransparentColor:=Color; //chw 2006
CurrBmp.TransparentMode:=tmauto; //chw 2006
//绘制到控件画布
if not (csDestroying in ComponentState) then
if FTransparent then self.Canvas.Draw(0,0,CurrBmp)else //chw 2006
BitBlt(Canvas.Handle, 0, 0, Width, Height, CurrBmp.Canvas.Handle, 0, 0, SRCCopy); //chw 2006
// BitBlt(Canvas.Handle, 0, 0, Width, Height, CurrBmp.Canvas.Handle, 0, 0, SRCCopy); //chw 2006
if Assigned(OnPainted) then
OnPainted(Self);
end;
//执行滚动
procedure TAAScrollText.OnScrollTimer(Sender: TObject);
begin
if CurrPos = 0 then //单次滚动完成
begin
FRepeatedCount := FRepeatedCount + 1;
if (RepeatCount > 0) and (RepeatedCount >= RepeatCount) then
begin //滚动完成
Active := False;
FRepeatedCount := -1;
if Assigned(OnComplete) then
OnComplete(Self);
Exit;
end else if DelayTimer.Interval > 0 then
begin //循环延时
ScrollTimer.Enabled := False;
DelayTimer.Enabled := True;
Exit;
end;
end; //chw 2006
if FUpMode then
begin
if (FScrollStep > 0) and (CurrPos + FScrollStep >= TextBmp.Height) then
CurrPos := 0
else if (FScrollStep < 0) and (CurrPos + FScrollStep < 0) then
CurrPos := 0
else
CurrPos := CurrPos + FScrollStep; //当前位置增加
end else
begin
if (FScrollStep > 0) and (CurrPos + FScrollStep >= TextBmp.Width) then
CurrPos := 0
else if (FScrollStep < 0) and (CurrPos + FScrollStep < 0) then
CurrPos := 0
else
CurrPos := CurrPos + FScrollStep; //当前位置增加
end;
end;
//创建文本位图
procedure TAAScrollText.CreateText;
var
i, j: Integer;
DispLines: TStrings;
CurrText: string;
WrapLines: TStrings;
CurrHeight: Integer;
CurrAlign: TAlignment;
x, y: Integer;
TextWidth: Integer;
TextHeight: Integer;
MaxCol: Integer;
begin
BeginUpdate;
DispLines := nil;
WrapLines := nil;
try
DispLines := TStringList.Create; //临时文本
WrapLines := TStringList.Create;
//-------------------------------------------
if FUpMode then
begin
with FText do
begin
TextBmp.Height := 0;
TextBmp.Width := Width;
TextBmp.Canvas.Brush.Color := Color;
TextBmp.Canvas.Brush.Style := bsSolid;
DispLines.Clear;
DispLines.AddStrings(Lines);
AAFont.Canvas := TextBmp.Canvas;
AAFont.Effect.Assign(FText.FontEffect);
if Fade then //淡入淡出空白
CurrHeight := FadeHeight
else
CurrHeight := 0;
CurrHeight := CurrHeight + Height * HeadSpace div 100; //头部空白
TextBmp.Canvas.Font.Assign(Font);
for i := 0 to DispLines.Count - 1 do
begin
CurrText := DispLines; //当前处理字符串
if LabelEffect = leOnlyALine then
begin
TextBmp.Canvas.Font.Assign(Font);
AAFont.Effect.Assign(FText.FontEffect);
end;
Fonts.Check(CurrText, TextBmp.Canvas.Font, AAFont.Effect); //检查字体标签
Labels.Check(CurrText, CurrAlign); //检查用户标签
TextHeight := AAFont.TextHeight(CurrText + ' ');
TextWidth := AAFont.TextWidth(CurrText);
if WordWrap and (TextWidth > Width) then //自动换行
begin
MaxCol := Width * Length(CurrText) div TextWidth;
while AAFont.TextWidth(Copy(CurrText, 1, MaxCol)) > Width do
Dec(MaxCol);
WrapText(CurrText, WrapLines, MaxCol);
end else if CurrText <> '' then
WrapLines.Text := CurrText
else
WrapLines.Text := ' ';
CurrHeight := CurrHeight + Round(TextHeight * (1 + RowPitch / 100)) *
WrapLines.Count;
end;
TextBmp.Canvas.Brush.Color := Color;
TextBmp.Canvas.Brush.Style := bsSolid;
CurrHeight := CurrHeight + Height * TailSpace div 100; //尾部空白
if CurrHeight < ClientHeight then
CurrHeight := ClientHeight;
TextBmp.Height := CurrHeight;
if Assigned(FText.BackGround.Graphic) and not
FText.BackGround.Graphic.Empty then
DrawBackGround(TextBmp.Canvas, Rect(0, 0, TextBmp.Width,
TextBmp.Height), FText.BackGround.Graphic, FText.BackGroundMode);
DispLines.Clear;
DispLines.AddStrings(Lines);
TextBmp.Canvas.Brush.Style := bsClear;
AAFont.Effect.Assign(FText.FontEffect);
if Fade then //淡入淡出空白
CurrHeight := FadeHeight
else
CurrHeight := 0;
CurrHeight := CurrHeight + Height * HeadSpace div 100; //头部空白
TextBmp.Canvas.Font.Assign(Font);
CurrAlign := Alignment; //默认对齐方式
for i := 0 to DispLines.Count - 1 do
begin
CurrText := DispLines; //当前处理字符串
if LabelEffect = leOnlyALine then
begin
TextBmp.Canvas.Font.Assign(Font);
AAFont.Effect.Assign(FText.FontEffect);
CurrAlign := Alignment;
end;
Fonts.Check(CurrText, TextBmp.Canvas.Font, AAFont.Effect); //检查字体标签
Labels.Check(CurrText, CurrAlign); //检查用户标签
TextWidth := AAFont.TextWidth(CurrText);
if WordWrap and (TextWidth > Width) then //自动换行
begin
MaxCol := Width * Length(CurrText) div TextWidth;
while AAFont.TextWidth(Copy(CurrText, 1, MaxCol)) > Width do
Dec(MaxCol);
WrapText(CurrText, WrapLines, MaxCol);
end else if CurrText <> '' then
WrapLines.Text := CurrText
else
WrapLines.Text := ' ';
for j := 0 to WrapLines.Count - 1 do
begin
CurrText := WrapLines[j];
TextHeight := AAFont.TextHeight(CurrText + ' ');
TextWidth := AAFont.TextWidth(CurrText);
case CurrAlign of //对齐方式
taLeftJustify: x := 0;
taCenter: x := (TextBmp.Width - TextWidth) div 2;
taRightJustify: x := TextBmp.Width - TextWidth;
else x := 0;
end;
y := CurrHeight; //行间距
AAFont.TextOut(x, y, CurrText);
CurrHeight := CurrHeight + Round(TextHeight * (1 + RowPitch / 100));
end;
end;
if Assigned(OnTextReady) then //调用OnTextReady事件
OnTextReady(Self);
end;
end else
begin
//--------------------------------------------
with FText do
begin
TextBmp.Height := Height; //chw
TextBmp.Width := 0; //chw
TextBmp.Canvas.Brush.Color := Color;
TextBmp.Canvas.Brush.Style := bsSolid;
DispLines.Clear;
DispLines.AddStrings(Lines);
for i:=0 to Lines.Count-1 do
DispLines[0]:=DispLines[0]+Lines;
AAFont.Canvas := TextBmp.Canvas;
AAFont.Effect.Assign(FText.FontEffect);
if Fade then //淡入淡出空白
CurrHeight := FadeHeight
else
CurrHeight := 0;
CurrHeight := CurrHeight + Width * HeadSpace div 100; //头部空白 chw
TextBmp.Canvas.Font.Assign(Font);
CurrText := DispLines[0]; //当前处理字符串
if LabelEffect = leOnlyALine then
begin
TextBmp.Canvas.Font.Assign(Font);
AAFont.Effect.Assign(FText.FontEffect);
end;
Fonts.Check(CurrText, TextBmp.Canvas.Font, AAFont.Effect); //检查字体标签
Labels.Check(CurrText, CurrAlign); //检查用户标签
TextWidth := AAFont.TextWidth(CurrText);
TextHeight := AAFont.TextHeight(CurrText + ' '+'|');
CurrHeight := CurrHeight + TextWidth; //chw
//TextBmp.Canvas.Brush.Color := Color;
//TextBmp.Canvas.Brush.Style := bsSolid;
CurrHeight := CurrHeight + Width * TailSpace div 100; //尾部空白 chw
if CurrHeight < ClientWidth then
CurrHeight := ClientWidth;
TextBmp.Width := CurrHeight;
//TextBmp.Height:=TextHeight;
if Assigned(FText.BackGround.Graphic) and not
FText.BackGround.Graphic.Empty then
DrawBackGround(TextBmp.Canvas, Rect(0, 0, TextBmp.Width,
TextBmp.Height), FText.BackGround.Graphic, FText.BackGroundMode);
TextBmp.Canvas.Brush.Style := bsClear;
AAFont.Effect.Assign(FText.FontEffect);
if Fade then //淡入淡出空白
CurrHeight := FadeHeight
else
CurrHeight := 0;
CurrHeight := CurrHeight + Width * HeadSpace div 100; //头部空白
TextBmp.Canvas.Font.Assign(Font);
CurrAlign := Alignment; //默认对齐方式
case CurrAlign of //对齐方式
taLeftJustify: y := 0;
taCenter: y := (TextBmp.Height - TextHeight) div 2;
taRightJustify: y := TextBmp.Height - TextHeight;
else y := 0;
end;
x := CurrHeight; //行间距
AAFont.TextOut(x, y, CurrText);
end;
if Assigned(OnTextReady) then //调用OnTextReady事件
OnTextReady(Self);
end;
finally
WrapLines.Free;
DispLines.Free;
EndUpdate;
end;
end;
//设置活动
procedure TAAScrollText.SetActive(const Value: Boolean);
begin
if FActive <> Value then
begin
FActive := Value;
ScrollTimer.Enabled := FActive;
if not FActive then
DelayTimer.Enabled := False;
end;
end;
//设置透明
procedure TAAScrollText.SetTransparent(const Value: Boolean); //chw 2006
begin
if FTransparent <> Value then
begin
FTransparent := Value;
if FTransparent then
begin
self.Parent.DoubleBuffered:=true;
FText.SetFade(True);
end else
self.Parent.DoubleBuffered:=False;
end;
end;
//设置滚动方式
procedure TAAScrollText.SetUpMode(const Value: Boolean); //chw 2006
begin
if FUpMode <> Value then
begin
FUpMode := Value;
Changed;
end;
end;
//设置循环延时
procedure TAAScrollText.SetRepeatDelay(const Value: Word);
begin
if FRepeatDelay <> Value then
begin
FRepeatDelay := Value;
if FRepeatDelay <= 0 then
FRepeatDelay := 0;
DelayTimer.Interval := Value;
end;
end;
//设置滚动延时
procedure TAAScrollText.SetScrollDelay(const Value: Word);
begin
if FScrollDelay <> Value then
begin
FScrollDelay := Value;
if FScrollDelay <= 0 then
FScrollDelay := 0;
ScrollTimer.Interval := FScrollDelay;
end;
end;
//设置每次滚动增量
procedure TAAScrollText.SetScrollStep(const Value: Integer);
begin
if FScrollStep <> Value then
begin
FScrollStep := Value;
end;
end;
//设置循环次数
procedure TAAScrollText.SetRepeatCount(const Value: TBorderWidth);
begin
if FRepeatCount <> Value then
begin
FRepeatCount := Value;
if FRepeatCount <= 0 then
FRepeatCount := 0;
Changed;
end;
end;
//设置文本内容
procedure TAAScrollText.SetText(const Value: TScrollTextParam);
begin
FText.Assign(Value);
end;
//设置当前位置
procedure TAAScrollText.SetCurrPos(const Value: Integer);
begin
if FCurrPos <> Value then
begin
if UpMode then
begin
FCurrPos := Value mod TextBmp.Height;
if FCurrPos < 0 then
Inc(FCurrPos, TextBmp.Height);
end else
begin
FCurrPos := Value mod TextBmp.Width;
if FCurrPos < 0 then
Inc(FCurrPos, TextBmp.Width);
end;
if FTransparent then self.Invalidate else Paint; //CHW 2006 12
//Paint; //chw 2006 12
end;
end;
//大小变化消息
function TAAScrollText.CanResize(var NewWidth,
NewHeight: Integer): Boolean;
begin
if NewWidth < 20 then NewWidth := 20;
if NewHeight < 20 then NewHeight := 20;
Result := inherited CanResize(NewWidth, NewHeight);
end;
//循环延时
procedure TAAScrollText.OnDelayTimer(Sender: TObject);
begin
DelayTimer.Enabled := False;
CurrPos := CurrPos + FScrollStep;
if Active then
ScrollTimer.Enabled := True;
end;
//创建默认字体集
procedure TAAScrollText.CreateDefFonts;
var
FLabel: TFontLabel;
begin
inherited;
FLabel := Fonts.AddItem('Title4', '隶书', 22, clBlack, [fsBold], True, 2, 2);
if Assigned(FLabel) then
begin
FLabel.Effect.Gradual.Enabled := True;
FLabel.Effect.Gradual.Style := gsLeftToRight;
FLabel.Effect.Gradual.StartColor := $00FF2200;
FLabel.Effect.Gradual.EndColor := $002210FF;
FLabel.Effect.Outline := True;
FLabel.Effect.Blur := 50;
end;
FLabel := Fonts.AddItem('Text3', '隶书', 11, clBlue, [], True, 1, 1);
if Assigned(FLabel) then
begin
FLabel.Effect.Gradual.Enabled := True;
FLabel.Effect.Gradual.Style := gsTopToBottom;
FLabel.Effect.Gradual.StartColor := $00CC3311;
FLabel.Effect.Gradual.EndColor := $00FF22AA;
end;
end;
//默认文本创建默认标签
function TAAScrollText.UseDefaultLabels: Boolean;
begin
Result := not FText.IsLinesStored;
end;
//控件属性已装载
procedure TAAScrollText.LoadedEx;
begin
inherited;
Reset;
end;
//释放
destructor TScrollTextParam.Destroy;
begin
inherited;
end;
//设置淡入淡出
procedure TScrollTextParam.SetFade(const Value: Boolean);
begin
if FFade <> Value then
begin
FFade := Value;
Changed;
end;
end;
//设置淡入淡出高度
procedure TScrollTextParam.SetFadeHeight(const Value: Integer);
begin
if FFadeHeight <> Value then
begin
FFadeHeight := Value;
Changed;
end;
end;
//设置头部空白
procedure TScrollTextParam.SetHeadSpace(const Value: Integer);
begin
if FHeadSpace <> Value then
begin
FHeadSpace := Value;
if FHeadSpace < 0 then
FHeadSpace := 0;
if FHeadSpace > 150 then
FHeadSpace := 150;
Changed;
end;
end;
//设置尾部空白
procedure TScrollTextParam.SetTailSpace(const Value: Integer);
begin
if FTailSpace <> Value then
begin
FTailSpace := Value;
if FTailSpace < 0 then
FTailSpace := 0;
if FTailSpace > 150 then
FTailSpace := 150;
Changed;
end;
end;
//文本内容是否存储
function TScrollTextParam.IsLinesStored: Boolean;
begin
Result := Lines.Text <> csAAScrollTextCopyRight;
end;
//绘制渐隐图
procedure TAAFadeText.DrawFadeBmp(AText: string; Bmp: TBitmap);
var
OffPoint: TPoint;
th, tw: Integer;
begin
AAFont.Canvas := Bmp.Canvas;
if Text.LabelEffect = leOnlyALine then
begin
Bmp.Canvas.Font.Assign(Font);
AAFont.Effect.Assign(Text.FontEffect);
CurrAlign := Text.Alignment;
end;
Fonts.Check(AText, Bmp.Canvas.Font, AAFont.Effect); //检查字体标签
Labels.Check(AText, CurrAlign); //检查用户标签
th := AAFont.TextHeight(AText); //文本高度
tw := AAFont.TextWidth(AText); //文本宽度
case CurrAlign of //水平对齐方式
taLeftJustify: OffPoint.x := 0;
taRightJustify: OffPoint.x := ClientWidth - tw;
taCenter: OffPoint.x := (ClientWidth - tw) div 2;
end;
case Text.Layout of //垂直对齐方式
tlTop: OffPoint.y := 0;
tlCenter: OffPoint.y := (ClientHeight - th) div 2;
tlBottom: OffPoint.y := ClientHeight - th;
end;
Bmp.Height := ClientHeight;
Bmp.Width := ClientWidth;
Bmp.Canvas.Brush.Color := Color;
Bmp.Canvas.Brush.Style := bsSolid;
if Text.Transparent then //透明
begin
CopyParentImage(Bmp.Canvas); //复制父控件画布
end else if not Text.IsBackEmpty then
begin //绘制背景图
DrawBackGround(Bmp.Canvas, Rect(0, 0, Bmp.Width, Bmp.Height),
Text.BackGround.Graphic, Text.BackGroundMode);
end else
begin //填充背景色
Bmp.Canvas.FillRect(ClientRect);
end;
Bmp.Canvas.Brush.Style := bsClear;
AAFont.TextOut(OffPoint.x, OffPoint.y, AText); //平滑字体输出
end;
//渐隐到指定行
procedure TAAFadeText.FadeTo(Line: Integer);
begin
if Text.Lines.Count <= 0 then
Exit;
if Line < 0 then
Line := 0;
if Line > Text.Lines.Count - 1 then
begin
Line := 0;
Inc(FRepeatedCount);
if (FRepeatCount > 0) and (FRepeatedCount >= FRepeatCount) then
begin
Active := False;
FRepeatedCount := 0;
FLineIndex := -1;
FadeToStr('');
if Assigned(OnComplete) then
OnComplete(Self);
Exit;
end;
end;
FadeToStr(Text.Lines[Line]);
FLineIndex := Line;
end;
//渐隐到下一行
procedure TAAFadeText.FadeToNext;
begin
FadeTo(LineIndex + 1);
end;
//渐隐到指定文本
procedure TAAFadeText.FadeToStr(AText: string);
begin
OutBmp.Assign(TextBmp);
DrawFadeBmp(AText, InBmp);
LastText := CurrText;
CurrText := AText;
FFadeProgress := 0;
FadeTimer.Enabled := False;
FadeTimer.Enabled := True;
if DelayTimer.Enabled then
begin
DelayTimer.Enabled := False;
DelayTimer.Enabled := True;
end;
end;
//属性已装载
procedure TAAFadeText.LoadedEx;
begin
inherited;
CurrAlign := Text.Alignment;
Reset;
FRepeatedCount := 0;
DelayTimer.Enabled := FActive;
if FActive then
OnDelayTimer(Self);
end;
//渐隐切换文本定时事件
procedure TAAFadeText.OnDelayTimer(Sender: TObject);
begin
FadeToNext;
end;
//渐隐过程定时事件
procedure TAAFadeText.OnFadeTimer(Sender: TObject);
begin
if Abs(NewProg - FadeProgress) > 1 then
NewProg := FadeProgress;
NewProg := NewProg + csMaxProgress * FadeTimer.Interval div Text.FadeDelay;
if NewProg > csMaxProgress then
begin
NewProg := csMaxProgress;
FadeTimer.Enabled := False;
end;
FadeProgress := Round(NewProg);
end;
//绘制控件画布
procedure TAAFadeText.PaintCanvas;
begin
inherited;
if Text.Transparent then
begin //透明且完整重绘
if FadeProgress = 0 then
DrawFadeBmp(CurrText, TextBmp)
else begin
DrawFadeBmp(LastText, OutBmp);
DrawFadeBmp(CurrText, InBmp);
end;
end;
if FadeProgress <> 0 then //渐隐中
Blend(TextBmp, OutBmp, InBmp, FFadeProgress);
Bitblt(Canvas.Handle, 0, 0, Width, Height, TextBmp.Canvas.Handle, 0, 0,
SRCCOPY);
if Assigned(OnPainted) then
OnPainted(Self);
end;
//更新显示
procedure TAAFadeText.Reset;
begin
if FadeProgress = 0 then
DrawFadeBmp(CurrText, TextBmp)
else begin
DrawFadeBmp(LastText, OutBmp);
DrawFadeBmp(CurrText, InBmp);
Blend(TextBmp, OutBmp, InBmp, FFadeProgress);
end;
inherited;
end;
//设置活跃
procedure TAAFadeText.SetActive(const Value: Boolean);
begin
if FActive <> Value then
begin
FActive := Value;
DelayTimer.Enabled := FActive;
if FActive then
begin
FRepeatedCount := 0;
OnDelayTimer(Self);
end;
end;
end;
//设置渐隐进程
procedure TAAFadeText.SetFadeProgress(const Value: TProgress);
begin
if FFadeProgress <> Value then
begin
FFadeProgress := Value;
Paint;
end;
end;
//设置当前行
procedure TAAFadeText.SetLineIndex(const Value: Integer);
begin
if FLineIndex <> Value then
begin
FadeTo(FLineIndex);
end;
end;
//设置总循环次数
procedure TAAFadeText.SetRepeatCount(const Value: TBorderWidth);
begin
if FRepeatCount <> Value then
begin
FRepeatCount := Value;
if FRepeatedCount >= FRepeatCount then
end;
end;
//设置文本
procedure TAAFadeText.SetText(const Value: TFadeTextParam);
begin
FText.Assign(Value);
end;
//是默认文本时创建默认标签
function TAAFadeText.UseDefaultLabels: Boolean;
begin
Result := not FText.IsLinesStored;
end;
//赋值
procedure TFadeTextParam.Assign(Source: TPersistent);
begin
inherited;
if Source is TFadeTextParam then
begin
FFadeDelay := TFadeTextParam(Source).FadeDelay;
LineDelay := TFadeTextParam(Source).LineDelay;
end;
end;
//释放
destructor TFadeTextParam.Destroy;
begin
inherited;
end;
//取行延时
function TFadeTextParam.GetLineDelay: Cardinal;
begin
Result := TAAFadeText(Owner).DelayTimer.Interval;
end;
// 取图像高度
function TAAScrollText.GetBmpHeight: Integer;
begin
Result := TextBmp.Height;
end;
//存储文本
function TFadeTextParam.IsLinesStored: Boolean;
begin
Result := Lines.Text <> csAAFadeTextCopyRight;
end;
//设置渐隐延时
procedure TFadeTextParam.SetFadeDelay(const Value: Cardinal);
begin
if FFadeDelay <> Value then
begin
FFadeDelay := Value;
if FFadeDelay > LineDelay - 200 then
FFadeDelay := LineDelay - 200;
if FFadeDelay < 50 then
FFadeDelay := 50;
end;
end;
//设置行延时
procedure TFadeTextParam.SetLineDelay(const Value: Cardinal);
var
T: Cardinal;
begin
T := Value;
if T < FFadeDelay + 200 then
T := FFadeDelay + 200;
TAAFadeText(Owner).DelayTimer.Interval := T;
end;
end.
[ Last edited by chw74 on 2006-12-16 at 11:24 ]Author:
chw74 Time: 2006-12-16 11:30 Subject: 经过在家编译测试,觉得不会消耗掉整个内存,增加到一定大小就稳定不变了!
看看我在其它程序中用的自动换行!!!!!!!!!!!!!!!!!!!
var
sCuted{ 按固定长度分割出来的部分字符串 }: string;
iCutLength{ 按固定长度分割出来的部分字符串的长度 }: integer;
--------------------
while FBmp.Canvas.TextWidth(sCuted)>self.Width do
begin
dec(iCutLength);
sCuted := Copy(s, 1, iCutLength);
end;
if bytetype(s, iCutLength) = mbLeadByte then
sline := _CutString(iCutLength-1, s)
else sline := _CutString(iCutLength, s);
k:=FBmp.Canvas.TextWidth(s);
----------------
function TScrollText._CutString(Len: integer; var S: string): string;
var
T: string;
j: integer;
begin
Result := '';
if Len >= length(S) then exit;
T := System.Copy(S, 1, Len);
j := length(T);
{ while j > 1 do
if T[j] = #32 then break
else dec(j);
if j = 1 then j := Len; }
Result := System.Copy(S, j + 1, length(S));
S := System.Copy(S, 1, j);
end;Author:
Passion Time: 2006-12-21 16:56
