// これは...
これは Delphi Advent Calendar 2017 15 日目の記事です。
長くなってしまったので機能単位で分割しています。
[ファイル(F)]
ここで [ファイル(F)] の実装に戻ります。印刷の実装がまだでしたね。
Delphi では簡易的なファイルの印刷に AssignPrn() を使う事ができますが、メモ帳にはヘッダーやフッター等があるため、この方法は使えません。
Delphi の Professional 以上の SKU には FastReport というレポートツールが付属するのでこれを使えば楽になります。他にも Delphi で使える商用レポートツールはいくつかあります。
Starter Edition でも使えるものには LightReport2 があります。
...が、今回はいずれも使わず、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 イベントハンドラの実装は以下のようになります。
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 も追加します。
- Vcl.Printers (DocWiki)
- Vcl.Printers.Printer (DocWiki)
- Delphi Tips - TPrinter オブジェクト (SupportKB)
- System.Math (DocWiki)
- System.Math.Max (DocWiki)
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)。
実装コードは以下の通りです。割とガチです。
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 イベントハンドラの実装は以下のようになります。
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 を追加します。
implementation
{$R *.dfm}
uses
frmuGotoLine,
frmuHeaderFooter; // <-- 追加
ヘッダーとフッターの値を保持するためのメンバー変数 (フィールド) も作っておきます。
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 イベントハンドラで初期値を入れておきます。
procedure TForm1.FormCreate(Sender: TObject);
// フォーム作成時
begin
FHeaderStr := '&f';
FFooterStr := 'ページ(&p)';
Init;
end;
acPrint ([印刷(P)]) のイベントハンドラを書き換えます。
procedure TForm1.acPrintExecute(Sender: TObject);
// Action: 印刷(P)
begin
PrintText(FHeaderStr, FFooterStr);
end;
次に acHeaderFooter のイベントハンドラを作ります。
acHeaderFooterExecute イベントハンドラは以下のようになります。
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)...] が実行される事を確認してください。
// 戻る
ほぼ完成です。印刷ロジックが長いですね。
今回はここまでです。ここまでの全ソースを掲載しておきます。
[メインフォーム]
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.
[行へ移動] ダイアログ
(変更ありません)
[ヘッダーとフッター] ダイアログ
(コードを書いていません)