// これは...

これは Delphi Advent Calendar 2017 15 日目の記事です。
長くなってしまったので機能単位で分割しています。

[ファイル(F)]

ここで [ファイル(F)] の実装に戻ります。印刷の実装がまだでしたね。

Delphi では簡易的なファイルの印刷に AssignPrn() を使う事ができますが、メモ帳にはヘッダーやフッター等があるため、この方法は使えません。

AssignPrn (DocWiki)

Delphi の Professional 以上の SKU には FastReport というレポートツールが付属するのでこれを使えば楽になります。他にも Delphi で使える商用レポートツールはいくつかあります。

Starter Edition でも使えるものには LightReport2 があります。

LightReport2 ver2.51 Unicode Edition

...が、今回はいずれも使わず、Printer オブジェクトを使ってゴリゴリ実装したいと思います。

[ページ設定(U)...]

メモ帳の [ページ設定(U)] はこのようになっています。

Windows 8.1 ではヘッダーとフッターの意味が分からないと思いますが、この文字の意味は次の通りです。Windows 10 以降の場合には入力値というリンクがあります。

コマンド	操作
&l	これに続く文字を左揃えにします
&c	これに続く文字を中央揃えにします
&r	これに続く文字を右揃えにします
&d	現在の日付を印刷します
&t	現在の時刻を印刷します
&f	ドキュメントの名前を印刷します。ファイル名が付いていない場合は、"(無題)" が印刷されます。
&P	ページ番号を印刷します。
&&	アンパサンド (&) を印刷します。

これらを組み合わせてヘッダーやフッターを構成できるという訳ですね。では Delphi の TPageSetupDialog を確認してみましょう。

あれ？形が違いますね。実はメモ帳のページ設定ダイアログは汎用のダイアログではないのです。テキストファイルオープンダイアログも違いましたよね。メモ帳はコモンダイアログそのものではなくカスタマイズされたコモンダイアログを使っています。

カスタマイズされたコモンダイアログですが、メモ帳のように OS 付属なら当然問題は起きないのですが、OS が変わるとコモンダイアログのデザインが変わって変な位置にカスタム部分が表示される事があるためオススメしません。よって、ヘッダーやフッターは別の方法で設定します。

ではページ設定ダイアログを追加しましょう。TPageSetupDialog はツールパレットの [Dialogs] タブにあります。

次にオブジェクトインスペクタで PageSetupDialog1 のプロパティを変更します。

プロパティ	値	説明
MarginLeft	2000	左マージンです。メモ帳の初期値は 20mm です。
MarginRight	2000	右マージンです。メモ帳の初期値は 20mm です。
Options.psoMargins	True	True でないとマージンの値を設定 / 保存できません。

acPageSetup アクションのイベントハンドラを作ります。

acPageSetupExecute イベントハンドラの実装は以下のようになります。

frmuMain.pas

procedure TForm1.acPageSetupExecute(Sender: TObject);
// Action: ページ設定(U)...
begin
  PageSetupDialog1.Execute;
end;

〔Alt〕,〔F〕,〔U〕で [ページ設定(U)...] が実行される事を確認してください。

[印刷(P)...]

印刷ですが、メモ帳の印刷ではフォントサイズは [書式(O) | フォント(F)...] の設定で変化しますが、[書式(O) | 右端で折り返す(W)] の状態に関係なくページ内で折り返して印字されます。WYSIWYG ではありません。

ロジックが長くなるので PrintText() というメソッドを追加します。Printer オブジェクトを操作するので、uses に Vcl.Printers を追加しておきます。Max() 関数も使いたいので System.Math も追加します。

frmuMain.pas

unit frmuMain;

interface

uses
  ..., Vcl.Printers, System.Math;  // <-- 追加

  (中略)

  private
    { Private 宣言 }
    FFileName: String;
    FEncodingIndex: Integer;
    procedure DispRowCol;
    procedure Init;
    procedure PrintText(const HeaderStr, FooterStr: string);
    procedure SaveFile;
    procedure UpdateCaption;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

  (中略)

procedure TForm1.PrintText(const HeaderStr, FooterStr: string);
// 印刷ロジック
begin
  
end;

フォームデザイナで TPrintDialog を追加しておきます (PrintDialog1)。

実装コードは以下の通りです。割とガチです。

frmuMain.pas

procedure TForm1.PrintText(const HeaderStr, FooterStr: string);
// 印刷ロジック
const
  DRAW_FLG = DT_NOPREFIX or DT_TOP or DT_LEFT or DT_WORDBREAK;
  CALC_FLG = DRAW_FLG or DT_CALCRECT;
