mmbutton.pas

一套及时通讯的原码

function TGlyphCache.Empty: Boolean;
begin
  Result := GlyphLists.Count = 0;
end;

var
  GlyphCache: TGlyphCache;

{ TButtonGlyph }

constructor TButtonGlyph.Create;
var
  I: TButtonState;
begin
  inherited Create;
  FOriginal := TBitmap.Create;
  FOriginal.OnChange := GlyphChanged;
  FTransparentColor := clOlive;
  FNumGlyphs := 1;
  for I := Low(I) to High(I) do
    FIndexs[I] := -1;
  if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
end;

destructor TButtonGlyph.Destroy;
begin
  FOriginal.Free;
  Invalidate;
  if Assigned(GlyphCache) and GlyphCache.Empty then
  begin
    GlyphCache.Free;
    GlyphCache := nil;
  end;
  inherited Destroy;
end;

procedure TButtonGlyph.Invalidate;
var
  I: TButtonState;
begin
  for I := Low(I) to High(I) do
  begin
    if FIndexs[I] <> -1 then FGlyphList.Delete(FIndexs[I]);
    FIndexs[I] := -1;
  end;
  GlyphCache.ReturnList(FGlyphList);
  FGlyphList := nil;
end;

procedure TButtonGlyph.GlyphChanged(Sender: TObject);
begin
  if Sender = FOriginal then
  begin
    FTransparentColor := FOriginal.TransparentColor;
    Invalidate;
    if Assigned(FOnChange) then FOnChange(Self);
  end;
end;

procedure TButtonGlyph.SetGlyph(Value: TBitmap);
var
  Glyphs: Integer;
begin
  Invalidate;
  FOriginal.Assign(Value);
  if (Value <> nil) and (Value.Height > 0) then
  begin
    FTransparentColor := Value.TransparentColor;
    if Value.Width mod Value.Height = 0 then
    begin
      Glyphs := Value.Width div Value.Height;
      if Glyphs > 4 then Glyphs := 1;
      SetNumGlyphs(Glyphs);
    end;
  end;
end;

procedure TButtonGlyph.SetNumGlyphs(Value: TNumGlyphs);
begin
  if (Value <> FNumGlyphs) and (Value > 0) then
  begin
    Invalidate;
    FNumGlyphs := Value;
  end;
end;

function TButtonGlyph.CreateButtonGlyph(State: TButtonState): Integer;
const
  ROP_DSPDxax = $00E20746;
var
  TmpImage, MonoBmp: TBitmap;
  IWidth, IHeight: Integer;
  IRect, ORect: TRect;
  I: TButtonState;
begin
  if (State = bsDown) and (NumGlyphs < 3) then State := bsUp;
  Result := FIndexs[State];
  if Result <> -1 then Exit;
  IWidth := FOriginal.Width div FNumGlyphs;
  IHeight := FOriginal.Height;
  if FGlyphList = nil then
  begin
    if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
    FGlyphList := GlyphCache.GetList(IWidth, IHeight);
  end;
  TmpImage := TBitmap.Create;
  try
    TmpImage.Width := IWidth;
    TmpImage.Height := IHeight;
    IRect := Rect(0, 0, IWidth, IHeight);
    TmpImage.Canvas.Brush.Color := clBtnFace;
    I := State;
    if Ord(I) >= NumGlyphs then I := bsUp;
    ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);
    case State of
      bsUp, bsDown:
        begin
          TmpImage.Canvas.BrushCopy(IRect, FOriginal, ORect, FTransparentColor);
          FIndexs[State] := FGlyphList.Add(TmpImage, nil);
        end;
      bsExclusive:
        begin
          TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
          FIndexs[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor);
        end;
      bsDisabled:
        if NumGlyphs > 1 then
        begin
          TmpImage.Canvas.BrushCopy(IRect, FOriginal, ORect, FTransparentColor);
          FIndexs[State] := FGlyphList.Add(TmpImage, nil);
        end
        else
        begin
          { Create a disabled version }
          MonoBmp := TBitmap.Create;
          try
            with MonoBmp do
            begin
              Assign(FOriginal);
              {$IFDEF DELPHI3}
              MonoBmp.HandleType := bmDDB;
              {$ENDIF}
              Canvas.Brush.Color := clBlack;
              Width := IWidth;
              if Monochrome then
              begin
                Canvas.Font.Color := clWhite;
                Monochrome := False;
                Canvas.Brush.Color := clWhite;
              end;
              Monochrome := True;
            end;
            with TmpImage.Canvas do
            begin
              Brush.Color := clBtnFace;
              FillRect(IRect);

              Brush.Color := clBlack;
              Font.Color := clWhite;
              CopyMode := MergePaint;
              Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp);

              CopyMode := SrcAnd;
              Draw(IRect.Left, IRect.Top, MonoBmp);
              Brush.Color := clBtnShadow;
              Font.Color := clBlack;
              CopyMode := SrcPaint;
              Draw(IRect.Left, IRect.Top, MonoBmp);
              CopyMode := SrcCopy;

            end;
            FIndexs[State] := FGlyphList.Add(TmpImage, nil);
          finally
            MonoBmp.Free;
          end;
       end;
    end;
  finally
    TmpImage.Free;
  end;
  Result := FIndexs[State];
  FOriginal.Dormant;
