我想在透明的panel里滚动文本! 主要是想透明滚动,看到下面的控件! 怎样实现! VCL组件开发及应用http://www.delphi2007.net/DelphiVCL/html/delphi_20061222152202184.html
我想在透明的panel里滚动文本! 主要是想透明滚动,看到下面的控件! 怎样实现!
编码如下!但是有文本重叠显示成一片红的问题.请高手帮忙修改!
unit Glass;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
type
TGlassStyle = (
gsBlackness, gsDstInvert, gsMergeCopy, gsMergePaint, gsNotSrcCopy,
gsNotSrcErase, gsPatCopy, gsPatInvert, gsPatPaint, gsSrcAnd,
gsSrcCopy, gsSrcErase, gsSrcInvert, gsSrcPaint, gsWhiteness);
TGlass = class(TCustomControl)
private
FLines:TStringList;
FScrollDelay:integer;
FLoop:integer;
FRowSpacing:integer;
FBgColor:TColor;
FFont:TFont;
Timer:TTimer;
FPos,I,K,LineH,j:integer;
//-------------------------------
FMode,FTransparent:Boolean;
Fbmp1,FBgbmp:Tbitmap;
sLine,s:string;
//-------------------
FBmp:TBitmap;
FActive:Boolean;
FColor: TColor;
FStyle: TGlassStyle;
FOnPaint: TNotifyEvent;
procedure SetLines(Value:TStringList);
procedure SetFont(Value:TFont);
function GetLines:TStringList;
function GetFont:TFont;
function GetLoop:integer;
procedure Init;
procedure SetLoop(Value:Integer);
procedure SetBgbmp(Value:Tbitmap);
procedure TimerProc(Sender:Tobject);
procedure SetScrollDelay(Value:Integer);
procedure SetActive(Value:boolean);
procedure ReadandWritetext;
function _CutString(Len: integer; var S: string): string;
procedure CPaint;
//-----------------------
procedure SetColor(Value: TColor);
procedure SetStyle(Value: TGlassStyle);
procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
// procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
protected
Buffer: TBitmap;
procedure CreateParams(var Params: TCreateParams); override;
procedure Paint; override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// procedure invalidate;override;
property Canvas;
published
property Lines:TStringList read GetLines Write SetLines;
property ScrollDelay:integer read FScrollDelay write SetScrollDelay default 10;
property Bgbmp:Tbitmap read FBgbmp write SetBgbmp;
property Font:TFont read GetFont write SetFont;
property Active:boolean read FActive write SetActive;
property UPMode:Boolean read FMode write FMode;
property Transparent:Boolean read FTransparent write FTransparent;
property Loop:integer read GetLoop write SetLoop;
property RowSpacing:integer read FRowSpacing write FRowSpacing;
//------------------------
property Align;
property Anchors;
property AutoSize;
property BiDiMode;
property BorderWidth;
property Color: TColor read FColor write SetColor;
property Ctl3D;
property Enabled;
property Style: TGlassStyle read FStyle write SetStyle default gsSrcAnd;
property Visible;
property OnClick;
property OnDblClick;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Delphi Area', [TGlass]);
end;
function GlassStyleToInt(gs: TGlassStyle): LongInt;
begin
case gs of
gsBlackness : Result := cmBlackness;
gsDstInvert : Result := cmDstInvert;
gsMergeCopy : Result := cmMergeCopy;
gsMergePaint : Result := cmMergePaint;
gsNotSrcCopy : Result := cmNotSrcCopy;
gsNotSrcErase: Result := cmNotSrcErase;
gsPatCopy : Result := cmPatCopy;
gsPatInvert : Result := cmPatInvert;
gsPatPaint : Result := cmPatPaint;
gsSrcAnd : Result := cmSrcAnd;
gsSrcCopy : Result := cmSrcCopy;
gsSrcErase : Result := cmSrcErase;
gsSrcInvert : Result := cmSrcInvert;
gsSrcPaint : Result := cmSrcPaint;
gsWhiteness : Result := cmWhiteness;
else Assert(True, 'Error parameter in function GlassStyleToInt');
end;
end;
constructor TGlass.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFont:=TFont.Create;
FLines:=TStringList.Create;
Timer:=TTimer.Create(Self);
Timer.Interval:=10;
FScrollDelay:=10;
Timer.Enabled:=false;
Timer.OnTimer:=TimerProc;
FBmp:=TBitmap.Create;
Fbmp1:=Tbitmap.Create;
FBgbmp:=Tbitmap.Create;
FBgColor:=clBlack;
//-------------------
Buffer := TBitmap.Create;
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csDoubleClicks, csReplicatable];
Width := 100;
Height := 100;
FStyle := gsSrcAnd;
ParentCtl3d := False;
Ctl3D := False;
ParentColor := False;
FColor := clWhite;
end;
destructor TGlass.Destroy;
begin
FFont.Free;
FLines.Free;
Timer.Free;
FBmp.Free;
Fbmp1.Free;
FBgbmp.free;
//---- ------------------------
Buffer.Free;
inherited Destroy;
end;
procedure TGlass.Paint;
var
R: TRect;
rop: LongInt;
begin
R := Rect(0, 0, Width, Height);
Buffer.Width := Width;
Buffer.Height := Height;
Buffer.Canvas.Brush.Style := bsClear;
Buffer.Canvas.Brush.Color := FColor;
// Buffer.Canvas.FillRect(Rect(0, 0, Width, Height));
rop := GlassStyleToInt(FStyle);
//StretchBlt(Buffer.Canvas.Handle, 0, 0, Width, Height,
// Canvas.Handle, 0, 0, Width, Height, rop);
if Ctl3D then DrawEdge(Buffer.Canvas.Handle, R, BDR_RAISEDINNER, BF_RECT);
// Buffer.Canvas.Pen.Mode := pmCopy;
// Buffer.Canvas.Pen.Style := psSolid;
Buffer.Transparent:=FTransparent;
Buffer.TransparentColor:=FColor;
Buffer.TransparentMode:=tmAuto;
Canvas.Draw(0, 0, Buffer);
if Assigned(FOnPaint) then FOnPaint(Self);
end;
procedure TGlass.SetColor(Value: TColor);
begin
if Value <> FColor then
begin
FColor := Value;
RecreateWnd;
end;
end;
procedure TGlass.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
end;
procedure TGlass.WMWindowPosChanging(var Message: TWMWindowPosChanging);
begin
Invalidate;
inherited;
end;
procedure TGlass.WMEraseBkgnd(var Message: TMessage);
begin
Message.Result := 0;
end;
procedure TGlass.Resize;
begin
Invalidate;
inherited;
end;
procedure TGlass.CMCtl3DChanged(var Message: TMessage);
begin
inherited;
RecreateWnd;
end;
procedure TGlass.SetStyle(Value: TGlassStyle);
begin
if Value <> FStyle then
begin
FStyle := Value;
RecreateWnd;
end;
end;
function TGlass.GetFont: TFont;
begin
if Assigned(FFont) then Result:=FFont
else Result:=Self.Canvas.Font;
end;
//-------------------------------------------
function TGlass.GetLoop:integer;
begin
Result:=Floop;
end;
procedure TGlass.Init;
begin
FBmp.Width:=Self.Width;
FBmp.Height:=Self.Height;
With FBmp.Canvas do
begin
Brush.Color:=FBgColor;
RectAngle(ClipRect);
Font.Assign(FFont);
Brush.Style:=bsClear;
LineH := TextHeight('|中国沈阳CHW最量夏|')+1;
end;
FBmp1.PixelFormat:=pf8bit;
FBmp1.Width:=Self.Width;
FBmp1.Height:=Self.Height;
With FBmp1.Canvas do
begin
Brush.Color:=FBgColor;
RectAngle(ClipRect);
Font.Assign(FFont);
Brush.Style:=bsClear;
end;
FBmp1.Transparent:=not FBgbmp.Empty or FTransparent;
FBmp1.TransparentColor:=FBgColor;
FBmp1.TransparentMode:=tmauto;
//Self.DoubleBuffered:=True;
//self.Parent.DoubleBuffered:=true;
end;
procedure TGlass.SetLoop(Value:Integer);
begin
FLoop:=Value;
end;
procedure TGlass.SetBgbmp(Value:Tbitmap);
begin
FBgbmp.Assign(Value);
self.Invalidate;
end;
function TGlass.GetLines: TStringList;
begin
Result:=FLines;
end;
procedure TGlass.CPaint;
var
DR,SR,DR1,SR1:Trect;
begin
if FMode then
begin
DR := Rect(0, self.Height-1,self.Width, self.Height);
SR := Rect(0, Fpos, self.Width, Fpos+1);
DR1:= rect(0,0,self.Width,self.Height-1);
SR1:= rect(0,1,self.Width,self.Height);
end
else
begin
DR := Rect(self.Width-1, 0,self.Width, self.Height);
SR := Rect(FPos,0, FPos+1,self.Height);
DR1:= rect(0,0,self.Width-1,self.Height);
SR1:= rect(1,0,self.Width,self.Height);
end;
FBmp1.Canvas.CopyRect(DR1,FBmp1.Canvas,SR1);
FBmp1.Canvas.CopyRect(DR,FBmp.Canvas,SR);
if not (FBgbmp.Empty or FTransparent) then Canvas.StretchDraw(Self.Canvas.ClipRect,FBgbmp);
//self.CAnvas.Draw(0,0,FBgbmp);
Buffer.Canvas.CopyRect(ClientRect,Fbmp1.Canvas,ClientRect);
// self.Canvas.Draw(0,0,fbmp1);
// self.Canvas.CopyRect(Self.Canvas.ClipRect,FBmp1.Canvas,Self.Canvas.ClipRect);
end;
procedure TGlass.SetActive(Value: boolean);
begin
FActive:=Value;
FPos:=0;
I:=0;
K:=0;
j:=FLoop;
sLine :='';
init;
//readandwritetext;
if flines.Count>0 then
Timer.Enabled:=Value
else
if Value then
begin
Messagebox(0,'请先选择显示内容','错误', MB_OK);
//SetActive(False);
Factive:=False;
end;
end;
procedure TGlass.SetFont(Value: TFont);
begin
FFont.Assign(Value);
self.Invalidate;
end;
procedure TGlass.SetLines(Value: TStringList);
begin
FLines.Assign(Value);
// self.Invalidate;
end;
procedure TGlass.SetScrollDelay(Value: Integer);
begin
FScrollDelay:=Value;
Timer.Interval:=Value;
end;
procedure TGlass.TimerProc(Sender: Tobject);
begin
if FMode then
begin
if FPos > LineH-1+FRowSpacing then
begin
FPos := 0;
readandwritetext;
end;
end
else
begin
// readandwritetext;
if FPos >k-1 then
begin
FPos := 0;
readandwritetext;
end;
end;
CPaint;
//RecreateWnd;
invalidaterect(self.Canvas.Handle,nil, true);
self.Invalidate;
Inc(FPos);
end;
procedure TGlass.ReadandWriteText;
var
sCuted{ 按固定长度分割出来的部分字符串 }: string;
iCutLength{ 按固定长度分割出来的部分字符串的长度 }: integer;
x,y:integer;
begin
FBmp.Canvas.Font.Assign(FFont);
iCutLength:=self.Width div Fbmp.canvas.TextWidth('中')*2;
LineH := FBmp.Canvas.TextHeight('|中国沈阳CHW最量夏|')+1;
x:=(self.Width - Fbmp.canvas.TextWidth('中')*(iCutLength div 2))div 2;
y:=(self.Height-LineH)div 2;
if sLine=''then
begin
if I>=flines.Count then
begin
if FLoop=0 then I:=0 else
begin
I:=0;
Dec(j);
if j<=0 then SetActive(False);
end;
end;
//if I>=flines.Count then SetActive(False);
s:=flines[I];
//Messagebox(0,'请先选择显示内容','错误', MB_OK);
inc(I);
end
else s:=sline;
sCuted := Copy(s, 1, iCutLength);
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);
with FBmp.Canvas do
begin
brush.Color:=FBgColor;
//Brush.Color := clBlack;
FillRect(Rect(0, 0, self.Width, self.Height));
Font.Assign(FFont);
end;
if UPMode then FBmp.Canvas.TextOut(x,1,s)else FBmp.Canvas.TextOut(0,y+1,s);
end;
function TGlass._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;
end.