今天俺用Delphi编写了第一个控件,大家顶啊！

俺最近看完了Delphi6 Develop Guid 的关于编写控件的章节，算是学有所成吧：今天俺用Delphi编写了第一个控件。尽管还是参考了书上的例子，但是小弟收获甚多啊！确实啊，真正的高手应该是那群控件编写者啊！现在把部分代码贴出来给大家看看。需要的请到这里下载：
http://blog.blogchina.com/upload/2004-12-10/20041210235227604838.rar
unit MHMarquee;interfaceuses
  SysUtils, Windows, Classes, Forms, Controls, Graphics,
  Messages, ExtCtrls, Dialogs;const
  ScrollPixels = 1;     // num of pixels for each scroll
  TimerInterval = 50;   // time between scrolls in ms
implementationconstructor TMHMarquee.Create(AOwner: TComponent);
{ constructor for TMHMarquee class }  procedure DoTimer;
  { procedure sets up TMHMarquee's timer }
  begin
    FTimer := TTimer.Create(Self);
    with FTimer do
    begin
      Enabled := False;      Interval := TimerInterval;
      OnTimer := DoTimerOnTimer;
    end;
  end;begin
  inherited Create(AOwner);
  FItems := TStringList.Create;  { instanciate string list }
  DoTimer;                       { set up timer }
  { set instance variable default values }
  Width := 100;
  Height := 75;
  FActive := False;
  FCircleShow := false;  //初始没有循环播放
  FScrollRight := false;  //初始向右
  BevelWidth := 3;
 // FJust := tjCenter;
  FSideWidth:= BorderWidth+2*BevelWidth;
end;destructor TMHMarquee.Destroy;
{ destructor for TMHMarquee class }
begin
  SetActive(False);
  FTimer.Free;             // free allocated objects
  FItems.Free;
  inherited Destroy;
end;procedure TMHMarquee.DoTimerOnTimer(Sender: TObject);
{ This method is executed in respose to a timer event }
begin
  IncLine;
  { only repaint within borders }
  InvalidateRect(Handle, @InsideRect, False);
end;procedure TMHMarquee.IncLine;
{ this method is called to increment a line }
begin
  if  FScrollRight then       ////向右 if Marquee is scrolling upward
  begin
    { Check to see if marquee has scrolled to end yet }
    if FItems.Count * LineHi + width+FSideWidth  >= CurrLine then
      { not at end, so increment current line }
      Inc(CurrLine, ScrollPixels)
    else
    begin
     if FCircleShow then     //循环处理
       SetStartLine
     else
       SetActive(False);
    end;
  end
  else begin                   // if Marquee is scrolling downward
    { Check to see if marquee has scrolled to end yet }
    if CurrLine >= FSideWidth then
      { not at end, so decrement current line }
      Dec(CurrLine, ScrollPixels)
    else
    begin
     if FCircleShow then
       SetStartLine
     else
       SetActive(False);
    end;
  end;
end;procedure TMHMarquee.SetItems(Value: TStringList);
 procedure DoFItems;
 var
   tList:TstringList;
   i,j:integer;
   tStr1,tStr:WideString;    //使用unicode,可以兼容所有的字符
 begin
   tList := TstringList.Create;
   try
     for i:=0 to Value.Count-1 do
     begin
       tStr1:=Value[i];
       tStr:='';
           while j<= Length(tStr1) do
       begin
         tStr :=tStr+tStr1[j]+#13;
         inc(j);
         tList.Add(string(tStr));
     end;
      FItems.Assign(tList);
   finally
     tList.Free;
   end; end;begin
  if FItems <> Value then
    DoFItems;
end;procedure TMHMarquee.SetLineWidth
;
{ this virtual method sets the LineHi instance variable }
var
  Metrics : TTextMetric;
begin
  { get metric info for font }
  GetTextMetrics(Canvas.Handle, Metrics);
  { 获得每个汉字的最大宽度 }
  LineHi := Metrics.tmMaxCharWidth ;
end;procedure TMHMarquee.SetStartLine;
{ this virtual method initializes the CurrLine instance variable }
begin
  // initialize current line to top if scrolling up, or...
  if  FScrollRight then CurrLine := FSideWidth //向右
  // bottom if scrolling down
  else CurrLine := VRect.right-width+FSideWidth ;     //向左
end;procedure TMHMarquee.PaintLine(R: TRect; LineNum: Integer);
{ this method is called to paint each line of text onto MemBitmap }
var
  S: string;
begin
  { Copy next line to local variable for clarity }
  S := FItems.Strings[LineNum];
  { Draw line of text onto memory bitmap }
  DrawText(MemBitmap.Canvas.Handle, PChar(s), Length(s),R,DT_LEFT);   //画一列文字end;
procedure TMHMarquee.FillBitmap;
var
  x, i : Integer;
  R: TRect;
begin
  SetLineWidth;                 // set height of each line
  { VRect rectangle represents entire memory bitmap }
  VRect := Rect(0, 0, Width*2+ LineHi * FItems.Count,Height);
  { InsideRect rectangle represents interior of beveled border }//?
  InsideRect := Rect(FSideWidth, FSideWidth, Width - (FSideWidth),
    Height - (FSideWidth));
  R := Rect(InsideRect.Left, InsideRect.Top, InsideRect.Left+LineHi, InsideRect.Bottom);
  SetStartLine;
  MemBitmap.Height := Height;      // initialize memory bitmap
  with MemBitmap do
  begin
    Width := VRect.Right;
    with Canvas do
    begin
      Font := Self.Font;
      Brush.Color := Color;
      FillRect(VRect);
      Brush.Style := bsClear;
    end;
  end;
  x := width;
  i := 0;
  repeat
    R.left := x;
    R.Right:= x+Linehi;
    PaintLine(R, i);
    { increment y by the height (in pixels) of a line }
    inc(x, LineHi);
    inc(i);
  until i >= FItems.Count;      // repeat for all lines
end;procedure TMHMarquee.Paint;
{ this virtual method is called in response to a }
{ Windows paint message }
begin
  if FActive then
    { Copy from memory bitmap to screen }
    BitBlt(Canvas.Handle, insideRect.Left , insideRect.Top , width-2*FSideWidth, height-2*FSideWidth,
      MemBitmap.Canvas.Handle, currLine, FSideWidth, srcCopy)
  else
    inherited Paint;
end;procedure TMHMarquee.SetActive(Value: Boolean);
{ called to activate/deactivate the marquee }
begin
  if Value and (not FActive) and (FItems.Count > 0) then
  begin
    FActive := True;                // set active flag
    MemBitmap := TBitmap.Create;
    FillBitmap;                     // Paint Image on bitmap
    FTimer.Enabled := True;         // start timer
  end
  else if (not Value) and FActive then
  begin
    FTimer.Enabled := False;   // disable timer,
    if Assigned(FOnDone)       // fire OnDone event,
      then FOnDone(Self);
    FActive := False;          // set FActive to False
    MemBitmap.Free;            // free memory bitmap
    Invalidate;                // clear control window
  end;
end;procedure TMHMarquee.SetTimerActive(Value: Boolean);
begin
  if assigned(FTimer) and  FActive then  //只对Factive=true有效
   begin
     if FTimer.Enabled and (not Value) then
       FTimer.Enabled := false
     else if (not FTimer.Enabled) and Value then
       FTimer.Enabled := true;   end;end;procedure TMHMarquee.SetTimerInterval(Value: integer);
begin
  if Value<=0 then exit;
  if FTimer.Enabled = true then
    begin
      SetTimerActive(false);
      FTimer.Interval := Value;
      SetTimerActive(true);
    end
  else
    FTimer.Interval := Value;
end;procedure TMHMarquee.SetCircleShow(Value: Boolean);
begin
  if FCircleShow <> Value then
    FCircleShow := Value;
end;end.