end;

procedure TButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; X, Y: Integer;
  State: TButtonState);
var
  Index: Integer;
begin
  if FOriginal = nil then Exit;
  if (FOriginal.Width = 0) or (FOriginal.Height = 0) then Exit;
  Index := CreateButtonGlyph(State);
  FGlyphList.Draw(Canvas, X, Y, Index);
end;

procedure TButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;
  TextBounds: TRect; State: TButtonState);
var
  CString: PChar;

begin
   if Length(Caption) > 0 then
   begin
      CString := StrAlloc(Length(Caption)+1);
      try
         StrPCopy(CString, Caption);
         Canvas.Brush.Style := bsClear;
         if State = bsDisabled then
         begin
            with Canvas do
            begin
               OffsetRect(TextBounds, 1, 1);
               Font.Color := clWhite;
               DrawText(Handle, CString, Length(Caption), TextBounds, 0);
               OffsetRect(TextBounds, -1, -1);
               Font.Color := clDkGray;
               DrawText(Handle, CString, Length(Caption), TextBounds, 0);
            end;
         end
         else DrawText(Canvas.Handle, CString, -1, TextBounds,
              DT_CENTER or DT_VCENTER or DT_SINGLELINE);

      finally
         StrDispose(CString);
      end;
   end;
end;

procedure TButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
  const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
  var GlyphPos: TPoint; var TextBounds: TRect);
var
  TextPos: TPoint;
  ClientSize, GlyphSize, TextSize: TPoint;
  TotalSize: TPoint;
  CString: PChar;

