myautobtn.pas

自动适应简繁体的TBitbtn按钮,并有类似XP风格的外观

  else
  begin
    if (FState in [baDown, baExclusive]) or
      (FMouseInControl and (FState <> baDisabled)) or
      (csDesigning in ComponentState) then
      DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [baDown, baExclusive]],
        FillStyles[Transparent] or BF_RECT)
    else if not Transparent then
    begin
      Canvas.Brush.Color := Color;
      Canvas.FillRect(PaintRect);
    end;
    InflateRect(PaintRect, -1, -1);
  end;
  if FState in [baDown, baExclusive] then
  begin
    if (FState = baExclusive) and (not FFlat or not FMouseInControl) then
    begin
      Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight);
      Canvas.FillRect(PaintRect);
    end;
    Offset.X := 1;
    Offset.Y := 1;
  end
  else
  begin
    Offset.X := 0;
    Offset.Y := 0;
  end;
  {if FBordFlat then
  begin
    Offset.Y := Offset.Y-1;
    Offset.X := Offset.X;
  end;}
  if Enabled and (Caption='') and (TButtonGlyph(FGlyph).FOriginal.Width=0) then
  begin
      Canvas.Brush.Color := Color;
      if FState in [baDown] then
      begin
        PaintRect.Left:=PaintRect.Left+1;
        PaintRect.Top:=PaintRect.Top+1;
        PaintRect.Right:=PaintRect.Right-1;
        PaintRect.Bottom:=PaintRect.Bottom-1;
      end;
      Canvas.FillRect(PaintRect);
  end else
  TButtonGlyph(FGlyph).Draw(Canvas, PaintRect, Offset, Caption, FLayout, FMargin,
    FSpacing, FState, Transparent, DrawTextBiDiModeFlags(0));
end;

procedure TMySpeedButton.UpdateTracking;
var
  P: TPoint;
begin
  if FFlat then
  begin
    if Enabled then
    begin
      GetCursorPos(P);
      FMouseInControl := not (FindDragTarget(P, True) = Self);
      if FMouseInControl then
        Perform(CM_MOUSELEAVE, 0, 0)
      else
        Perform(CM_MOUSEENTER, 0, 0);
    end;
  end;
end;
    
procedure TMySpeedButton.Loaded;
var
  State: TautoButtonState;
begin
  inherited Loaded;
  if Enabled then
    State := baUp
  else
    State := baDisabled;
  TButtonGlyph(FGlyph).CreateButtonGlyph(State);
end;
    
procedure TMySpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then
  begin
//     Font.Color:= clPurple;
//     FLeaveColor:= clPurple;
    if not FDown then
    begin
      FState := baDown;
      Invalidate;
    end;
    FDragging := True;
  end;
end;
    
procedure TMySpeedButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewState: TautoButtonState;
begin
  inherited MouseMove(Shift, X, Y);
  if FDragging then
  begin
    if not FDown then NewState := baUp
    else NewState := baExclusive;
    if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
      if FDown then NewState := baExclusive else NewState := baDown;
    if NewState <> FState then
    begin
      FState := NewState;
      Invalidate;
    end;
  end
  else if not FMouseInControl then
    UpdateTracking;
end;
    
procedure TMySpeedButton.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 := baUp;
      FMouseInControl := False;
      if DoClick and not (FState in [baExclusive, baDown]) then
        Invalidate;
    end
    else
      if DoClick then
      begin
        SetDown(not FDown);
        if FDown then Repaint;
      end
      else
      begin
        if FDown then FState := baExclusive;
        Repaint;
      end;
    if DoClick then Click;
    UpdateTracking;
  end;
end;
    
procedure TMySpeedButton.Click;
begin
  inherited Click;
end;
    
function TMySpeedButton.GetPalette: HPALETTE;
begin
  Result := Glyph.Palette;
end;
    
function TMySpeedButton.GetGlyph: TBitmap;
begin
  Result := TButtonGlyph(FGlyph).Glyph;
end;
    
procedure TMySpeedButton.SetGlyph(Value: TBitmap);
begin
  TButtonGlyph(FGlyph).Glyph := Value;
  Invalidate;
end;
    
function TMySpeedButton.GetNumGlyphs: TautoNumGlyphs;
begin
  Result := TButtonGlyph(FGlyph).NumGlyphs;
end;
    
procedure TMySpeedButton.SetNumGlyphs(Value: TautoNumGlyphs);
begin
  if Value < 0 then Value := 1
  else if Value > 4 then Value := 4;
  if Value <> TButtonGlyph(FGlyph).NumGlyphs then
  begin
    TButtonGlyph(FGlyph).NumGlyphs := Value;
    Invalidate;
  end;
end;
    
procedure TMySpeedButton.GlyphChanged(Sender: TObject);
begin
  Invalidate;
end;
    
procedure TMySpeedButton.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 TMySpeedButton.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 = baUp then Invalidate;
      FState := baExclusive
    end
    else
    begin
      FState := baUp;
      Repaint;
    end;
    if Value then UpdateExclusive;
  end;
end;
    
procedure TMySpeedButton.SetFlat(Value: Boolean);
begin
  if Value <> FFlat then
  begin
    FFlat := Value;
    Invalidate;
  end;
end;

