fr_ctrls.pas

FreeReport 2.34 consists of the report engine, designer and previewer, with capabilities comparable

  R := Rect(0, 0, Width, Height);
  if Canvas.Handle <> CacheCanvas.Handle then
    Canvas.CopyRect(R, CacheCanvas, R);

  if FFlat and (FState = fbsUp) and (csDesigning in ComponentState) then
    Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
  FState := AState;
end;

procedure TfrSpeedButton.UpdateTracking;
var
  P: TPoint;
begin
  if FFlat then
  begin
    GetCursorPos(P);
    FMouseInControl := Enabled and (FindDragTarget(P, True) = Self);
  end;
end;

procedure TfrSpeedButton.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 := fbsDown;
      Repaint;
    end;
    FDragging := True;
  end;
end;

procedure TfrSpeedButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewState: TfrButtonState;
begin
  inherited MouseMove(Shift, X, Y);
  if FDragging then
  begin
    if not FDown then NewState := fbsUp
    else NewState := fbsExclusive;
    if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
      if FDown then NewState := fbsExclusive else NewState := fbsDown;
    if NewState <> FState then
    begin
      FState := NewState;
      Repaint;
    end;
  end;
end;

procedure TfrSpeedButton.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 := fbsUp;
      FMouseInControl := False;
      if not (FState in [fbsExclusive, fbsDown]) then Repaint;
    end
    else
      if DoClick then SetDown(not FDown)
      else
      begin
        if FDown then FState := fbsExclusive;
        Repaint;
      end;
    UpdateTracking;
    Invalidate;
    if DoClick then Click;
  end;
end;

procedure TfrSpeedButton.Click;
begin
  inherited Click;
end;

procedure TfrSpeedButton.DrawGlyph(Canvas:TCanvas; X,Y:Integer; Enabled:Boolean);
const
  NewState: array[Boolean] of TfrButtonState = (fbsDisabled, fbsUp);
begin
  TButtonGlyph(FGlyph).DrawButtonGlyph(Canvas, X, Y, NewState[Enabled], False);
end;

function TfrSpeedButton.GetGlyph: TBitmap;
begin
  Result := TButtonGlyph(FGlyph).Glyph;
end;

procedure TfrSpeedButton.SetGlyph(Value: TBitmap);
begin
  TButtonGlyph(FGlyph).Glyph := Value;
  Invalidate;
end;

function TfrSpeedButton.GetNumGlyphs: TNumGlyphs;
begin
  Result := TButtonGlyph(FGlyph).NumGlyphs;
end;

procedure TfrSpeedButton.SetNumGlyphs(Value: TNumGlyphs);
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 TfrSpeedButton.GlyphChanged(Sender: TObject);
begin
  Invalidate;
end;

procedure TfrSpeedButton.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 TfrSpeedButton.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 FState := fbsExclusive
    else FState := fbsUp;
    Invalidate;
    if Value then UpdateExclusive;
  end;
end;

procedure TfrSpeedButton.SetFlat(Value: Boolean);
begin
  if Value <> FFlat then
  begin
    FFlat := Value;
    Invalidate;
  end;
end;

procedure TfrSpeedButton.SetGroupIndex(Value: Integer);
begin
  if FGroupIndex <> Value then
  begin
    FGroupIndex := Value;
    UpdateExclusive;
  end;
end;

procedure TfrSpeedButton.SetLayout(Value: TButtonLayout);
begin
  if FLayout <> Value then
  begin
    FLayout := Value;
    Invalidate;
  end;
end;

procedure TfrSpeedButton.SetAllowAllUp(Value: Boolean);
begin
  if FAllowAllUp <> Value then
  begin
    FAllowAllUp := Value;
    UpdateExclusive;
  end;
end;

procedure TfrSpeedButton.WMLButtonDblClk(var Message: TWMLButtonDown);
begin
  inherited;
  if FDown then DblClick;
end;

procedure TfrSpeedButton.CMEnabledChanged(var Message: TMessage);
const
  NewState: array[Boolean] of TfrButtonState = (fbsDisabled, fbsUp);
begin
  TButtonGlyph(FGlyph).CreateButtonGlyph(NewState[Enabled]);
  UpdateTracking;
  Invalidate;
end;

procedure TfrSpeedButton.CMButtonPressed(var Message: TMessage);
var
  Sender: TfrSpeedButton;
begin
  if Message.WParam = FGroupIndex then
  begin
    Sender := TfrSpeedButton(Message.LParam);
    if Sender <> Self then
    begin
      if Sender.Down and FDown then
      begin
        FDown := False;
        FState := fbsUp;
        Invalidate;
      end;
      FAllowAllUp := Sender.AllowAllUp;
    end;
  end;
