この発言に対し以下のコメントが寄せられています

#01319　かつぼー        さん　斜線鎖線極細極太色付文字間隔LightReport2






Takezouさん作、LightReportという、大変すばらしいコンポーネントを
愛用させてもらっていますが、複写式帳票にインパクトプリンタで打ち
出す必要があり、その際大変難儀しました。
ひとつは、金額の一桁毎に枠があり、そこにきれいに納める事、
もうひとつは、すでに罫線等は印刷されていますので、数字だけを印字
するのですが、プレビューでは罫線も表示する必要があること。
罫線だけ印字するのは簡単ですが、その逆はなかなか面倒でした。
もうひとつ、点線を引くことが出来ないこと。などです。

これらを解決するコンポーネントを作りました。
文字間隔の調整が出来る。
鎖線が引ける。
四辺毎に、線の色を指定できる。
四辺毎に、線の太さを細かく指定できる。
四辺毎に、鎖線の間隔を細かく指定できる。
対角線も引ける。
IsDrawLine,IsDrawTextプロパティで、割と簡単に線だけ、あるいは
文字だけを印字できる。(印刷前にFindComponentなどでループを回して、
プロパティを設定しなければなりませんが、それでも結構楽になりました)

HMargin,VMargin,線の太さなどはIntegerではなくてDoubleにしましたので、
設計時やプレビュー時にはほとんど意味はありませんが、実際の紙に印刷
するときは、かなり細かく調整できるのではないかと思います。
プリンタの解像度が大きければ、Widthを0.1とかにすれば相当細い線が
引けるのではないかと思います。

できたてホヤホヤで、実際に使い込んでいませんので、
変なところがあったりするかもしれません。

長いので、三つに分けます。
興味のある人はつなぎ合わせてコンパイルしてください。
RegisterComponents('LightReport2', [TLRItemExt]);
などを各自追加しないと、パレットには出てきません。

作者のTakezouさん、ありがとうございます。
ほとんどTLRItemのマネです。
３発言に納めるために、空行を削除しているのでちょっと見にくいです。

unit LightRepEx3;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  LightRep;
type
  TLineStyleObject = class(TPersistent)
  private
    FParent: TControl;
    FColor: TColor;
    FWidth: Double;
    FLine: Double;
    FGap: Double;
    procedure SetColor(const Value: TColor);
    procedure SetWidth(const Value: Double);
    procedure SetLine(const Value: Double);
    procedure SetGap(const Value: Double);
  protected
  public
    constructor Create(AParent: TControl); virtual;
    procedure Assign(Source: TPersistent); override;
    procedure DrawLine(ACanvas: TCanvas; ARect: TRect;
      APrintScale: Double); virtual; abstract;
  published
    property Color: TColor read FColor write SetColor;
    property Width: Double read FWidth write SetWidth;
    property Line: Double read FLine write SetLine;
    property Gap: Double read FGap write SetGap;
  end;
  TLineTopStyleObject = class(TLineStyleObject)
  public
    procedure DrawLine(ACanvas: TCanvas; ARect: TRect;
      APrintScale: Double); override;
  end;
  TLineLeftStyleObject = class(TLineStyleObject)
  public
    procedure DrawLine(ACanvas: TCanvas; ARect: TRect;
      APrintScale: Double); override;
  end;
  TLineRightStyleObject = class(TLineStyleObject)
  public
    procedure DrawLine(ACanvas: TCanvas; ARect: TRect;
      APrintScale: Double); override;
  end;
  TLineBottomStyleObject = class(TLineStyleObject)
  public
    procedure DrawLine(ACanvas: TCanvas; ARect: TRect;
      APrintScale: Double); override;
  end;
  TLineLeftTopToRightBottomStyleObject = class(TLineStyleObject)
  public
    procedure DrawLine(ACanvas: TCanvas; ARect: TRect;
      APrintScale: Double); override;
  end;
  TLineRightTopToLeftBottomStyleObject = class(TLineStyleObject)
  public
    procedure DrawLine(ACanvas: TCanvas; ARect: TRect;
      APrintScale: Double); override;
  end;
  TLRItemExt = class(TCustomLRItem)
  private
    FAlignment: TAlignment;
    FEditMask: string;
    FHMargin: Double;
    FVMargin: Double;
    FLayout: TTextLayout;
    FTransParent: Boolean;
    FWordWrap: Boolean;
    FCharSpace: Double;
    FIsDrawText: Boolean;
    FIsDrawLine: Boolean;
    FLineTopStyle   : TLineStyleObject;
    FLineRightStyle : TLineStyleObject;
    FLineLeftStyle  : TLineStyleObject;
    FLineBottomStyle: TLineStyleObject;
    FLineLeftTopToRightBottomStyle: TLineStyleObject;
    FLineRightTopToLeftBottomStyle: TLineStyleObject;
    procedure SetAlignment(const Value: TAlignment);
    procedure SetEditMask(const Value: string);
    procedure SetHMargin(const Value: Double);
    procedure SetVMargin(const Value: Double);
    procedure SetLayout(const Value: TTextLayout);
    procedure SetText(const Value: string);
    procedure SetTransParent(const Value: Boolean);
    procedure SetWordWrap(const Value: Boolean);
    procedure SetLineTopStyle(ALineStyle: TLineStyleObject);
    procedure SetLineRightStyle(ALineStyle: TLineStyleObject);
    procedure SetLineLeftStyle(ALineStyle: TLineStyleObject);
    procedure SetLineBottomStyle(ALineStyle: TLineStyleObject);
    procedure SetLineLeftTopToRightBottomStyle(ALineStyle: TLineStyleObject);
    procedure SetLineRightTopToLeftBottomStyle(ALineStyle: TLineStyleObject);
    procedure SetCharSpace(const Value: Double);
    procedure SetIsDrawText(const Value: Boolean);
    procedure SetIsDrawLine(const Value: Boolean);
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    function GetText: string;
  protected
    procedure Paint; override;
    procedure Print(ACanvas: TCanvas; ARect: TRect; APrintScale: Double;
      APrintStatus: TPrintStatus); override;
    function GetDiaplayText: string; virtual;
    procedure DrawText(ACanvas: TCanvas; ARect: TRect;
     APrintScale: Double); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Color;
    property Font;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property LineTopStyle: TLineStyleObject
      read FLineTopStyle write SetLineTopStyle;
    property LineRightStyle: TLineStyleObject
      read FLineRightStyle write SetLineRightStyle;
    property LineLeftStyle: TLineStyleObject
      read FLineLeftStyle write SetLineLeftStyle;
    property LineBottomStyle: TLineStyleObject
      read FLineBottomStyle write SetLineBottomStyle;
    property LineLeftTopToRightBottomStyle: TLineStyleObject read
     FLineLeftTopToRightBottomStyle write SetLineLeftTopToRightBottomStyle;
    property LineRightTopToLeftBottomStyle: TLineStyleObject read
     FLineRightTopToLeftBottomStyle write SetLineRightTopToLeftBottomStyle;
    property CharSpace: Double read FCharSpace write SetCharSpace;
    property IsDrawText: Boolean read FIsDrawText write SetIsDrawText
      default True;
    property IsDrawLine: Boolean read FIsDrawLine write SetIsDrawLine
      default True;
    property Layout: TTextLayout read FLayout write SetLayout default tlTop;
    property Alignment: TAlignment read FAlignment write SetAlignment
      default taLeftJustify;
    property Text: string read GetText write SetText;
    property DisplayMask: string read FEditMask write SetEditMask;
    property Transparent: boolean read FTransparent write SetTransparent;
    property VMargin: Double read FVMargin write SetVMargin;
    property HMargin: Double read FHMargin write SetHMargin;
    property WordWrap: Boolean read FWordWrap write SetWordWrap
      default False;
  end;
