flatbtns.pas

相信大家已经找很长时间了

{ TFlatSpeedBtn }
constructor TFlatSpeedBtn.Create (AOwner: TComponent);
begin
  inherited Create(AOwner);
  if MouseTimer = nil then
  begin
    MouseTimer := TTimer.Create(nil);
    MouseTimer.Enabled := False;
    MouseTimer.Interval := 100; // 10 times a second
  end;
  SetBounds(0, 0, 25, 25);
  ControlStyle := [csCaptureMouse, csDoubleClicks];
  FGlyph := TBitmap.Create;
  FNumGlyphs := 1;
  ParentFont := True;
  ParentColor := True;
  FFocusedColor := $00FF80FF;
  FDownColor := $00C5D6D9;
  FBorderColor := $004080FF;
  FColorHighlight := clWhite;
  FColorShadow := clBlack;
  FSpacing := 4;
  FMargin := -1;
  FLayout := blGlyphTop;
  FUseAdvColors := false;
  FAdvColorFocused := 10;
  FAdvColorDown := 10;
  FAdvColorBorder := 50;
  FModalResult := mrNone;
  FTransparent := tmNone;
  Inc(ControlCounter);
end;

destructor TFlatSpeedBtn.Destroy;
begin
  RemoveMouseTimer;
  FGlyph.Free;
  Dec(ControlCounter);
  if ControlCounter = 0 then
  begin
    MouseTimer.Free;
    MouseTimer := nil;
  end;
  inherited Destroy;
end;

procedure TFlatSpeedBtn.Paint;
var
  FTransColor: TColor;
  FImageList: TImageList;
  sourceRect, destRect: TRect;
  tempGlyph: TBitmap;
  Offset: TPoint;