end;

procedure TfrSpeedButton.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(CharCode, Caption) and Enabled then
    begin
      Click;
      Result := 1;
    end else
      inherited;
end;

procedure TfrSpeedButton.CMFontChanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure TfrSpeedButton.CMTextChanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure TfrSpeedButton.CMSysColorChange(var Message: TMessage);
begin
  Invalidate;
end;

procedure TfrSpeedButton.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  if FFlat and (not FMouseInControl) and Enabled then
  begin
    if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
    FMouseInControl := True;
    Invalidate;
  end;
end;

procedure TfrSpeedButton.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if FFlat and FMouseInControl and Enabled then
  begin
    if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
    FMouseInControl := False;
    Invalidate;
  end;
end;

function TfrSpeedButton.GetPalette: HPALETTE;
begin
  Result := Glyph.Palette;
end;

procedure TfrSpeedButton.SetMargin(Value: Integer);
begin
  if (Value <> FMargin) and (Value >= -1) then
  begin
    FMargin := Value;
    Invalidate;
  end;
end;

procedure TfrSpeedButton.SetSpacing(Value: Integer);
begin
  if Value <> FSpacing then
  begin
    FSpacing := Value;
    Invalidate;
  end;
end;

procedure TfrSpeedButton.SetInactiveGrayed(Value: Boolean);
begin
  if Value <> FInactiveGrayed then begin
    FInactiveGrayed := Value;
    Invalidate;
  end;
end;


{ TTBSeparator }

function GetAlign(al:TAlign): TAlign;
begin
  if al in [alLeft, alRight] then
    Result := alTop else
    Result := alLeft;
end;

constructor TfrTBSeparator.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alLeft;
  Width := 8;
  Height := 8;
  FDrawBevel := True;
end;

procedure TfrTBSeparator.SetParent(AParent:TWinControl);
begin
  inherited;
  if not (csDestroying in ComponentState) and (AParent <> nil) then
    Align := GetAlign(AParent.Parent.Align);
end;

procedure TfrTBSeparator.SetDrawBevel(Value: Boolean);
begin
  FDrawBevel := Value;
  Invalidate;
end;

procedure TfrTBSeparator.Paint;
begin
  with Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := clBtnFace;
    Pen.Style := psClear;
    Rectangle(0, 0, Width, Height);
    Pen.Style := psSolid;
    if FDrawBevel then
    case Align of
      alLeft, alRight:
      begin
        Pen.Color := clBtnShadow;
        MoveTo(Width div 2 - 1, 2);
        LineTo(Width div 2 - 1, Height - 2);
        Pen.Color := clBtnHighlight;
        MoveTo(Width div 2, 2);
        LineTo(Width div 2, Height - 2);
      end;
      alTop, alBottom:
      begin
        Pen.Color := clBtnShadow;
        MoveTo(2, Height div 2 - 1);
        LineTo(Width - 2, Height div 2 - 1);
        Pen.Color := clBtnHighlight;
        MoveTo(2, Height div 2);
        LineTo(Width - 2, Height div 2);
      end;
    end;
    if csDesigning in ComponentState then
    begin
      Brush.Style := bsClear;
      Pen.Style := psDot;
      Pen.Color := clBtnShadow;
      Rectangle(0, 0, Width - 1, Height - 1);
    end;
  end;
end;

constructor TfrTBPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alLeft;
  Width := 8;
  Height := 8;
end;

procedure TfrTBPanel.SetParent(AParent:TWinControl);
begin
  inherited;
  if not (csDestroying in ComponentState) and (AParent <> nil) then
    Align := GetAlign(AParent.Parent.Align);
end;

procedure TfrTBPanel.Paint;
begin
  with Canvas do
  begin
    Brush.Color := clBtnFace;
    FillRect(Rect(0, 0, Width, Height));
    if csDesigning in ComponentState then
    begin
      Brush.Style := bsClear;
      Pen.Style := psDot;
      Pen.Color := clBtnShadow;
      Rectangle(0, 0, Width - 1, Height - 1);
    end;
  end;
end;

{ TTBButton }

constructor TfrTBButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alLeft;
  Flat := True;
end;

procedure TfrTBButton.SetParent(AParent:TWinControl);
begin
  inherited;
  if not (csDestroying in ComponentState) and (AParent <> nil) then
    Align := GetAlign(AParent.Parent.Align);
end;



end.