var
  i, l, j, Index, LineCount, Sum, TextHeight, X_DPI, Y_DPI, PAGE_HEIGHT,
  PAPER_WIDTH, PAPER_HEIGHT, MIN_HEIGHT, Copies: Integer;
  PrintRect, CalcRect, CalcRect2, HeaderRect, FooterRect: TRect;
  Text: String;
  SL : TStringList;
  Pages: array of Integer;
  { DrawHeaderFooter End}
  procedure DrawHeaderFooter(const AStr: string; ARect: TRect; AFlgs: Integer; APage: Integer);
  var
    Flgs: Integer;
    AlignFlg: Integer;
    P: PChar;
    Str: string;
    ChangeAlign: Boolean;
  begin
    if AStr = '' then
      Exit;
    Flgs := AFlgs or DT_NOPREFIX or DT_SINGLELINE;
    AlignFlg := DT_CENTER;
    Str := '';
    P := @AStr[1];
    while (P^ <> #$00) do
      begin
        if P^ = '&' then
          begin
            Inc(P);
            if P^ = #$00 then
              Break;
            ChangeAlign := False;
            case UpCase(P^) of
              'L', 'C', 'R':
                ChangeAlign := True;
              'D':
                Str := Str + FormatDateTime('YYYY"年"M"月"M"日"', Date);
              'T':
                Str := Str + FormatDateTime('h:n:s', Time);
              'F':
                begin
                  if FFileName = '' then
                    Str := Str + '無題'
                  else
                    Str := Str + TPath.GetFileName(FFileName);
                end;
              'P':
                Str := Str + APage.ToString;
              '&':
                Str := Str + '&';
            end;
            if (Str <> '') and ChangeAlign then
              begin
                DrawText(Printer.Canvas.Handle, PChar(Str), Length(Str), ARect, Flgs or AlignFlg);
                Str := '';
              end;
            case UpCase(P^) of
              'L': AlignFlg := DT_LEFT;
              'C': AlignFlg := DT_CENTER;
              'R': AlignFlg := DT_RIGHT;
            end;
          end
        else
          Str := Str + P^;
        Inc(P);
      end;
    if Str <> '' then
      begin
        DrawText(Printer.Canvas.Handle, PChar(Str), Length(Str), ARect, Flgs or AlignFlg);
        Str := '';
      end;
  end;
  { DrawHeaderFooter End}
  { DrawHeader Begin}
  procedure DrawHeader(APage: Integer);
  begin
    DrawHeaderFooter(HeaderStr, HeaderRect, DT_TOP, APage);
  end;
  { DrawHeader End}
  { DrawFooter Begin}
  procedure DrawFooter(APage: Integer);
  begin
    DrawHeaderFooter(FooterStr, FooterRect, DT_BOTTOM, APage);
  end;
  { DrawFooter End}
begin
  if not PrintDialog1.Execute then
    Exit;

  // プリンタの DPI
  X_DPI := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
  Y_DPI := GetDeviceCaps(Printer.Handle, LOGPIXELSY);

  // 用紙の幅と高さ
  PAPER_WIDTH  := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH );
  PAPER_HEIGHT := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT);

  // 印刷領域
  PrintRect.Top    :=                Trunc(PageSetupDialog1.MarginTop    / 2540 * Y_DPI);
  PrintRect.Left   :=                Trunc(PageSetupDialog1.MarginLeft   / 2540 * X_DPI);
  PrintRect.Bottom := PAPER_HEIGHT - Trunc(PageSetupDialog1.MarginBottom / 2540 * Y_DPI);
  PrintRect.Right  := PAPER_WIDTH  - Trunc(PageSetupDialog1.MarginRight  / 2540 * X_DPI);

  // 印刷
  Printer.BeginDoc;
  SetBkMode(Printer.Canvas.Handle, TRANSPARENT);
  Printer.Canvas.Font.Assign(Memo1.Font); // Memo1 のフォントを Canvas に割り当て

  Text := 'A';
  CalcRect := Rect(0, 0, Printer.PageWidth, 0);
  DrawText(Printer.Canvas.Handle, PChar(Text), Length(Text), CalcRect, CALC_FLG);
  MIN_HEIGHT := CalcRect.Bottom;

  if HeaderStr <> '' then
    begin
      HeaderRect := PrintRect;
      HeaderRect.Bottom := PrintRect.Top + MIN_HEIGHT * 2;
      PrintRect.Top := HeaderRect.Bottom;
    end;
  if FooterStr <> '' then
    begin
      FooterRect := PrintRect;
      FooterRect.Top := PrintRect.Bottom - MIN_HEIGHT * 2;
      PrintRect.Bottom := FooterRect.Top;
    end;
  PAGE_HEIGHT := PrintRect.Bottom - PrintRect.Top;

  SetLength(Pages, 1);
  SL := TStringList.Create;
  try
    SL.Text := Memo1.Lines.Text;

    // ページ数の計算
    LineCount := 0;
    Sum := 0;
    for i:=0 to SL.Count-1 do
      begin
        Text := SL[i];
        CalcRect := PrintRect;
        CalcRect.Top    := 0;
        CalcRect.Bottom := 0;
        DrawText(Printer.Canvas.Handle, PChar(Text), Length(Text), CalcRect, CALC_FLG);
        TextHeight := Max(MIN_HEIGHT, CalcRect.Bottom);
        if (Sum + TextHeight) > PAGE_HEIGHT then
          begin
            Pages[Length(Pages)-1] := LineCount;
            SetLength(Pages, Length(Pages) + 1);
            LineCount := 0;
            Sum := 0;
          end;
        Inc(LineCount);
        Inc(Sum, TextHeight);
      end;
    LineCount := SL.Count;
    for i:=0 to Length(Pages) - 2 do
      Dec(LineCount, Pages[i]);
    Pages[Length(Pages)-1] := LineCount;

    // 印刷
    if PrintDialog1.Collate then
      Copies := PrintDialog1.Copies // 部単位で印刷
    else
      Copies := 1;
    for j:=1 to Copies do
      begin
        CalcRect := PrintRect;
        Index := 0;
        for l:=0 to Length(Pages) - 1 do
          begin
            // ヘッダ
            DrawHeader(l+1);
            // テキスト
            CalcRect.Top := PrintRect.Top;
            for i:=0 to Pages[l] - 1 do
              begin
                CalcRect2 := PrintRect;
                CalcRect2.Top := 0;
                CalcRect2.Bottom := 0;
                Text := SL[Index];
                DrawText(Printer.Canvas.Handle, PChar(Text), Length(Text), CalcRect2, CALC_FLG);
                TextHeight := Max(MIN_HEIGHT, CalcRect2.Bottom);
                DrawText(Printer.Canvas.Handle, PChar(Text), Length(Text), CalcRect, DRAW_FLG);
                CalcRect.Top := CalcRect.Top + TextHeight;
                Inc(Index);
              end;
            // フッタ
            DrawFooter(l+1);
            // 改ページ
            if (l <> (Length(Pages) - 1)) or (J <> Copies) then
              Printer.NewPage;
          end;
      end;
  finally
    SL.Free;
  end;
  Printer.EndDoc;
