この発言は
#00978　らせん企画      さんのRE:QuickReport 用 斜線コンポーネント
に対するコメントです



QuickReport で斜線を書くコンポーネントです。

らせん企画さんの QRDiagonal を参考に参考しました。




{--------------------------------------------}
{ TQRrect- 斜め線コンポーネント              }
{--------------------------------------------}
unit QRrect;
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
  Quickrpt;

type

{ TQRrectLine }
  TLinePos = (lpLeftTop, lpRightTop, lpLeftBottom, lpRightBottom);
  TQRrectLine = class(TPersistent)
  private
    FVisible: Boolean;
    FPen: TPen;
  Protected

  public
    constructor Create;
    destructor Destroy; override;
    procedure Free;

  published
    property Visible: Boolean read FVisible write FVisible default
True;
    property Pen: TPen read FPen write FPen;
  end;

{ TQRrect}
  TQRrect= class(TQRPrintable)
  private
    { Private 宣言 }
    FPos1, FPos2: TLinePos;
    FInnerPen: TPen;
    FFitToBand: Boolean;
    procedure SetInnerPen(Value: TPen);
    procedure SetFitToBand(Value: Boolean);
    procedure FitIt;
    Procedure SetPos1(pPos: TLinePos);
    Procedure SetPos2(pPos: TLinePos);
    Function SetPoint(pPos: TLinePos; pRect: TRect): TPoint;


  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    procedure Print(OfsX, OfsY: Integer); override;

  published
    property InnerPen: TPen read FInnerPen write SetInnerPen;
    property FitToBand: Boolean read FFitToBand write SetFitToBand;
    Property Pos1: TLinePos Read FPos1 Write SetPos1;
    Property Pos2: TLinePos Read FPos2 Write SetPos2;
  end;

procedure Register;

{=====================================================================
=========}
implementation

{ TQRrectLine }
constructor TQRrectline.Create;
begin
  inherited Create;
  Visible := True;
  FPen := TPen.Create;
  FPen.Width := 2;
   end;

destructor TQRrectLine.Destroy;
begin
  FPen.Free;

  inherited Destroy;
end;

Procedure TQRrect.SetPos1(pPos: TLinePos);
Begin
FPos1 := pPos;
Paint;
End;

Procedure TQRrect.SetPos2(pPos: TLinePos);
Begin
 FPos2 := pPos;
 Paint;
End;

procedure TQRrectLine.Free;
begin
  if Self <> nil then Destroy;
end;

{ TQRrect}
constructor TQRrect.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  Width := 65;
  Height := 65;

  FInnerPen := TPen.Create;
  FInnerPen.Color := clBlack;
  FInnerPen.Width := 1;


end;

destructor TQRrect.Destroy;
begin
  inherited Destroy;
end;


Function TQRrect.SetPoint(pPos: TLinePos; pRect: TRect): TPoint;
Begin
  Case pPos Of   lpRightTop:
  Result := Point(pRect.Right - 1, pRect.Top);
   lpLeftBottom:    Result := Point(pRect.Left, pRect.Bottom - 1);
   lpRightBottom:    Result := Point(pRect.Right - 1, pRect.Bottom -
1);
   Else
    Result := Point(pRect.Left, pRect.Top);
 End;
End;

procedure TQRrect.SetInnerPen(Value: TPen);
begin
  FInnerPen.Assign(Value);
end;

procedure TQRrect.SetFitToBand(Value: Boolean);
begin
  FFitToBand := Value;
  if FitToBand then FitIt;
  Invalidate;
end;

procedure TQRrect.FitIt;
begin
  if FitToBand and (Parent is TQRCustomBand) then
  begin
    Top := 0;
    Left := 0;
    Width := TQRCustomBand(Parent).Width;
    Height := TQRCustomBand(Parent).Height;
  end;
end;

{ 画面表示の為のメソッド }
procedure TQRrect.Paint;
var
  wPos1, wPos2: TPoint;  wRect: TRect;
begin

  with Canvas do
  begin
    Brush.Color := clNone;
    Brush.Style := bsClear;
    Pen := FInnerPen;

    wRect := Rect(0, 0, Width, Height);
    FillRect(wRect);
    wPos1 := SetPoint(FPos1, wRect);
    wPos2 := SetPoint(FPos2, wRect);
    MoveTo(wPos1.x, wPos1.y);
    LineTo(wPos2.x, wPos2.y);
 end;
end;

{ 印刷・プレビューのためのメソッド }
procedure TQRrect.Print(OfsX, OfsY: Integer);
var
  Rect: TRect;
  wPos1, wPos2: TPoint;
  wRect: TRect;
begin
  if Not Enabled then
    Exit;


  with ParentReport.QRPrinter do
  begin
    Rect.Left := XPos(OfsX + Size.Left);
    Rect.Top := YPos(OfsY + Size.Top);
    Rect.Right := XPos(OfsX + Size.Left + Size.Width);
    Rect.Bottom := YPos(OfsY + Size.Top + Size.Height);


    wRect.Left := XPos(OfsX + Size.Left -1   );
    wRect.Top := YPos(OfsY + Size.Top -1);
    wRect.Right := XPos(OfsX + Size.Left + Size.Width);
    wRect.Bottom := YPos(OfsY + Size.Top + Size.Height);

    with Canvas do
    begin

    Pen := FInnerPen;

    FillRect(wRect);
    wPos1 := SetPoint(FPos1, wRect);
    wPos2 := SetPoint(FPos2, wRect);
    MoveTo(wPos1.x, wPos1.y);
    LineTo(wPos2.x, wPos2.y);
    end; { with Canvas do }
  end; { with ParentReport.QRPrinter do }
end;

procedure Register;
begin
  RegisterComponents('QReport', [TQRrect]);
end;

end.
 


- FDELPHI  MES(16):玉石混淆みんなで作るSample蔵【見本蓄積】 01/04/14 -

Original document by フレディ        氏 ID:(QZM07721)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。