rm_rrect.pas

report machine 2.3 功能强大

end;

procedure TRMRoundRectView.CalcGaps;
begin
	LeftFrame.Style := LeftFrame.Style and not rmftDouble;
	RightFrame.Style := RightFrame.Style and not rmftDouble;
	TopFrame.Style := TopFrame.Style and not rmftDouble;
	BottomFrame.Style := BottomFrame.Style and not rmftDouble;
  inherited CalcGaps;

  if Cadre.wShadow <> -99 then
  begin
    DRect1.Right := DRect1.Right - Cadre.wShadow;
    DRect1.Bottom := DRect1.Bottom - Cadre.wShadow;
  end;
  InflateRect(DRect1, -(Cadre.wCurve div 4), -(Cadre.wCurve div 4));
end;

procedure TRMRoundRectView.ShowBackGround;
var
  OldDRect: TRect;
  OldFill: TColor;
begin
  if (DocMode <> dmDesigning) or (Cadre.wShadow = -99) then Exit;
  OldDRect := DRect;
  OldFill := FillColor;
  DRect := Rect(x, y, x + dx + 1, y + dy + 1);
  FillColor := clWhite;
  inherited;
  DRect := OldDRect;
  FillColor := OldFill;
end;

procedure TRMRoundRectView.ShowFrame;
var
  FSW, FCU: Integer;

  procedure Line(x, y, dx, dy: Integer);
  begin
    Canvas.MoveTo(x, y);
    Canvas.LineTo(x + dx, y + dy);
  end;

  procedure FrameLine(i: Integer);
  begin
    Canvas.Pen.Width := Round(Prop['FrameWidth']);
    case i of
      0: Line(x + dx, y, 0, dy);
      1: Line(x, y, 0, dy);
      2: Line(x, y + dy, dx, 0);
      3: Line(x, y, dx, 0);
    end;
  end;

begin
  if DisableDrawing then Exit;
  with Canvas do
  begin
    if Cadre.wShadow = -99 then
    begin
      if Cadre.wCurve < 0 then
        Cadre.wCurve := 0;
      PaintGrad(Canvas, X, Y, X + DX, Y + DY, FillColor, Cadre.SdColor, TRMGradientStyle(Cadre.wCurve));
      Pen.Width := Round(Prop['FrameWidth']);
      Pen.Color := Prop['FrameColor'];

      if RightFrame.Visible then FrameLine(0);
      if LeftFrame.Visible then FrameLine(1);
      if BottomFrame.Visible then FrameLine(2);
      if TopFrame.Visible then FrameLine(3);

      Exit;
    end;

    Pen.Style := psSolid;
    Brush.Style := bsClear;
    Pen.Color := Cadre.SdColor;
    Pen.Width := Round(Prop['FrameWidth']);
    Brush.Color := Cadre.SdColor;

    FSW := Round(Cadre.wShadow * ScaleY);
    FCU := Round(Cadre.wCurve * ScaleY);

    if Cadre.sCurve then
      RoundRect(x + FSW, y + FSW, x + dx + 1, y + dy + 1, FCu, Fcu)
    else
      Rectangle(x + FSW, y + FSW, x + dx + 1, y + dy + 1);

    Pen.Width := Round(Prop['FrameWidth']);
    Cadre.Cadre := ((Prop['FrameTyp'] and $F) = $F);

    if not Cadre.Cadre then
      Pen.Color := FillColor
    else
      Pen.Color := Prop['FrameColor'];

    if FillColor = clNone then
      Brush.Color := clWhite
    else
      Brush.Color := FillColor;
    if Cadre.sCurve then
      RoundRect(x, y, x + dx + 1 - FSW, y + dy + 1 - FSW, FCu, Fcu)
    else
      Rectangle(x, y, x + dx + 1 - FSW, y + dy + 1 - FSW);
  end;
end;

procedure TRMRoundRectView.ShowEditor;
var
  tmpForm: TRMRoundRectForm;
