unit tflatbuttonunit.txt

Librery to VCL_FREESTYLE

  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 TFlatButton.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; 
      FMouseInControl := 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 TFlatButton.Click; 
begin 
  if Parent <> nil then 
    GetParentForm(self).ModalResult := FModalResult; 
  inherited Click; 
end;    
 
function TFlatButton.GetPalette: HPALETTE; 
begin 
  Result := FGlyph.Palette; 
end; 
 
procedure TFlatButton.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 TFlatButton.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 TFlatButton.SetAdvColors (Index: Integer; Value: TAdvColors); 
begin 
  case Index of 
    0: FAdvColorFocused := Value; 
    1: FAdvColorDown := Value; 
    2: FAdvColorBorder := Value; 
  end; 
  CalcAdvColors; 
  Invalidate; 
end; 
 
procedure TFlatButton.SetUseAdvColors (Value: Boolean); 
begin 
  if Value <> FUseAdvColors then 
  begin 
    FUseAdvColors := Value; 
    ParentColor := Value; 
    CalcAdvColors; 
    Invalidate; 
  end; 
end; 
 
procedure TFlatButton.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 TFlatButton.SetNumGlyphs (value: TNumGlyphs); 
begin 
  if value <> FNumGlyphs then 
  begin 
    FNumGlyphs := value; 
    Invalidate; 
  end; 
end; 
 
procedure TFlatButton.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 TFlatButton.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 TFlatButton.SetGroupIndex (Value: Integer); 
begin 
  if FGroupIndex <> Value then 
  begin 
    FGroupIndex := Value; 
    UpdateExclusive; 
  end; 
end; 
 
procedure TFlatButton.SetLayout (Value: TButtonLayout); 
begin 
  if FLayout <> Value then 
  begin 
    FLayout := Value; 
    Invalidate; 
  end; 
end; 
 
procedure TFlatButton.SetMargin (Value: Integer); 
begin 
  if (Value <> FMargin) and (Value >= -1) then 
  begin 
    FMargin := Value; 
    Invalidate; 
  end; 
end; 
 
procedure TFlatButton.SetSpacing (Value: Integer); 
begin 
  if Value <> FSpacing then 
  begin 
    FSpacing := Value; 
    Invalidate; 
  end; 
end; 
 
procedure TFlatButton.SetAllowAllUp (Value: Boolean); 
begin 
  if FAllowAllUp <> Value then 
  begin 
    FAllowAllUp := Value; 
    UpdateExclusive; 
  end; 
end; 
 
procedure TFlatButton.WMLButtonDblClk (var Message: TWMLButtonDown); 
begin 
  inherited; 
  if FDown then DblClick; 
end; 
 
procedure TFlatButton.CMEnabledChanged (var Message: TMessage); 
begin 
  inherited; 
  if not Enabled then 
  begin 
    FMouseInControl := False; 
    FState := bsDisabled; 
    RemoveMouseTimer; 
  end; 
  UpdateTracking; 
  Invalidate; 
end; 
 
procedure TFlatButton.CMButtonPressed (var Message: TMessage); 
var 
  Sender: TFlatButton; 
begin 
  if Message.WParam = FGroupIndex then 
  begin 
    Sender := TFlatButton(Message.LParam); 
    if Sender <> Self then 
    begin 
      if Sender.Down and FDown then 
      begin 
        FDown := False; 
        FState := bsUp; 
        Invalidate; 
      end; 
      FAllowAllUp := Sender.AllowAllUp; 
    end; 
  end; 
end; 
 
procedure TFlatButton.CMDialogChar (var Message: TCMDialogChar); 
begin 
  with Message do 
    if IsAccel(CharCode, Caption) and Enabled then 
    begin 
      if GroupIndex <> 0 then 
        SetDown(true); 
      Click; 
      Result := 1; 
    end; 
end; 
 
procedure TFlatButton.CMFontChanged (var Message: TMessage); 
begin 
  Invalidate; 
end; 
 
