我想在透明的panel里滚动文本! 主要是想透明滚动,看到下面的控件! 怎样实现!

Question

我想在透明的panel里滚动文本! 主要是想透明滚动,看到下面的控件! 怎样实现!

Answer 1

编码如下!但是有文本重叠显示成一片红的问题.请高手帮忙修改!
 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;

Answer 2

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;

Answer 3

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.