end;

PrintText() の中に DrawHeaderFooter() 等のメソッドが入れ子で記述されているのが面白いですね。Pascal は関数内関数のようにメソッドを入れ子にできます。もちろん、関数内関数内関数や関数内関数内関数内関数も作れます。

acPrint のイベントハンドラを作ります。

acPrintExecute イベントハンドラの実装は以下のようになります。

frmuMain.pas

procedure TForm1.acPrintExecute(Sender: TObject);
// Action: 印刷(P)
begin
  PrintText('&f', 'ページ(&p)');
end;

〔Alt〕,〔F〕,〔P〕または〔Ctrl〕+〔P〕で [印刷(P)...] が実行される事を確認してください。

[ヘッダーとフッター(H)...]

こちらは別ダイアログとして実装してしまいましょう。

ActionList にアクションを追加します。カテゴリを [File] にする事に注意してください。

Action (Name)	Caption	Category	ShortCut
acHeaderFooter	ヘッダーとフッター(&H)...	File

メニューにも割り当てましょう。この位置がいいかと思います。メニューアイテムを割り込ませるには〔Ins〕キーを押します。

ここに acHeaderFooter アクションを割り当てておきます。

次にダイアログを作成します。 [ファイル | 新規作成 | VCL フォーム - Delphi] を選びます。

新しい "空のフォーム付きのユニット" が作られました。

Unit3.pas という名前になっていますので〔F2〕を押して名前を frmuHeaderFooter に変更します。

マウスで二回ゆっくりクリックしても名前を変更できます。

新規作成されたフォームは自動生成の対象となっていますので、[プロジジェクト | オプション] で自動生成から外します。

自動生成から外したら、フォーム (Form3) のプロパティを変更します。

プロパティ	値	説明
BorderICons	[biSystemMenu]	フォーム右上のアイコンです。?ボタンだけにします。
BorderStyle	bsSingle	サイズ変更のできないフォームにします。
Caption	ヘッダーとフッター	フォームのキャプションバーのキャプションです。
ClientHeight	126	フォームのクライアント領域の高さです。
ClientWidth	400	フォームのクライアント領域の幅です。
Font.Name	Tahoma	フォームで使われるデフォルトのフォント名です。
Font.Size	9	フォームで使われるデフォルトのフォントサイズです。
Position	poMainFormCenter	フォームが表示される位置です。親ウィンドウの中心に表示します

こんな見た目になったと思います。

ここにコントロールを貼るのですが、面倒なので以下のコードをコピー (〔Ctrl〕+〔C〕) してフォームエディタ上で貼り付け (〔Ctrl〕+〔V〕) してみてください。

object Label1: TLabel
  Left = 12
  Top = 15
  Width = 58
  Height = 14
  Caption = #12504#12483#12480#12540'(&H):'
  FocusControl = Edit1
end
object Edit1: TEdit
  Left = 88
  Top = 12
  Width = 300
  Height = 23
  TabOrder = 0
  Text = 'Edit1'
end
object Label2: TLabel
  Left = 12
  Top = 51
  Width = 53
  Height = 14
  Caption = #12501#12483#12479#12540'(&F):'
  FocusControl = Edit2
end
object Edit2: TEdit
  Left = 88
  Top = 48
  Width = 300
  Height = 23
  TabOrder = 1
  Text = 'Edit2'
end
object Button1: TButton
  Left = 205
  Top = 88
  Width = 88
  Height = 26
  Caption = 'OK'
  Default = True
  ModalResult = 1
  TabOrder = 2
end
object Button2: TButton
  Left = 300
  Top = 88
  Width = 88
  Height = 26
  Cancel = True
  Caption = #12461#12515#12531#12475#12523
  ModalResult = 2
  TabOrder = 3
end

プロパティが設定された状態で貼り付けられたと思います。Delphi でコンポーネントをクリップボードにコピーした時、それはテキスト形式で格納されています。つまりメモ帳などへ一時退避的に置いておく事も可能です。この特性を覚えておくと便利な事もあると思います。

このフォームのユニット (frmuHeaderFooter.pas) にはコードの記述は不要です。メインフォームに戻り、rmuHeaderFooter を参照できるように implementation の下の uses に frmuHeaderFooter を追加します。

frmuMain.pas

implementation

{$R *.dfm}

uses
  frmuGotoLine,
  frmuHeaderFooter;  // <-- 追加

ヘッダーとフッターの値を保持するためのメンバー変数 (フィールド) も作っておきます。

frmuMain.pas

  private
    { Private 宣言 }
    FFileName: String;
    FEncodingIndex: Integer;
    FHeaderStr: string;       // <-- 追加
    FFooterStr: string;       // <-- 追加
    procedure DispRowCol;
    procedure Init;
    procedure PrintText(const HeaderStr, FooterStr: string);
    procedure SaveFile;
    procedure UpdateCaption;
  public
    { Public 宣言 }
  end;

FormCreate イベントハンドラで初期値を入れておきます。

frmuMain.pas

procedure TForm1.FormCreate(Sender: TObject);
// フォーム作成時
begin
  FHeaderStr := '&f';
  FFooterStr := 'ページ(&p)';
  Init;
end;

acPrint ([印刷(P)]) のイベントハンドラを書き換えます。

frmuMain.pas

procedure TForm1.acPrintExecute(Sender: TObject);
// Action: 印刷(P)
begin
  PrintText(FHeaderStr, FFooterStr);
end;

次に acHeaderFooter　のイベントハンドラを作ります。

acHeaderFooterExecute イベントハンドラは以下のようになります。

frmuMain.pas