implementation
uses
  Mask, Math;
function RoundOff(X: Extended): Integer;
begin
  if x >= 0 then Result := Trunc(x + 0.5)
  else Result := Trunc(x - 0.5);
end;
procedure TLineStyleObject.Assign(Source: TPersistent);
begin
  if Source is TLineStyleObject then
    with Source as TLineStyleObject do
    begin
      FColor := Color;
      FWidth := Width;
      FLine := Line;
      FGap := Gap;
    end;
  inherited Assign(Source);
end;
procedure TLineStyleObject.SetColor(const Value: TColor);
begin
  if FColor <> Value then
  begin
    FColor := Value;
    FParent.Invalidate;
  end;
end;
procedure TLineStyleObject.SetWidth(const Value: Double);
begin
  if (FWidth <> Value) and (Value >= 0) then
  begin
    FWidth := Value;
    FParent.Invalidate;
  end;
end;
procedure TLineStyleObject.SetLine(const Value: Double);
begin
  if (FLine <> Value) and (Value >= 0) then
  begin
    FLine := Value;
    FParent.Invalidate;
  end;
end;
procedure TLineStyleObject.SetGap(const Value: Double);
begin
  if (FGap <> Value) and (Value >= 0) then
  begin
    FGap := Value;
    FParent.Invalidate;
  end;
end;
constructor TLineStyleObject.Create(AParent: TControl);
begin
  inherited Create;
  FParent := AParent;
end;
procedure TLineTopStyleObject.
  DrawLine(ACanvas: TCanvas; ARect: TRect;APrintScale: Double);
var
  offset, startX, startY, endX: Integer;
  x, line, gap: Double;
begin
  if FWidth <= 0 then Exit;
  if (FLine > 0) and (FLine <= 0) then Exit;
  with ACanvas.Pen do
  begin
    Style := psSolid;
    Color := FColor;
    Width := RoundOff(APrintScale * FWidth);
  end;
  if (csDesigning in FParent.ComponentState) then
    offset := 0
  else
    offset := RoundOff(APrintScale);
  with ARect do
  begin
    startX := Left - offset;
    startY := Top - offset;
    endX := Right;
  end;
  with ACanvas do
  begin
    MoveTo(startX, startY);
    if FGap <= 0 then
      LineTo(endX, startY)
    else
    begin
      x := 0;
      line := FLine * APrintScale;
      gap := FGap * APrintScale;
      while (startX + x) < endX do
      begin
        x := x + line;
        LineTo(Min(RoundOff(startX + x), endX), startY);
        x := x + gap;
        MoveTo(RoundOff(startX + x), startY);
      end;
    end;
  end;
end;
 


Original document by かつぼー        氏 ID:(CQU00157)

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