begin
   CString := StrAlloc(Length(Caption)+2);
   StrPCopy(CString, Caption);
   try
      { calculate the item sizes }
      ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top);

      if FOriginal <> nil then
         GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height)
      else
         GlyphSize := Point(0, 0);

      if Length(Caption) > 0 then
      begin
         TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
         DrawText(Canvas.Handle, CString, -1, TextBounds, DT_CALCRECT);
      end
      else TextBounds := Rect(0, 0, 0, 0);
      TextSize := Point(TextBounds.Right - TextBounds.Left,
                        TextBounds.Bottom -TextBounds.Top);

      { If the layout has the glyph on the right or the left, then both the
        text and the glyph are centered vertically.  If the glyph is on the top
        or the bottom, then both the text and the glyph are centered horizontally.}
      if Layout in [blGlyphLeft, blGlyphRight] then
      begin
         GlyphPos.Y := (ClientSize.Y div 2) - (GlyphSize.Y div 2);
         TextPos.Y := (ClientSize.Y div 2) - (TextSize.Y div 2);
      end
      else
      begin
         GlyphPos.X := (ClientSize.X div 2) - (GlyphSize.X div 2);
         TextPos.X := (ClientSize.X div 2) - (TextSize.X div 2);
      end;

      { if there is no text or no bitmap, then Spacing is irrelevant }
      if (TextSize.X = 0) or (GlyphSize.X = 0) then Spacing := 0;

      { adjust Margin and Spacing }
      if Margin = -1 then
      begin
         if Spacing = -1 then
         begin
            TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
            if Layout in [blGlyphLeft, blGlyphRight] then
               Margin := (ClientSize.X - TotalSize.X) div 3
            else
               Margin := (ClientSize.Y - TotalSize.Y) div 3;
            Spacing := Margin;
         end
         else
         begin
            TotalSize := Point(GlyphSize.X + Spacing + TextSize.X,
                               GlyphSize.Y + Spacing + TextSize.Y);
            if Layout in [blGlyphLeft, blGlyphRight] then
               Margin := (ClientSize.X div 2) - (TotalSize.X div 2)
            else
               Margin := (ClientSize.Y div 2) - (TotalSize.Y div 2);
         end;
      end
      else
      begin
         if Spacing = -1 then
         begin
            TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X),
                               ClientSize.Y - (Margin + GlyphSize.Y));
            if Layout in [blGlyphLeft, blGlyphRight] then
               Spacing := (TotalSize.X div 2) - (TextSize.X div 2)
            else
               Spacing := (TotalSize.Y div 2) - (TextSize.Y div 2);
         end;
      end;

      case Layout of
         blGlyphLeft:
         begin
            GlyphPos.X := Margin;
            TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
         end;
         blGlyphRight:
         begin
            GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;
            TextPos.X := GlyphPos.X - Spacing - TextSize.X;
         end;
         blGlyphTop:
         begin
            GlyphPos.Y := Margin;
            TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
         end;
         blGlyphBottom:
         begin
            GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
            TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
         end;
      end;

      { fixup the result variables }
      Inc(GlyphPos.X, Client.Left);
      Inc(GlyphPos.Y, Client.Top);
      OffsetRect(TextBounds, TextPos.X + Client.Left, TextPos.Y + Client.Top);

   finally
      StrDispose(CString);
   end;
end;

function TButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;
  const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
  State: TButtonState): TRect;
var
  GlyphPos: TPoint;
  TextBounds: TRect;
begin
  CalcButtonLayout(Canvas, Client, Caption, Layout, Margin, Spacing,
    GlyphPos, TextBounds);
  DrawButtonGlyph(Canvas, GlyphPos.X, GlyphPos.Y, State);
  DrawButtonText(Canvas, Caption, TextBounds, State);
  Result := TextBounds;
end;

{== TMMSpeedButton ======================================================}
constructor TMMSpeedButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FPattern := nil;
  
  SetBounds(0, 0, 25, 25);
  ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks];
  FGlyph := TButtonGlyph.Create;
  TButtonGlyph(FGlyph).OnChange := GlyphChanged;
  ParentFont := True;
  FSpacing := 4;
  FMargin := -1;
  FLayout := blGlyphLeft;
  FBevel := bsRaised;
  FDownColor := clWhite;
  FBevelColor := clBlack;

  ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
  if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMSpeedButton ------------------------------------------------------}
destructor TMMSpeedButton.Destroy;
begin
  TButtonGlyph(FGlyph).Free;
  if FPattern <> nil then FPattern.Free;

  inherited Destroy;
end;

{-- TMMSpeedButton ------------------------------------------------------}
procedure TMMSpeedButton.CreateBrushPattern;
var
  X, Y: Integer;
begin
  if FPattern <> nil then FPattern.Free;
  FPattern := TBitmap.Create;
  FPattern.Width := 8;
  FPattern.Height := 8;
  with FPattern.Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := clBtnFace;
    FillRect(Rect(0, 0, FPattern.Width, FPattern.Height));
    for Y := 0 to 7 do
      for X := 0 to 7 do
        if (Y mod 2) = (X mod 2) then  { toggles between even/odd pixles }