procedure TForm1.acHeaderFooterExecute(Sender: TObject);
// Action: ヘッダーとフッター(H)
begin
  Form3 := TForm3.Create(Self);
  try
    // ヘッダー文字列とフッター文字列を Form3 に渡す
    Form3.Edit1.Text := FHeaderStr;
    Form3.Edit2.Text := FFooterStr;
    // Form3 をモーダルで表示
    if Form3.ShowModal = mrOK then
      begin
        // [OK] ボタンが押されたら
        FHeaderStr := Form3.Edit1.Text;
        FFooterStr := Form3.Edit2.Text;
      end;
  finally
    Form3.Free;
  end;
end;

例えばヘッダーに &L123&C456&R789 という文字列が指定された場合、

ヘッダーとフッターはこのように印字されます。ヘッダーを &R789&C456&L123 にしても印字結果は同じになります。

〔Alt〕,〔F〕,〔H〕で [ヘッダーとフッター(H)...] が実行される事を確認してください。

// 戻る

ほぼ完成です。印刷ロジックが長いですね。

今回はここまでです。ここまでの全ソースを掲載しておきます。

[メインフォーム]

frmuMain.pas

unit frmuMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.Actions,
  Vcl.ActnList, Vcl.Menus, Vcl.ExtDlgs, System.IOUtils, Vcl.Clipbrd,
  System.RegularExpressions, System.UITypes, Vcl.ComCtrls, WinAPI.ShellAPI, Vcl.Printers, System.Math;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    MainMenu1: TMainMenu;
    ActionList1: TActionList;
    acNew: TAction;
    acOpen: TAction;
    acSave: TAction;
    acSaveAs: TAction;
    acPageSetup: TAction;
    acPrint: TAction;
    acExit: TAction;
    F1: TMenuItem;
    N1: TMenuItem;
    O1: TMenuItem;
    S1: TMenuItem;
    A1: TMenuItem;
    U1: TMenuItem;
    P1: TMenuItem;
    X1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    OpenTextFileDialog1: TOpenTextFileDialog;
    SaveTextFileDialog1: TSaveTextFileDialog;
    acUndo: TAction;
    acCut: TAction;
    acCopy: TAction;
    acPaste: TAction;
    acDelete: TAction;
    acFind: TAction;
    acFindNext: TAction;
    acReplace: TAction;
    acGoTo: TAction;
    acSelectAll: TAction;
    acTimeDate: TAction;
    E1: TMenuItem;
    U2: TMenuItem;
    N4: TMenuItem;
    C1: TMenuItem;
    T1: TMenuItem;
    P2: TMenuItem;
    L1: TMenuItem;
    N5: TMenuItem;
    F2: TMenuItem;
    N6: TMenuItem;
    R1: TMenuItem;
    G1: TMenuItem;
    N7: TMenuItem;
    A2: TMenuItem;
    D1: TMenuItem;
    FindDialog1: TFindDialog;
    ReplaceDialog1: TReplaceDialog;
    acWordwrap: TAction;
    acFont: TAction;
    O2: TMenuItem;
    W1: TMenuItem;
    F3: TMenuItem;
    FontDialog1: TFontDialog;
    acStatusBar: TAction;
    N8: TMenuItem;
    S2: TMenuItem;
    StatusBar1: TStatusBar;
    acHelp: TAction;
    acAbout: TAction;
    H1: TMenuItem;
    H2: TMenuItem;
    A3: TMenuItem;
    N9: TMenuItem;
    PageSetupDialog1: TPageSetupDialog;
    PrintDialog1: TPrintDialog;
    acHeaderFooter: TAction;
    H3: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure acExitExecute(Sender: TObject);
    procedure acOpenExecute(Sender: TObject);
    procedure acSaveExecute(Sender: TObject);
    procedure acSaveAsExecute(Sender: TObject);
    procedure acNewExecute(Sender: TObject);
    procedure acUndoExecute(Sender: TObject);
    procedure ActionList1Update(Action: TBasicAction; var Handled: Boolean);
    procedure acCutExecute(Sender: TObject);
    procedure acCopyExecute(Sender: TObject);
    procedure acPasteExecute(Sender: TObject);
    procedure E1Click(Sender: TObject);
    procedure acFindExecute(Sender: TObject);
    procedure Dialog_Find(Sender: TObject);
    procedure acFindNextExecute(Sender: TObject);
    procedure acDeleteExecute(Sender: TObject);
    procedure acReplaceExecute(Sender: TObject);
    procedure ReplaceDialog1Replace(Sender: TObject);
    procedure acGoToExecute(Sender: TObject);
    procedure acSelectAllExecute(Sender: TObject);
    procedure acTimeDateExecute(Sender: TObject);
    procedure acWordwrapExecute(Sender: TObject);
    procedure acFontExecute(Sender: TObject);
    procedure StatusBar1Resize(Sender: TObject);
    procedure Memo1Click(Sender: TObject);
    procedure Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure acStatusBarExecute(Sender: TObject);
    procedure acHelpExecute(Sender: TObject);
    procedure acAboutExecute(Sender: TObject);
    procedure acPageSetupExecute(Sender: TObject);
    procedure acPrintExecute(Sender: TObject);
    procedure acHeaderFooterExecute(Sender: TObject);
  private
    { Private 宣言 }
    FFileName: String;
    FEncodingIndex: Integer;
    FHeaderStr: string;
    FFooterStr: string;
    procedure DispRowCol;
    procedure Init;
    procedure PrintText(const HeaderStr, FooterStr: string);
    procedure SaveFile;
    procedure UpdateCaption;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  frmuGotoLine,
  frmuHeaderFooter;

procedure TForm1.FormCreate(Sender: TObject);
// フォーム作成時
begin
  FHeaderStr := '&f';
  FFooterStr := 'ページ(&p)';
  Init;
end;

