delphi2007 教程

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