begin
  tmpForm := TRMRoundRectForm.Create(nil);
  try
    with tmpForm do
    begin
      FView := Self;
      M1.Lines.Assign(Memo);
      shWidth.Text := IntToStr(Cadre.wShadow);
      if Cadre.wShadow <> -99 then
      begin
        cbGradian.Checked := False;
        ShadowColor := Cadre.sdColor;
        NormalColor := FillColor;
        cmShadow.Checked := Cadre.sCurve;
        sCurve.Text := IntToStr(Cadre.wCurve);
      end
      else
      begin
        cbGradian.Checked := True;
        ShadowColor := Cadre.sdColor;
        NormalColor := FillColor;
        if Cadre.wCurve > cbStyle.Items.Count - 1 then
          Cadre.wCurve := 0;
        cbStyle.ItemIndex := Cadre.wCurve;
      end;

      if ShowModal = mrOk then
      begin
        RMDesigner.BeforeChange;
        Memo.Assign(M1.Lines);
        Cadre.sdColor := ShadowColor;
        FillColor := NormalColor;
        Cadre.sCurve := cmShadow.Checked;
        try
          Cadre.wShadow := StrToInt(shWidth.Text);
        except
          Cadre.wShadow := 6;
        end;

        try
          Cadre.wCurve := StrToInt(sCurve.Text);
          if Cadre.wShadow = -99 then
            Cadre.wCurve := cbStyle.ItemIndex;
        except
          Cadre.wCurve := 10;
        end;
        RMDesigner.AfterChange;
      end;
    end;
  finally
    tmpForm.Free;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMRoundRectForm}

procedure TRMRoundRectForm.Localize;
var
  i: Integer;
  s: string;
begin
	Font.Name := RMLoadStr(SRMDefaultFontName);
  Font.Size := StrToInt(RMLoadStr(SRMDefaultFontSize));
  Font.Charset := StrToInt(RMLoadStr(SCharset));

  Caption := RMLoadStr(rmRes + 670);
  LblSample.Caption := RMLoadStr(rmRes + 671);
  btnExpr.Caption := RMLoadStr(rmRes + 673);
  cbGradian.Caption := RMLoadStr(rmRes + 674);
  lblSWidth.Caption := RMLoadStr(rmRes + 675);
  LblSColor.Caption := RMLoadStr(rmRes + 676);
  cmShadow.Caption := RMLoadStr(rmRes + 677);
  Label1.Caption := RMLoadStr(rmRes + 679);
  Label2.Caption := RMLoadStr(rmRes + 680);
  Label3.Caption := RMLoadStr(rmRes + 681);
  bColor.Hint := RMLoadStr(rmRes + 683);
  bColor2.Hint := bColor.Hint;
  bColor3.Hint := bColor3.Hint;
  BOk.Caption := RMLoadStr(SOk);
  bCancel.Caption := RMLoadStr(SCancel);
  cbCadre.Caption := RMLoadStr(rmRes + 684);

  cbStyle.Items.CommaText := RMLoadStr(rmRes + 682);
  for i := 0 to cbStyle.Items.Count - 1 do
  begin
    s := cbStyle.Items.Strings[i];
    if Pos('_', s) <> 0 then
    begin
      s[Pos('_', s)] := ' ';
      cbStyle.Items.Strings[i] := s;
    end;
  end;
end;

procedure TRMRoundRectForm.FormCreate(Sender: TObject);
var
  i: Integer;
  s: string;
begin
  Localize;
  cbStyle.Items.CommaText := SRrectType;
  for i := 0 to cbStyle.Items.Count - 1 do
  begin
    s := cbStyle.Items.Strings[i];
    if Pos('_', s) <> 0 then
    begin
      s[Pos('_', s)] := ' ';
      cbStyle.Items.Strings[i] := s;
    end;
  end;

  panGrad.Left := panCurve.Left;
  panGrad.Top := panCurve.Top;
  panGrad.Visible := False;
end;

procedure TRMRoundRectForm.btnExprClick(Sender: TObject);
var
  s: string;
begin
  s := RMDesigner.InsertExpression;
  if s <> '' then
    M1.SelText := s;
  M1.SetFocus;
end;

procedure TRMRoundRectForm.ChgColorButton(S: TObject; C: TColor);
var
  BM: TBitmap;
  Bc: TImage;
begin
  BM := TBitmap.Create;
  Bc := S as TImage;
  BM.Height := bC.Height;
  BM.Width := bC.Width;

  with BM.Canvas do
  begin
    Pen.Color := clBlack;
    Brush.Color := C;
    Rectangle(0, 0, bC.Width, bC.Height);
  end;
  if Bc.Tag = 0 then
    ShadowColor := C else
    NormalColor := C;

  bC.Picture.Assign(BM);
  BM.Free;