procedure TForm1.StatusBar1Resize(Sender: TObject);
// ステータスバーのリサイズ
begin
  StatusBar1.Panels[1].Width := StatusBar1.Width div 4;
  StatusBar1.Panels[0].Width := StatusBar1.Width - StatusBar1.Panels[1].Width;
end;

procedure TForm1.Memo1Click(Sender: TObject);
// Memo1 クリック時
begin
  DispRowCol;
end;


procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
// Memo1 キーアップ時
begin
  DispRowCol;
end;

// [FILE] Actions

procedure TForm1.acNewExecute(Sender: TObject);
// Action: 新規(N)
begin
  Init;
end;

procedure TForm1.acOpenExecute(Sender: TObject);
// Action: 開く(O)...
var
  Enc: TEncoding;
begin
  if OpenTextFileDialog1.Execute then
    begin
      // 値を保存
      FFileName := OpenTextFileDialog1.FileName;
      FEncodingIndex := OpenTextFileDialog1.EncodingIndex;
      // キャプションを変更
      UpdateCaption;
      // EncodingIndex によりエンコーディングを指定
      case FEncodingIndex of
        1: Enc := TEncoding.Unicode;
        2: Enc := TEncoding.BigEndianUnicode;
        3: Enc := TEncoding.UTF8;
      else
        Enc := TEncoding.Default;
      end;
      // エンコーディングを指定して読み込み
      Memo1.Lines.LoadFromFile(FFileName, Enc);
    end;
end;

procedure TForm1.acSaveExecute(Sender: TObject);
// Action: 上書き保存(S)
begin
  if (FFileName = '') then
    begin
      // 名前を付けて保存
      acSaveAs.Execute;
    end
  else
    begin
      // 上書き保存
      SaveFile;
    end;
end;

procedure TForm1.acSaveAsExecute(Sender: TObject);
// Action: 名前を付けて保存(A)...
begin
  if SaveTextFileDialog1.Execute then
    begin
      // 値を保存
      FFileName := SaveTextFileDialog1.FileName;
      FEncodingIndex := SaveTextFileDialog1.EncodingIndex;
      // キャプションを変更
      UpdateCaption;
      // ファイルへ保存
      SaveFile;
    end;
end;

procedure TForm1.acPageSetupExecute(Sender: TObject);
// Action: ページ設定(U)...
begin
  PageSetupDialog1.Execute;
end;

procedure TForm1.acHeaderFooterExecute(Sender: TObject);
// Action: ヘッダーとフッター(H)
begin
  Form3 := TForm3.Create(Self);
  try
    // ヘッダー文字列とフッター文字列を Form3 に渡す
    Form3.Edit1.Text := FHeaderStr;
    Form3.Edit2.Text := FFooterStr;
    // Form3 をモーダルで表示
    if Form3.ShowModal = mrOK then
      begin
        // [OK] ボタンが押されたら
        FHeaderStr := Form3.Edit1.Text;
        FFooterStr := Form3.Edit2.Text;
      end;
  finally
    Form3.Free;
  end;
end;

procedure TForm1.acPrintExecute(Sender: TObject);
// Action: 印刷(P)
begin
  PrintText(FHeaderStr, FFooterStr);
end;

procedure TForm1.acExitExecute(Sender: TObject);
// Action: メモ帳の終了(X)
begin
  Self.Close;
end;

// [EDIT] Actions

procedure TForm1.E1Click(Sender: TObject);
begin
  acDelete.ShortCut := TextToShortCut('Del');
end;

procedure TForm1.acUndoExecute(Sender: TObject);
// Action: 元に戻す(U)
begin
  Memo1.Undo;
end;

procedure TForm1.acCutExecute(Sender: TObject);
// Action: 切り取り(T)
begin
  Memo1.CutToClipboard;
end;

procedure TForm1.acCopyExecute(Sender: TObject);
// Action: コピー(C)
begin
  Memo1.CopyToClipboard;
end;

procedure TForm1.acPasteExecute(Sender: TObject);
// Action: 貼り付け(P)
begin
  Memo1.PasteFromClipboard;
end;

procedure TForm1.acDeleteExecute(Sender: TObject);
// Action: 削除(L)
begin
  Memo1.ClearSelection;
end;

procedure TForm1.acFindExecute(Sender: TObject);
// Action: 検索(F)
begin
  // 検索ダイアログを開く
  FindDialog1.Execute;
end;

procedure TForm1.acFindNextExecute(Sender: TObject);
// Action: 次を検索(N)
begin
  if FindDialog1.FindText = '' then
    acFind.Execute
  else
    Dialog_Find(FindDialog1);
end;

procedure TForm1.acReplaceExecute(Sender: TObject);
// Action: 置換(H)
begin
  // 置換ダイアログを開く
  ReplaceDialog1.Execute;
end;

procedure TForm1.Dialog_Find(Sender: TObject);
// 検索イベントハンドラ
var
  RegEx: TRegEx;
  Exp, Msg: String;
  Options: TRegExOptions;
  Match, dMatch: TMatch;
  StartPos, EndPos: Integer;