begin
  // get the transparent color
  FTransColor := FGlyph.Canvas.Pixels[0, FGlyph.Height - 1];
  Canvas.Font := Self.Font;

  if FState in [bsDown, bsExclusive] then
    Offset := Point(1, 1)
  else
    Offset := Point(0, 0);

  CalcButtonLayout(Canvas, ClientRect, Offset, FLayout, FSpacing,
    FMargin, FGlyph, FNumGlyphs, Caption, TextBounds, GlyphPos);

  if not Enabled then
  begin
    FState := bsDisabled;
    FDragging := False;
  end
  else
    if FState = bsDisabled then
      if FDown and (GroupIndex <> 0) then
        FState := bsExclusive
      else
        FState := bsUp;

  // DrawBackground
  case FTransparent of
    tmAlways: ;
    tmNone:
      begin
        case FState of
          bsUp:
            if FMouseInSpeedControl then
              Canvas.Brush.Color := FFocusedColor
            else
              Canvas.Brush.Color := Self.Color;
          bsDown:
            Canvas.Brush.Color := FDownColor;
          bsExclusive:
            if FMouseInSpeedControl then
              Canvas.Brush.Color := FFocusedColor
            else
              Canvas.Brush.Color := FDownColor;
          bsDisabled:
            Canvas.Brush.Color := Self.Color;
        end;
        Canvas.FillRect(ClientRect);
      end;
    tmNotFocused:
      if FMouseInSpeedControl then
      begin
        case FState of
          bsUp:
            if FMouseInSpeedControl then
              Canvas.Brush.Color := FFocusedColor
            else
              Canvas.Brush.Color := Self.Color;
          bsDown:
            Canvas.Brush.Color := FDownColor;
          bsExclusive:
            if FMouseInSpeedControl then
              Canvas.Brush.Color := FFocusedColor
            else
              Canvas.Brush.Color := FDownColor;
          bsDisabled:
            Canvas.Brush.Color := Self.Color;
        end;
        Canvas.FillRect(ClientRect);
      end;
  end;

  // DrawBorder
  case FState of
    bsUp:            
      if FMouseInSpeedControl then
        Frame3DBorder(canvas, ClientRect, FColorHighlight, FColorShadow, 1)
      else
        Frame3DBorder(canvas, ClientRect, FBorderColor, FBorderColor, 1);
    bsDown, bsExclusive:
      Frame3DBorder(canvas, ClientRect, FColorShadow, FColorHighlight, 1);
    bsDisabled:
      Frame3DBorder(canvas, ClientRect, FBorderColor, FBorderColor, 1);
  end;

  // DrawGlyph
  if not FGlyph.Empty then
  begin
    tempGlyph := TBitmap.Create;
    case FNumGlyphs of
      1: case FState of
           bsUp:        sourceRect := Rect(0, 0, FGlyph.Width, FGlyph.Height);
           bsDisabled:  sourceRect := Rect(0, 0, FGlyph.Width, FGlyph.Height);
           bsDown:      sourceRect := Rect(0, 0, FGlyph.Width, FGlyph.Height);
           bsExclusive: sourceRect := Rect(0, 0, FGlyph.Width, FGlyph.Height);
         end;
      2: case FState of
           bsUp:        sourceRect := Rect(0, 0, FGlyph.Width div FNumGlyphs, FGlyph.Height);
           bsDisabled:  sourceRect := Rect(FGlyph.Width div FNumGlyphs, 0, FGlyph.Width, FGlyph.Height);
           bsDown:      sourceRect := Rect(0, 0, FGlyph.Width div FNumGlyphs, FGlyph.Height);
           bsExclusive: sourceRect := Rect(0, 0, FGlyph.Width div FNumGlyphs, FGlyph.Height);
         end;
      3: case FState of
           bsUp:        SourceRect := Rect(0, 0, FGlyph.Width div FNumGlyphs, FGlyph.Height);
           bsDisabled:  SourceRect := Rect(FGlyph.width div FNumGlyphs, 0, (FGlyph.Width div FNumGlyphs) * 2, FGlyph.Height);
           bsDown:      SourceRect := Rect((FGlyph.Width div FNumGlyphs) * 2, 0, FGlyph.Width, FGlyph.Height);
           bsExclusive: SourceRect := Rect((FGlyph.Width div FNumGlyphs) * 2, 0, FGlyph.Width, FGlyph.Height);
         end;
      4: case FState of
           bsUp:        SourceRect := Rect(0, 0, FGlyph.Width div FNumGlyphs, FGlyph.Height);
           bsDisabled:  SourceRect := Rect(FGlyph.width div FNumGlyphs, 0, (FGlyph.Width div FNumGlyphs) * 2, FGlyph.Height);
           bsDown:      SourceRect := Rect((FGlyph.Width div FNumGlyphs) * 2, 0, (FGlyph.Width div FNumGlyphs) * 3, FGlyph.Height);
           bsExclusive: SourceRect := Rect((FGlyph.width div FNumGlyphs) * 3, 0, FGlyph.Width, FGlyph.Height);
         end;
    end;

    destRect := Rect(0, 0, FGlyph.Width div FNumGlyphs, FGlyph.Height);
    tempGlyph.Width := FGlyph.Width div FNumGlyphs;
    tempGlyph.Height := FGlyph.Height;
    tempGlyph.canvas.copyRect(destRect, FGlyph.canvas, sourcerect);

    if (FNumGlyphs = 1) and (FState = bsDisabled) then
    begin
      tempGlyph := CreateDisabledBitmap(tempGlyph, clBlack, clBtnFace, clBtnHighlight, clBtnShadow, True);
      FTransColor := tempGlyph.Canvas.Pixels[0, tempGlyph.Height - 1];
    end;

    FImageList := TImageList.CreateSize(FGlyph.Width div FNumGlyphs, FGlyph.Height);
    try
      FImageList.AddMasked(tempGlyph, FTransColor);
      FImageList.Draw(canvas, glyphpos.x, glyphpos.y, 0);
    finally
      FImageList.Free;
    end;
    tempGlyph.free;
  end;

  // DrawText
  Canvas.Brush.Style := bsClear;
  if FState = bsDisabled then
  begin
    OffsetRect(TextBounds, 1, 1);
    Canvas.Font.Color := clBtnHighlight;
    DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
    OffsetRect(TextBounds, -1, -1);
    Canvas.Font.Color := clBtnShadow;
    DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
  end
  else
    DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;

procedure TFlatSpeedBtn.UpdateTracking;
var
  P: TPoint;
begin
  if Enabled then
  begin
    GetCursorPos(P);
    FMouseInSpeedControl := not (FindDragTarget(P, True) = Self);
    if FMouseInSpeedControl then
      MouseLeave
    else
      MouseEnter;
  end;
end;

procedure TFlatSpeedBtn.Loaded;
begin
  inherited Loaded;
  Invalidate;
end;

procedure TFlatSpeedBtn.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then
  begin
    if not FDown then
    begin
      FState := bsDown;
      Invalidate;
    end;
    FDragging := True;
  end;
end;

procedure TFlatSpeedBtn.MouseMove (Shift: TShiftState; X, Y: Integer);
var
  NewState: TButtonState;
  P: TPoint;
begin
  inherited;

  // mouse is in control ?
  P := ClientToScreen(Point(X, Y));
  if (MouseInSpeedControl <> Self) and (FindDragTarget(P, True) = Self) then
  begin
    if Assigned(MouseInSpeedControl) then
      MouseInSpeedControl.MouseLeave;
    // the application is active ?
    if (GetActiveWindow <> 0) then
    begin
      if MouseTimer.Enabled then
        MouseTimer.Enabled := False;
      MouseInSpeedControl := Self;
      MouseTimer.OnTimer := MouseTimerHandler;
      MouseTimer.Enabled := True;
      MouseEnter;
    end;
  end;

  if FDragging then
  begin
    if not FDown then
      NewState := bsUp
    else
      NewState := bsExclusive;
    if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
      if FDown then
        NewState := bsExclusive
      else
        NewState := bsDown;
    if NewState <> FState then
    begin
      FState := NewState;
      Invalidate;
    end;
  end;