procedure TMySpeedButton.SelfExit;
begin
  if Assigned( FOnSelfExitevent ) then
  begin
    FOnSelfExitevent( Self);
  end
  else
    inherited;
end;

procedure TMySpeedButton.SelfEnter;
begin
  if Assigned( FOnSelfEnterevent ) then
  begin
    FOnSelfEnterevent( Self);
  end
  else
    inherited;
end;

procedure TMySpeedButton.SelfChange;
begin
  if Assigned( FOnSelfChangeevent ) then
  begin
    FOnSelfChangeevent( Self);
  end
  else
    inherited;
end;

procedure TMySpeedButton.SelfDblClick;
begin
  if Assigned( FOnSelfDblClickevent ) then
  begin
    FOnSelfDblClickevent( Self);
  end
  else
    inherited;
end;

procedure TMySpeedButton.SetGroupIndex(Value: Integer);
begin
  if FGroupIndex <> Value then
  begin
    FGroupIndex := Value;
    UpdateExclusive;
  end;
end;
    
procedure TMySpeedButton.SetLayout(Value: TautoButtonLayout);
begin
  if FLayout <> Value then
  begin
    FLayout := Value;
    Invalidate;
  end;
end;
    
procedure TMySpeedButton.SetMargin(Value: Integer);
begin
  if (Value <> FMargin) and (Value >= -1) then
  begin
    FMargin := Value;
    Invalidate;
  end;
end;
    
procedure TMySpeedButton.SetSpacing(Value: Integer);
begin
  if Value <> FSpacing then
  begin
    FSpacing := Value;
    Invalidate;
  end;
end;

procedure TMySpeedButton.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then
  begin
    FTransparent := Value;
    if Value then
      ControlStyle := ControlStyle - [csOpaque] else
      ControlStyle := ControlStyle + [csOpaque];
    Invalidate;
  end;
end;

procedure TMySpeedButton.SetAllowAllUp(Value: Boolean);
begin
  if FAllowAllUp <> Value then
  begin
    FAllowAllUp := Value;
    UpdateExclusive;
  end;
end;
    
procedure TMySpeedButton.WMLButtonDblClk(var Message: TWMLButtonDown);
begin
  inherited;
  if FDown then DblClick;
end;
    
procedure TMySpeedButton.CMEnabledChanged(var Message: TMessage);
const
  NewState: array[Boolean] of TautoButtonState = (baDisabled, baUp);
begin
  TButtonGlyph(FGlyph).CreateButtonGlyph(NewState[Enabled]);
  UpdateTracking;
  Repaint;
end;
    
procedure TMySpeedButton.CMButtonPressed(var Message: TMessage);
var
  Sender: TMySpeedButton;
begin
  if Message.WParam = FGroupIndex then
  begin
    Sender := TMySpeedButton(Message.LParam);
    if Sender <> Self then
    begin
      if Sender.Down and FDown then
      begin
        FDown := False;
        FState := baUp;
        Invalidate;
      end;
      FAllowAllUp := Sender.AllowAllUp;
    end;
  end;
end;
    
procedure TMySpeedButton.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(CharCode, Caption) and Enabled and Visible and
      (Parent <> nil) and Parent.Showing then
    begin
      Click;
      Result := 1;
    end else
      inherited;
end;
    
procedure TMySpeedButton.CMFontChanged(var Message: TMessage);
begin
  Invalidate;
end;
    
procedure TMySpeedButton.CMTextChanged(var Message: TMessage);
begin
  Invalidate;
end;
    
procedure TMySpeedButton.CMSysColorChange(var Message: TMessage);
begin
  with TButtonGlyph(FGlyph) do
  begin
    Invalidate;
    CreateButtonGlyph(FState);
  end;
end;

procedure TMySpeedButton.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  { Don't draw a border if DragMode <> dmAutomatic since this button is meant to
    be used as a dock client. }
  if FFlat and not FMouseInControl and Enabled and (DragMode <> dmAutomatic)
    and (GetCapture = 0) then
  begin
    FMouseInControl := True;
    Font.Color:= FInColor;
    Repaint;
  end;
end;

procedure TMySpeedButton.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if FFlat and FMouseInControl and Enabled and not FDragging then
  begin
    FMouseInControl := False;
    Font.Color:= FLeaveColor;
    Invalidate;
  end;
end;

procedure TMySpeedButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);

  procedure CopyImage(ImageList: TCustomImageList; Index: Integer);
  begin
    with Glyph do
    begin
      Width := ImageList.Width;
      Height := ImageList.Height;
      Canvas.Brush.Color := clFuchsia;//! for lack of a better color
      Canvas.FillRect(Rect(0,0, Width, Height));
      ImageList.Draw(Canvas, 0, 0, Index);
    end;
  end;

begin
  inherited ActionChange(Sender, CheckDefaults);
  if Sender is TCustomAction then
    with TCustomAction(Sender) do
    begin
      { Copy image from action's imagelist }
      if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and
        (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
        CopyImage(ActionList.Images, ImageIndex);
    end;
end;

procedure TMySpeedButton.SetInColor(clr: TColor);
begin
  FInColor:= clr;
end;

procedure TMySpeedButton.SetLeaveColor(clr: TColor);
begin
  FLeaveColor:= clr;
end;