begin
  // 検索文字列を正規表現文字列へエスケープ
  Exp := TRegEx.Escape(FindDialog1.FindText);

  // "大文字と小文字を区別する" にチェックが入っていなければ
  // オプションに roIgnoreCase (大文字小文字を区別しない) を追加
  if not (frMatchCase in FindDialog1.Options) then
    Include(Options, roIgnoreCase);

  // 正規表現オブジェクトの生成
  RegEx := TRegEx.Create(Exp, Options);

  if (frDown in FindDialog1.Options) then
    begin
      // 順方向検索 (下へ)
      StartPos  := Memo1.SelStart + Memo1.SelLength + 1;
      Match := RegEx.Match(Memo1.Lines.Text, StartPos);
    end
  else
    begin
      // 逆方向検索 (上へ)
      StartPos := 0;
      EndPos   := Memo1.SelStart + 1;
      Match := RegEx.Match(Memo1.Lines.Text, StartPos, EndPos);
      while Match.Success do
        begin
          // 最後にマッチした箇所を探す
          dMatch := Match.NextMatch;
          if dMatch.Success then
            Match := dMatch
          else
            break;
        end;
    end;

  // 検索文字列を共有
  FindDialog1.FindText := (Sender as TFindDialog).FindText;
  ReplaceDialog1.FindText := (Sender as TFindDialog).FindText;

  // 検索文字列を正規表現文字列へエスケープ
  Exp := TRegEx.Escape((Sender as TFindDialog).FindText);

  // "大文字と小文字を区別する" にチェックが入っていなければ
  // オプションに roIgnoreCase (大文字小文字を区別しない) を追加
  if not (frMatchCase in (Sender as TFindDialog).Options) then
    Include(Options, roIgnoreCase);

  // 正規表現オブジェクトの生成
  RegEx := TRegEx.Create(Exp, Options);
  if (frDown in (Sender as TFindDialog).Options) then
    begin
      // 順方向検索 (下へ)
      StartPos  := Memo1.SelStart + Memo1.SelLength + 1;
      Match := RegEx.Match(Memo1.Lines.Text, StartPos);
    end
  else
    begin
      // 逆方向検索 (上へ)
      StartPos := 0;
      EndPos   := Memo1.SelStart + 1;
      Match := RegEx.Match(Memo1.Lines.Text, StartPos, EndPos);
      while Match.Success do
        begin
          // 最後にマッチした箇所を探す
          dMatch := Match.NextMatch;
          if dMatch.Success then
            Match := dMatch
          else
            break;
        end;
    end;

  if Match.Success then
    begin
      // 一致する文字列があった
      SetFocus;
      Memo1.SelStart := Match.Index - 1;
      Memo1.SelLength := Match.Length;
    end
  else
    begin
      // 一致する文字列がなかった
      Msg := Format('"%s" が見つかりません。', [(Sender as TFindDialog).FindText]);
      MessageDlg(Msg, TMsgDlgType.mtInformation, [TMsgDlgBtn.mbOK], -1);
    end;
end;

procedure TForm1.ReplaceDialog1Replace(Sender: TObject);
// 置換イベントハンドラ
var
  srFlgs: TReplaceFlags;
  FindText: string;
  SelectFlg: Boolean;
begin
  // 検索文字列を共有
  FindDialog1.FindText := (Sender as TFindDialog).FindText;
  ReplaceDialog1.FindText := (Sender as TFindDialog).FindText;

  // フラグ
  if (frReplaceAll in ReplaceDialog1.Options) then
    begin
      // [すべて置換]
      srFlgs := [rfReplaceAll]; // すべて置換
      if  not (frMatchCase in ReplaceDialog1.Options) then
        Include(srFlgs, rfIgnoreCase);
      Memo1.Lines.Text := StringReplace(Memo1.Lines.Text, ReplaceDialog1.FindText, ReplaceDialog1.ReplaceText, srFlgs);
    end
  else
    begin
      // [置換して次へ]
      srFlgs := []; // 最初の一回だけ置換
      if  not (frMatchCase in ReplaceDialog1.Options) then
        Include(srFlgs, rfIgnoreCase);
      // 検索済みかどうかの判定
      FindText := (Sender as TFindDialog).FindText;
      if (frMatchCase in ReplaceDialog1.Options) then
        SelectFlg := SameStr(Memo1.SelText, FindText)   // 大文字小文字を区別する
      else
        SelectFlg := SameText(Memo1.SelText, FindText); // 大文字小文字を区別しない
      // 検索済みか？
      if SelectFlg then
        Memo1.SelText := ReplaceDialog1.ReplaceText;
      // 検索
      Dialog_Find(ReplaceDialog1);
    end;
end;

procedure TForm1.acGoToExecute(Sender: TObject);
// Action: 行へ移動(G)
begin
  Form2 := TForm2.Create(Self);
  try
    // 現在行と最大行を Form2 に渡す
    Form2.GotoLine := Memo1.Perform(EM_LINEFROMCHAR, WPARAM(-1), 0) + 1; // 0 オリジンなので + 1 する
    Form2.LineCount := Memo1.Perform(EM_GETLINECOUNT, 0, 0);
    // Form2 をモーダルで表示
    if Form2.ShowModal = mrOK then
      begin
        // [OK] ボタンが押されたら
        Memo1.SelLength := 0;
        Memo1.SelStart := Memo1.Perform(EM_LINEINDEX, Form2.GotoLine - 1, 0);
        Memo1.Perform(EM_SCROLLCARET,0 , 0);
      end;
  finally
    Form2.Free;
  end;
end;

procedure TForm1.acSelectAllExecute(Sender: TObject);
// Action: すべて選択(A)
begin
  Memo1.SelectAll;
end;

// [FORMAT] Actions

procedure TForm1.acTimeDateExecute(Sender: TObject);
// Action: 日付と時刻(D)
begin
  Memo1.SelText := FormatDateTime('hh:nn yyyy/mm/dd', Now);
end;

procedure TForm1.acWordwrapExecute(Sender: TObject);
// Action: [右側で折り返す(W)]
const
  SB: array [Boolean] of TScrollStyle = (ssBoth, ssVertical);
begin
  Memo1.WordWrap := not Memo1.WordWrap;
  Memo1.ScrollBars := SB[Memo1.WordWrap];
  if Memo1.WordWrap then         // <-- 追加
    StatusBar1.Visible := False; // <-- 追加
end;

