sctctrl.pas

suite component ace report

    procedure SetCenter( C: Boolean);
    procedure SetPicture(Value: TPicture);
  public
    constructor Create(AOwner: Tcomponent); override;
    destructor Destroy; override;
    procedure SetVariable(Variable: TSctvar);
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;

    procedure UpdateImage;
    procedure StartPrint; override;
    function PrintHeight( oPage: TComponent; Space, Taking: Integer): Integer; override;
    function SpendHeight(oPage: TComponent; Space: Integer): Integer; override;

    procedure PrintLabel( AceCanvas: TAceCanvas; Rect: TRect; Space: Integer); override;
    procedure PrintRtf(oPage: TWinControl; rtf: TSctRtfFile; PrintRow: Integer); override;
    procedure PrintTab(oPage: TWinControl; rtf: TSctRtfFile; PrintRow: Integer); override;

    property AlignVertical;
    property AlignHorizontal;
  published
    property Picture: TPicture read FPicture write SetPicture;
    property Center: Boolean read FCenter write SetCenter default False;
    property Variable: TSctvar read FVariable write SetVariable;
    property Stretch;
    property BorderType;
  end;


{ TSctVerticalDivider }
  TSctVerticalDivider = class(TSctLabel)
  private
    FDividerWidth: Integer;
    FDividerColor: TColor;
  protected
    procedure SetDividerColor(c: TColor);
    procedure SetDividerWidth(w: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure PrintLabel( AceCanvas: TAceCanvas; Rect: TRect; Space: Integer); override;
    function PrintHeight( oPage: TComponent; Space, Taking: Integer): Integer; override;
    function SpendHeight(oPage: TComponent; Space: Integer): Integer; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure PrintRtf(oPage: TWinControl; rtf: TSctRtfFile; PrintRow: Integer); override;
    procedure PrintTab(oPage: TWinControl; rtf: TSctRtfFile; PrintRow: Integer); override;
  published
    property Color;
    property ParentColor;
    property DividerWidth: Integer read FDividerWidth write SetDividerWidth default 1;
    property DividerColor: TColor read FDividerColor write SetDividerColor default clBlack;
  end;

{ TSctCustomLabel }
  TSctCustomLabel = class(TSctLabel)
  private
    FOnDraw: TSctOnDrawEvent;
  protected
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure PrintRtf(oPage: TWinControl; rtf: TSctRtfFile; PrintRow: Integer); override;
    procedure PrintTab(oPage: TWinControl; rtf: TSctRtfFile; PrintRow: Integer); override;
    procedure PrintLabel( AceCanvas: TAceCanvas; Rect: TRect; Space: Integer); override;
    procedure DrawLabel( AceCanvas: TAceCanvas; Rect: TRect; Space: Integer); virtual;
  published
    property OnDraw: TSctOnDrawEvent read FOnDraw  write FOnDraw;
    property Transparent;
    property BorderType;
    property Shade;
  end;

  procedure SctDrawBorder(AceCanvas: TAceCanvas; Rect: TRect; BorderType: TSctBorderType; Painting: Boolean);

implementation

uses sctrep, mask, sctbtn, acectrl;


  function getspot(l: TSctLabel): Integer;
  begin
    case l.AlignHorizontal of
      laLeft: result := l.left;
      laRight: result := l.left + l.width;
      laCenter: result := l.left + (l.width div 2);
    else
      result := 0;
    end;
  end;
  function getAlign(l: TSctLabel): TSctTabAlignment;
  begin
    case l.AlignHorizontal of
      laLeft: result := taLeft;
      laRight: result := taRight;
      laCenter: result := taCenter;
    else
      result := taLeft;
    end;
  end;

procedure SctDrawBorder(AceCanvas: TAceCanvas; Rect: TRect; BorderType: TSctBorderType; Painting: Boolean);
var
  R: TRect;
  BW: Integer;

  procedure MakeRect;
  begin
    AceCanvas.Brush.Color := clBlack;
    AceCanvas.Brush.Style := bsSolid;

    if BorderType = btSingle then
    begin
{      R := Bounds(Rect.Left, Rect.Top, Rect.Right - Rect.Left, BW);
      AceCanvas.FillRect(R);
      R := Bounds(Rect.Right - BW, Rect.Top, BW, Rect.Bottom - Rect.Top);
      AceCanvas.FillRect(R);
      R := Bounds(Rect.Left, Rect.Top, BW, Rect.Bottom - Rect.Top);
      AceCanvas.FillRect(R);
 }

      R := Bounds(Rect.Left, Rect.Top, Rect.Right - Rect.Left + BW, BW);
      AceCanvas.FillRect(R);
      R := Bounds(Rect.Right, Rect.Top, BW, Rect.Bottom - Rect.Top);
      AceCanvas.FillRect(R);
      R := Bounds(Rect.Left, Rect.Top, BW, Rect.Bottom - Rect.Top);
      AceCanvas.FillRect(R);

    end;

    if (BorderType = btSingle) or (BorderType = btUnderLine) then
    begin
      R := Bounds(Rect.Left, Rect.Bottom, Rect.Right - Rect.Left + BW, BW);
      AceCanvas.FillRect(R);
    end;

    AceCanvas.Brush.Style := bsClear;

  end;
begin
  BW := 1;

  if Painting And (BorderType <> btSingle) then
  begin
    AceCanvas.Pen.Width := 1;
    AceCanvas.Pen.Mode := pmBlack;
    if (BorderType = btSingle) then AceCanvas.Pen.Style := psSolid
    else AceCanvas.Pen.Style := psDot;
    AceCanvas.Brush.Style := bsClear;

    with AceCanvas do
    begin
      MoveTo(Rect.Left,Rect.Top);
      LineTo(Rect.Right, Rect.Top);
      LineTo(Rect.Right, Rect.Bottom);
      LineTo(Rect.Left, Rect.Bottom);
      LineTo(Rect.Left, Rect.Top);
    end;
  end;
  if (BorderType = btSingle) or (BorderType = btUnderLine) then MakeRect;

end;



{ TSctLabel }
constructor TSctLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csOpaque,csSetCaption];
  FClipType := ctDefault;
  FVerticalAlign := laBottom;
  FHorizontalAlign := laLeft;
  FBrush := TBrush.Create;
  FBrush.OnChange := LabelChanged;
  FPen := TPen.Create;
  FPen.OnChange := LabelChanged;
  FBorderPen := TPen.Create;
  FBorderPen.OnChange := LabelChanged;

  FRtfPrint := True;
  FRow := 0;

  FWrapText := False;
  FStretch := False;
  FRotateFont := 0;
  FShade := spNone;

  FBrushSet := TBrush.Create;
  FPenSet := TPen.Create;
  FPainting := False;
  FBorderMargin := 2;

  Width := 65;
  Height := 17;
  FAutoSize := False;