end;

procedure TRMRoundRectForm.UpdateSample;
var
  CC: TCanvas;
  FsW: Integer;
  FCu: Integer;
  BM: TBitmap;
begin
  try
    FsW := StrToInt(ShWidth.Text);
  except
    FsW := 10;
  end;

  try
    FCu := StrToInt(SCurve.Text);
  except
    FCu := 10;
  end;

  BM := TBitmap.Create;
  BM.Height := imgSample.Height;
  BM.Width := imgSample.Width;

  CC := BM.Canvas;

  if cbGradian.Checked then
  begin
    FsW := cbStyle.ItemIndex;
    if FsW < 0 then FsW := 0;
    PaintGrad(CC, 0, 0, bm.Width, bm.Height, NormalColor, ShadowColor,
      TRMGradientStyle(FsW));
  end
  else
  begin
    // R閕nitialise le panel
    CC.Pen.Color := clBtnFace;
    CC.Brush.Color := clBtnFace;
    CC.Rectangle(0, 0, imgSample.Width, imgSample.Height);

    // Trace l'ombre
    CC.Pen.Color := ShadowColor;
    CC.Brush.Color := ShadowColor;

    if cmShadow.Checked then
      CC.RoundRect(0 + FSW, 0 + FSW, imgSample.Width, imgSample.Height,
        FCu, FCu)
    else
      CC.Rectangle(0 + FSW, 0 + FSW, imgSample.Width, imgSample.Height);

    // Trace la zone de texte
    if not cbCadre.Checked then
      CC.Pen.Color := NormalColor else
      CC.Pen.Color := clBlack; // Trace le cadre

    CC.Brush.Color := NormalColor;
    if cmShadow.Checked then
      CC.RoundRect(0, 0, imgSample.Width - FSW, imgSample.Height - FSW,
        FCu, FCu)
    else
      CC.Rectangle(0, 0, imgSample.Width - FSW, imgSample.Height - FSW);
  end;

  imgSample.Picture.Assign(BM);
  BM.Free;
end;

procedure TRMRoundRectForm.bColorClick(Sender: TObject);
begin
  ColorDlg.Color := ShadowColor;
  if ColorDlg.Execute then
  begin
    ChgColorButton(Sender, ColorDlg.Color);
    UpdateSample;
  end;
end;

procedure TRMRoundRectForm.ShWidthChange(Sender: TObject);
begin
  if Sender is TEdit then
    if TEdit(Sender).Text = '' then Exit;
  UpdateSample;
end;

procedure TRMRoundRectForm.cbCadreClick(Sender: TObject);
begin
  UpdateSample;
end;

procedure TRMRoundRectForm.cmShadowClick(Sender: TObject);
begin
  UpdateSample;
end;

procedure TRMRoundRectForm.cbGradianClick(Sender: TObject);
begin
  panGrad.Visible := cbGradian.Checked;
  panCurve.Visible := not panGrad.Visible;
  if panGrad.Visible then
  begin
    shWidth.Text := '-99';
    sCurve.Text := '0';
    cbStyle.ItemIndex := 0;
  end
  else
  begin
    shWidth.Text := '10';
    sCurve.Text := '10';
  end;
end;

procedure TRMRoundRectForm.M1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = vk_Insert) and (Shift = []) then btnExprClick(Self);
  if Key = vk_Escape then ModalResult := mrCancel;
end;

procedure TRMRoundRectForm.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = vk_Return) and (ssCtrl in Shift) then
  begin
    ModalResult := mrOk;
    Key := 0;
  end;
end;

procedure TRMRoundRectForm.FormShow(Sender: TObject);
begin
  M1.SetFocus;
  UpdateSample;
  ChgColorButton(bColor, ShadowColor);
  ChgColorButton(bColor2, NormalColor);
  ChgColorButton(bColor3, ShadowColor);
end;

initialization
  RMRegisterObjectByRes(TRMRoundRectView, 'RM_RRECTOBJECT', RMLoadStr(SInsRoundRect), TRMRoundRectForm);

finalization

end.