procedure TFlatButton.CMTextChanged (var Message: TMessage); 
begin 
  Invalidate; 
end; 
 
procedure TFlatButton.CMSysColorChange (var Message: TMessage); 
begin 
  if FUseAdvColors then 
  begin 
    ParentColor := True; 
    CalcAdvColors; 
  end; 
  Invalidate; 
end; 
 
procedure TFlatButton.CMParentColorChanged (var Message: TWMNoParams); 
begin 
  inherited; 
  if FUseAdvColors then 
  begin 
    ParentColor := True; 
    CalcAdvColors; 
  end; 
  Invalidate; 
end; 
 
procedure TFlatButton.MouseEnter; 
begin 
  if Enabled and not FMouseInControl then 
  begin 
    FMouseInControl := True; 
    Invalidate; 
  end; 
end; 
 
procedure TFlatButton.MouseLeave; 
begin 
  if Enabled and FMouseInControl and not FDragging then 
  begin 
    FMouseInControl := False; 
    RemoveMouseTimer; 
    Invalidate; 
  end; 
end; 
 
procedure TFlatButton.MouseTimerHandler (Sender: TObject); 
var 
  P: TPoint; 
begin 
  GetCursorPos (P); 
  if FindDragTarget(P, True) <> Self then 
    MouseLeave; 
end; 
 
procedure TFlatButton.RemoveMouseTimer; 
begin 
  if MouseInControl = Self then 
  begin 
    MouseTimer.Enabled := False; 
    MouseInControl := nil; 
  end; 
end; 
 
procedure TFlatButton.SetDefault(const Value: Boolean); 
var 
 {$IFDEF DFS_COMPILER_2} 
  Form: TForm; 
 {$ELSE} 
  Form: TCustomForm; 
 {$ENDIF} 
begin 
  FDefault := Value; 
  if HandleAllocated then 
  begin 
    Form := GetParentForm(Self); 
    if Form <> nil then 
      Form.Perform(CM_FOCUSCHANGED, 0, Longint(Form.ActiveControl)); 
  end; 
  Invalidate; 
end; 
 
procedure TFlatButton.WMKillFocus(var Message: TWMKillFocus); 
begin 
  inherited; 
  MouseLeave; 
end; 
 
procedure TFlatButton.WMSetFocus(var Message: TWMSetFocus); 
begin 
  inherited; 
  if Enabled then 
  begin 
    FMouseInControl := True; 
    Invalidate; 
  end; 
end; 
 
procedure TFlatButton.WMKeyDown(var Message: TWMKeyDown); 
begin 
  if Message.CharCode = VK_SPACE then 
  begin 
    if GroupIndex = 0 then 
      FState := bsDown 
    else 
      SetDown(true); 
    Invalidate; 
  end; 
end; 
 
procedure TFlatButton.WMKeyUp(var Message: TWMKeyUp); 
begin 
  if Message.CharCode = VK_SPACE then 
  begin 
    if GroupIndex = 0 then 
      FState := bsUp 
    else 
      SetDown(false); 
    Click; 
    Invalidate; 
  end; 
end; 
 
procedure TFlatButton.SetTransparent(const Value: TTransparentMode); 
begin 
  FTransparent := Value; 
  Invalidate; 
end; 
 
procedure TFlatButton.WMMove(var Message: TWMMove); 
begin 
  inherited; 
  if not (FTransparent = tmNone) then 
    Invalidate; 
end; 
 
procedure TFlatButton.WMSize(var Message: TWMSize); 
begin 
  inherited; 
  if not (FTransparent = tmNone) then 
    Invalidate; 
end; 
 
procedure TFlatButton.CMMouseEnter(var Message: TMessage); 
begin 
  inherited; 
  if Assigned(FOnMouseEnter) then 
    FOnMouseEnter(Self); 
end; 
 
procedure TFlatButton.CMMouseLeave(var Message: TMessage); 
begin 
  inherited; 
  if Assigned(FOnMouseLeave) then 
    FOnMouseLeave(Self); 
end; 
 
end.