end;

destructor TSctLabel.Destroy;
begin
  if FBrush <> nil Then FBrush.Free;
  if FPen <> nil Then FPen.Free;
  if FBorderPen <> nil then FBorderPen.Free;
  if FBrushSet <> nil then FBrushSet.Free;
  if FPenSet <> nil then FPenSet.free;
  inherited Destroy;
end;

procedure TSctLabel.MouseMovement(var Message: TCMDesignHitTest);
var
  report: TSctReport;
begin
  inherited;
  if Page <> nil then
  begin
    Report := TSctReport(Page.Parent);
    Report.TopRuler.UpdateHair(Left + Message.xPos);
    Report.LeftRuler.UpdateHair(TSctBand(Parent).top + top + Message.yPos);
  end;
end;

procedure TSctLabel.AdjustBounds;
var
  h,w: Integer;
  Metrics: TTextMetric;
begin
  if not (csReading in ComponentState) and FAutoSize then
  begin
    if (csDesigning in ComponentState) then
    begin
      if (Page <> nil) And Not TSctGroupPage(Page).Printing then
      begin
        Canvas.Font := Font;
        GetTextMetrics( Canvas.Handle, Metrics );

        h := (FBorderMargin * 2) + abs( Metrics.tmHeight );
        w := (FBorderMargin * 2) + Canvas.TextWidth(Caption)+Metrics.tmMaxCharWidth;
        SetBounds(Left, Top, w, h);
      end;

    end;
  end;
end;

procedure TSctLabel.SetAutoSize(Value: Boolean);
begin
  if FAutoSize <> Value then
  begin
    FAutoSize := Value;
    AdjustBounds;
  end;
end;

function TSctLabel.GetTransparent: Boolean;
begin
  Result := not (csOpaque in ControlStyle);
end;

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

procedure TSctLabel.CMTextChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
  AdjustBounds;
end;

procedure TSctLabel.CMFontChanged(var Message: TMessage);
begin
  inherited;
  AdjustBounds;
end;


procedure TSctLabel.Loaded;
var
  h: Integer;