procedure TForm1.acFontExecute(Sender: TObject);
// Action: [フォント(F)...]
begin
  FontDialog1.Font := Memo1.Font;   // Memo1 のフォントをコピー
  if FontDialog1.Execute then
    Memo1.Font := FontDialog1.Font; // FontDialog1 のフォントをコピー
end;

// [VIEW] Actions

procedure TForm1.acStatusBarExecute(Sender: TObject);
// Action: [ステータスバー(S)]
begin
  StatusBar1.Visible := not StatusBar1.Visible;
end;

// [HELP] Actions

procedure TForm1.acHelpExecute(Sender: TObject);
// Action: [ヘルプ(H)]
var
  URL: string;
begin
  URL := 'https://www.embarcadero.com/jp/products/delphi';
  ShellExecute(0, 'open', PWideChar(URL), nil, nil, SW_SHOWNORMAL);
end;

procedure TForm1.acAboutExecute(Sender: TObject);
// Action: [バージョン情報(A)]
begin
  ShellAbout(Self.Handle, 'メモ帳クローン', '', Application.Icon.Handle);
end;

// リスト更新

procedure TForm1.ActionList1Update(Action: TBasicAction; var Handled: Boolean);
begin
  // [元に戻す(U)] の有効/無効
  acUndo.Enabled := Memo1.CanUndo;
  // [切り取り(T)] の有効/無効
  acCut.Enabled := Memo1.SelLength <> 0;
  // [コピー(C)] の有効/無効
  acCopy.Enabled := Memo1.SelLength <> 0;
  // [貼り付け(P)] の有効/無効
  acPaste.Enabled := ClipBoard.HasFormat(CF_TEXT);
  // [削除(L)] の有効/無効
  acDelete.Enabled := Memo1.SelLength <> 0;
  acDelete.ShortCut := 0;
  // [検索(F)] の有効/無効
  acFind.Enabled := Memo1.Lines.Text.Length > 0;
  // [次を検索(N)] の有効/無効
  acFindNext.Enabled := Memo1.Lines.Text.Length > 0;
  // [右側で折り返す(W)] のチェック状態
  acWordwrap.Checked := Memo1.WordWrap;
  // [行へ移動(&G)] の有効/無効
  acGoTo.Enabled := not Memo1.WordWrap;
  // [ステータスバー(S)] の有効/無効
  acStatusBar.Enabled := not Memo1.WordWrap;
  // [ステータスバー(S)] のチェック状態
  acStatusBar.Checked := StatusBar1.Visible;
end;

// メソッド

procedure TForm1.DispRowCol;
var
  Row, Col: Integer;
begin
  // ステータスバーに行/列を表示
  Row := Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);
  Col := Memo1. SelStart -  Memo1.Perform(EM_LINEINDEX, WPARAM(ROW), 0);
  StatusBar1.Panels[1].Text := Format(' %d行、%d列' , [Row + 1, Col + 1]);
end;

procedure TForm1.Init;
// エディタの初期化
begin
 // 値を初期化
  FFileName := '';
  FEncodingIndex := 0;
  Memo1.Lines.Clear; // Memo1 の中身を消去する。
  // キャプションを変更
  UpdateCaption;
  // 行/列の表示
  DispRowCol;
end;

procedure TForm1.PrintText(const HeaderStr, FooterStr: string);
// 印刷ロジック
const
  DRAW_FLG = DT_NOPREFIX or DT_TOP or DT_LEFT or DT_WORDBREAK;
  CALC_FLG = DRAW_FLG or DT_CALCRECT;