end;

procedure TFlatSpeedBtn.MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  DoClick: Boolean;
begin
  inherited MouseUp(Button, Shift, X, Y);
  if FDragging then
  begin
    FDragging := False;
    DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
    if FGroupIndex = 0 then
    begin
      // Redraw face in-case mouse is captured
      FState := bsUp;
      FMouseInSpeedControl := False;
      if DoClick and not (FState in [bsExclusive, bsDown]) then
        Invalidate;
    end
    else
      if DoClick then
      begin
        SetDown(not FDown);
        if FDown then Repaint;
      end
      else
      begin
        if FDown then FState := bsExclusive;
        Repaint;
      end;
    if DoClick then Click else MouseLeave;
    UpdateTracking;
  end;
end;

procedure TFlatSpeedBtn.Click;
begin
  if Parent <> nil then
     GetParentForm(self).ModalResult := FModalResult;
  if Assigned(PopupMenu) then
     PopupMenu.PopUp(ClientToScreen(Point(0, Height)).X,
                     ClientToScreen(Point(0, Height)).Y);
  inherited Click;
end;

function TFlatSpeedBtn.GetPalette: HPALETTE;
begin
  Result := FGlyph.Palette;
end;

procedure TFlatSpeedBtn.SetColors (Index: Integer; Value: TColor);
begin
  case Index of
    0: FFocusedColor := Value;
    1: FDownColor := Value;
    2: FBorderColor := Value;
    3: FColorHighlight := Value;
    4: FColorShadow := Value;
  end;
  Invalidate;
end;

procedure TFlatSpeedBtn.CalcAdvColors;
begin
  if FUseAdvColors then
  begin
    FFocusedColor := CalcAdvancedColor(Color, FFocusedColor, FAdvColorFocused, lighten);
    FDownColor := CalcAdvancedColor(Color, FDownColor, FAdvColorDown, darken);
    FBorderColor := CalcAdvancedColor(Color, FBorderColor, FAdvColorBorder, darken);
  end;
end;

procedure TFlatSpeedBtn.SetAdvColors (Index: Integer; Value: TAdvColors);
begin
  case Index of
    0: FAdvColorFocused := Value;
    1: FAdvColorDown := Value;
    2: FAdvColorBorder := Value;
  end;
  CalcAdvColors;
  Invalidate;
end;

procedure TFlatSpeedBtn.SetUseAdvColors (Value: Boolean);
begin
  if Value <> FUseAdvColors then
  begin
    FUseAdvColors := Value;
    ParentColor := Value;
    CalcAdvColors;
    Invalidate;
  end;
end;

procedure TFlatSpeedBtn.SetGlyph (value: TBitmap);
begin
  if value <> FGlyph then
  begin
    FGlyph.Assign(value);
    if not FGlyph.Empty then
    begin
      if FGlyph.Width mod FGlyph.Height = 0 then
      begin
        FNumGlyphs := FGlyph.Width div FGlyph.Height;
        if FNumGlyphs > 4 then FNumGlyphs := 1;
      end;
    end;
    Invalidate;
  end;
end;

procedure TFlatSpeedBtn.SetNumGlyphs (value: TNumGlyphs);
begin
  if value <> FNumGlyphs then
  begin
    FNumGlyphs := value;
    Invalidate;
  end;
end;

procedure TFlatSpeedBtn.UpdateExclusive;
var
  Msg: TMessage;
begin
  if (FGroupIndex <> 0) and (Parent <> nil) then
  begin
    Msg.Msg := CM_BUTTONPRESSED;
    Msg.WParam := FGroupIndex;
    Msg.LParam := Longint(Self);
    Msg.Result := 0;
    Parent.Broadcast(Msg);
  end;
end;

procedure TFlatSpeedBtn.SetDown (Value: Boolean);
begin
  if FGroupIndex = 0 then Value := False;
  if Value <> FDown then
  begin
    if FDown and (not FAllowAllUp) then Exit;
    FDown := Value;
    if Value then
    begin
      if FState = bsUp then Invalidate;
      FState := bsExclusive
    end
    else
    begin
      FState := bsUp;
      Repaint;
    end;
    if Value then UpdateExclusive;
  end;
end;

procedure TFlatSpeedBtn.SetGroupIndex (Value: Integer);
begin
  if FGroupIndex <> Value then