begin
  { if the font was created at a different font than it is
    read in from the pixelsPerInch is wrong because that is
    just using the current screen pixelsPerInch.  Which results
    in fonts being the wrong point size than that of which it
    was created because only the height is saved with the font.
  }
  if Not (csDesigning in ComponentState) then
  begin
    if PixelsPerInch <> Font.PixelsPerInch then
    begin
      if Not ParentFont then
      begin
        h := Font.Height;
        { Set correct PixelsPerInch }
        Font.PixelsPerInch := PixelsPerInch;
        { This will create a new font resource }
        Font.Height := h;
        { This will reset all the child fonts }
        Perform(CM_FONTCHANGED, 0, 0);
      end;  
    end;
  end;
end;

procedure TSctLabel.BeforePrint;
begin
  try
    if Assigned(FOnBeforePrint) then FOnBeforePrint(Self)
  except
    Application.HandleException(Self);
  end;
end;

procedure TSctLabel.AfterPrint;
begin
  try
    if Assigned(FOnAfterPrint) then FOnAfterPrint(Self)
  except
    Application.HandleException(Self);
  end;
end;

procedure TSctLabel.LabelChanged(Sender: TObject);
begin
  Invalidate;
end;

procedure TSctLabel.SetRotateFont(rotate: TSctRotateFont);
begin
  if rotate <> FRotateFont then
  begin
    FRotateFont := rotate;
    Invalidate;
  end;
end;

procedure TSctLabel.SetShade(shadepercent: TAceShadePercent);
begin
  if shadepercent <> FShade then
  begin
    FShade := shadepercent;
    if FShade <> spNone then Transparent := False;
    Invalidate;
  end;
end;

procedure TSctLabel.SetBorderMargin(bm: Integer);
begin
  if FBorderMargin <> bm then
  begin
    FBorderMargin := bm;
    if FAutoSize then AdjustBounds
    else Invalidate;
  end;
end;

function TSctLabel.GetPrintOk: Boolean;
begin
  if EndPrint then Result := False
  else
  begin
    if Assigned(FLabelPrintWhen) then
    begin
      try
{$ifdef SCT_OLDEVENT}
        result := FLabelPrintWhen(self);
{$else}
        Result := False;
        FLabelPrintWhen(self, result);
{$endif}
      except
        result := False;
      end;
    end else result := True;
  end;
end;

function TSctLabel.getppi: Integer;
begin
  if Parent <> nil Then
  begin
    if Parent is TSctBand Then result := TSctBand(Parent).PixelsPerInch
    else if Parent is TSctPage Then result := TSctBand(Parent).PixelsPerInch
    else result := screen.PixelsPerInch;
  end else result := screen.PixelsPerInch;
end;

procedure TSctLabel.SetBrush(Value: TBrush);
begin
  FBrush.Assign(Value);
end;

procedure TSctLabel.SetPen(Value: TPen);
begin
  FPen.Assign(Value);
end;

function TSctLabel.getdisplayText: string;
begin
  result := Caption;
end;

function TSctLabel.GetClipRect: Boolean;
begin
  if (ClipType = ctClip) Or
        ((ClipType = ctDefault) And TSctPage(Page).ClipLabels) Then result := True
  else Result := False;
end;

procedure TSctLabel.SetVerticalAlign( va: TSctVerticalAlign);
begin
  if FVerticalAlign <> va Then
  begin
    FVerticalAlign := va;
    Invalidate;
  end;
end;

procedure TSctLabel.SetHorizontalAlign( ha: TSctHorizontalAlign);
begin
  if FHorizontalAlign <> ha Then
  begin
    FHorizontalAlign := ha;
    Invalidate;
  end;
end;

procedure TSctLabel.SetBorderType( BType: TSctBorderType);
begin
  if FBorderType <> BType Then
  begin
    FBorderType := BType;
    Invalidate;
  end;
end;

procedure TSctLabel.SetWrapText( W: Boolean);
begin
  if FWrapText <> W Then
  begin
    FWrapText := W;
    if Not (csLoading in ComponentState) then
      if FWrapText then FStretch := True;
    Invalidate;
  end;
end;

procedure TSctLabel.SetStretch( S: Boolean);
begin
  if FStretch <> S Then
  begin
    FStretch := S;
    Invalidate;
  end;
end;

procedure TSctLabel.Paint;
var
  AceCanvas: TAceCanvas;
  R: TRect;
begin
  FPainting := True;
  AceCanvas := TAceCanvas.Create;
  try
    AceCanvas.Handle := Canvas.Handle;