var
  i, l, j, Index, LineCount, Sum, TextHeight, X_DPI, Y_DPI, PAGE_HEIGHT,
  PAPER_WIDTH, PAPER_HEIGHT, MIN_HEIGHT, Copies: Integer;
  PrintRect, CalcRect, CalcRect2, HeaderRect, FooterRect: TRect;
  Text: String;
  SL : TStringList;
  Pages: array of Integer;
  { DrawHeaderFooter End}
  procedure DrawHeaderFooter(const AStr: string; ARect: TRect; AFlgs: Integer; APage: Integer);
  var
    Flgs: Integer;
    AlignFlg: Integer;
    P: PChar;
    Str: string;
    ChangeAlign: Boolean;
  begin
    if AStr = '' then
      Exit;
    Flgs := AFlgs or DT_NOPREFIX or DT_SINGLELINE;
    AlignFlg := DT_CENTER;
    Str := '';
    P := @AStr[1];
    while (P^ <> #$00) do
      begin
        if P^ = '&' then
          begin
            Inc(P);
            if P^ = #$00 then
              Break;
            ChangeAlign := False;
            case UpCase(P^) of
              'L', 'C', 'R':
                ChangeAlign := True;
              'D':
                Str := Str + FormatDateTime('YYYY"年"M"月"M"日"', Date);
              'T':
                Str := Str + FormatDateTime('h:n:s', Time);
              'F':
                begin
                  if FFileName = '' then
                    Str := Str + '無題'
                  else
                    Str := Str + TPath.GetFileName(FFileName);
                end;
              'P':
                Str := Str + APage.ToString;
              '&':
                Str := Str + '&';
            end;
            if (Str <> '') and ChangeAlign then
              begin
                DrawText(Printer.Canvas.Handle, PChar(Str), Length(Str), ARect, Flgs or AlignFlg);
                Str := '';
              end;
            case UpCase(P^) of
              'L': AlignFlg := DT_LEFT;
              'C': AlignFlg := DT_CENTER;
              'R': AlignFlg := DT_RIGHT;
            end;
          end
        else
          Str := Str + P^;
        Inc(P);
      end;
    if Str <> '' then
      begin
        DrawText(Printer.Canvas.Handle, PChar(Str), Length(Str), ARect, Flgs or AlignFlg);
        Str := '';
      end;
  end;
  { DrawHeaderFooter End}
  { DrawHeader Begin}
  procedure DrawHeader(APage: Integer);
  begin
    DrawHeaderFooter(HeaderStr, HeaderRect, DT_TOP, APage);
  end;
  { DrawHeader End}
  { DrawFooter Begin}
  procedure DrawFooter(APage: Integer);
  begin
    DrawHeaderFooter(FooterStr, FooterRect, DT_BOTTOM, APage);
  end;
  { DrawFooter End}
begin
  if not PrintDialog1.Execute then
    Exit;

  // プリンタの DPI
  X_DPI := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
  Y_DPI := GetDeviceCaps(Printer.Handle, LOGPIXELSY);

  // 用紙の幅と高さ
  PAPER_WIDTH  := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH );
  PAPER_HEIGHT := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT);

  // 印刷領域
  PrintRect.Top    :=                Trunc(PageSetupDialog1.MarginTop    / 2540 * Y_DPI);
  PrintRect.Left   :=                Trunc(PageSetupDialog1.MarginLeft   / 2540 * X_DPI);
  PrintRect.Bottom := PAPER_HEIGHT - Trunc(PageSetupDialog1.MarginBottom / 2540 * Y_DPI);
  PrintRect.Right  := PAPER_WIDTH  - Trunc(PageSetupDialog1.MarginRight  / 2540 * X_DPI);

  // 印刷
  Printer.BeginDoc;
  SetBkMode(Printer.Canvas.Handle, TRANSPARENT);
  Printer.Canvas.Font.Assign(Memo1.Font); // Memo1 のフォントを Canvas に割り当て

  Text := 'A';
  CalcRect := Rect(0, 0, Printer.PageWidth, 0);
  DrawText(Printer.Canvas.Handle, PChar(Text), Length(Text), CalcRect, CALC_FLG);
  MIN_HEIGHT := CalcRect.Bottom;

  if HeaderStr <> '' then
    begin
      HeaderRect := PrintRect;
      HeaderRect.Bottom := PrintRect.Top + MIN_HEIGHT * 2;
      PrintRect.Top := HeaderRect.Bottom;
    end;
  if FooterStr <> '' then
    begin
      FooterRect := PrintRect;
      FooterRect.Top := PrintRect.Bottom - MIN_HEIGHT * 2;
      PrintRect.Bottom := FooterRect.Top;
    end;
  PAGE_HEIGHT := PrintRect.Bottom - PrintRect.Top;

  SetLength(Pages, 1);
  SL := TStringList.Create;
  try
    SL.Text := Memo1.Lines.Text;

    // ページ数の計算
    LineCount := 0;
    Sum := 0;
    for i:=0 to SL.Count-1 do
      begin
        Text := SL[i];
        CalcRect := PrintRect;
        CalcRect.Top    := 0;
        CalcRect.Bottom := 0;
        DrawText(Printer.Canvas.Handle, PChar(Text), Length(Text), CalcRect, CALC_FLG);
        TextHeight := Max(MIN_HEIGHT, CalcRect.Bottom);
        if (Sum + TextHeight) > PAGE_HEIGHT then
          begin
            Pages[Length(Pages)-1] := LineCount;
            SetLength(Pages, Length(Pages) + 1);
            LineCount := 0;
            Sum := 0;
          end;
        Inc(LineCount);
        Inc(Sum, TextHeight);
      end;
    LineCount := SL.Count;
    for i:=0 to Length(Pages) - 2 do
      Dec(LineCount, Pages[i]);
    Pages[Length(Pages)-1] := LineCount;

    // 印刷
    if PrintDialog1.Collate then
      Copies := PrintDialog1.Copies // 部単位で印刷
    else
      Copies := 1;
    for j:=1 to Copies do
      begin
        CalcRect := PrintRect;
        Index := 0;
        for l:=0 to Length(Pages) - 1 do
          begin
            // ヘッダ
            DrawHeader(l+1);
            // テキスト
            CalcRect.Top := PrintRect.Top;
            for i:=0 to Pages[l] - 1 do
              begin
                CalcRect2 := PrintRect;
                CalcRect2.Top := 0;
                CalcRect2.Bottom := 0;
                Text := SL[Index];
                DrawText(Printer.Canvas.Handle, PChar(Text), Length(Text), CalcRect2, CALC_FLG);
                TextHeight := Max(MIN_HEIGHT, CalcRect2.Bottom);
                DrawText(Printer.Canvas.Handle, PChar(Text), Length(Text), CalcRect, DRAW_FLG);
                CalcRect.Top := CalcRect.Top + TextHeight;
                Inc(Index);
              end;
            // フッタ
            DrawFooter(l+1);
            // 改ページ
            if (l <> (Length(Pages) - 1)) or (J <> Copies) then
              Printer.NewPage;
          end;
      end;
  finally
    SL.Free;
  end;
  Printer.EndDoc;
end;

procedure TForm1.SaveFile;
var
  Enc: TEncoding;
begin
  // EncodingIndex によりエンコーディングを指定
  case FEncodingIndex of
    1: Enc := TEncoding.Unicode;
    2: Enc := TEncoding.BigEndianUnicode;
    3: Enc := TEncoding.UTF8;
  else
    Enc := TEncoding.Default;
  end;
  // エンコーディングを指定して保存
  Memo1.Lines.SaveToFile(FFileName, Enc);
end;

procedure TForm1.UpdateCaption;
// キャプション (ファイル名) の更新
var
  Dmy: String;
begin
  if FFileName = '' then
    Dmy := '無題'
  else
    Dmy := TPath.GetFileName(FFileName);
  Self.Caption := Dmy + ' - メモ帳クローン';
end;

end.

[行へ移動] ダイアログ
(変更ありません)

[ヘッダーとフッター] ダイアログ
(コードを書いていません)

[前の記事へ] [親記事へ] [次の記事へ]