private
{ Private 宣言 }
FBitmap: TBitmap;
// Rubber band
FRubberBandActive: Boolean;
・・・（省略）・・・
function ScreenToImagePoint(X, Y: Integer): TPoint;
で、次のように記述。
function TForm1.ScreenToImagePoint(X, Y: Integer): TPoint;
begin
Result.X := Round(X / FZoom);
Result.Y := Round(Y / FZoom);
end;
次は、PointInRectInclusive 関数を作成。まず宣言して、
private
{ Private 宣言 }
・・・（省略）・・・
function ScreenToImagePoint(X, Y: Integer): TPoint;
function PointInRectInclusive(const R: TRect; const P: TPoint): Boolean;
Shift＋Ctrl＋C して、次のように記述する。
function TForm1.PointInRectInclusive(const R: TRect; const P: TPoint): Boolean;
begin
Result :=
(P.X >= R.Left) and (P.X <= R.Right) and
(P.Y >= R.Top) and (P.Y <= R.Bottom);
end;
function TForm1.GetHandleAtPosImg(const P: TPoint): THandlePos;
const
HSIZE = 8;
var
cx: Integer;
begin
Result := hpNone;
// Top
cx := (FRubberRect.Left + FRubberRect.Right) div 2;
if Abs(P.Y - FRubberRect.Top) <= HSIZE then
begin
if Abs(P.X - FRubberRect.Left) <= HSIZE then Exit(hpLeftTop);
if Abs(P.X - FRubberRect.Right) <= HSIZE then Exit(hpRightTop);
if Abs(P.X - cx) <= HSIZE then Exit(hpTop);
end;
// Bottom
if Abs(P.Y - FRubberRect.Bottom) <= HSIZE then
begin
if Abs(P.X - FRubberRect.Left) <= HSIZE then Exit(hpLeftBottom);
if Abs(P.X - FRubberRect.Right) <= HSIZE then Exit(hpRightBottom);
if Abs(P.X - cx) <= HSIZE then Exit(hpBottom);
end;
//Left /Right
if Abs(P.X - FRubberRect.Left) <= HSIZE then Exit(hpLeft);
if Abs(P.X - FRubberRect.Right) <= HSIZE then Exit(hpRight);
end;
次は、CursorFromHandle 関数を宣言。
private
{ Private 宣言 }
・・・（省略）・・・
function CursorFromHandle(H: THandlePos): TCursor;
こちらも Shift＋Ctrl＋C して、次のように記述する。
function TForm1.CursorFromHandle(H: THandlePos): TCursor;
begin
case H of
hpLeft, hpRight:
Result := crSizeWE;
hpTop, hpBottom:
Result := crSizeNS;
hpLeftTop, hpRightBottom:
Result := crSizeNWSE;
hpRightTop, hpLeftBottom:
Result := crSizeNESW;
else
Result := crDefault;
end;
end;
procedure TForm1.UpdateRubberCursor;
begin
if FRubberBandActive then
PaintBox1.Cursor := crCross
else
PaintBox1.Cursor := crDefault;
end;
次は、PaintBox の OnMouseMove 手続きを作成。
オブジェクトインスペクタの OnMouseMove をダブルクリックする。
こちらは、次のように記述する。
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
curImg: TPoint;
screenPt: TPoint;
dx, dy: Integer;
H: THandlePos;
begin
if not FRubberBandActive then Exit;
curImg := ScreenToImagePoint(X, Y);
//ドラッグ中のみ自動スクロール
if FDragging then
begin
screenPt := PaintBox1.ClientToScreen(Point(X, Y));
AutoScrollIfNeededFromScreen(screenPt);
end;
//矢印キーの形状をより適切に
if not FDragging then
begin
if FHasRubber and PointInRectInclusive(FRubberRect, curImg) then
begin
H := GetHandleAtPosImg(curImg);
if H <> hpNone then
PaintBox1.Cursor := CursorFromHandle(H)
else
PaintBox1.Cursor := crSizeAll; //内部＝移動
end
else
PaintBox1.Cursor := crCross; //ラバーバンド描画モード
Exit;
end;
dx := curImg.X - FStartPointImg.X;
dy := curImg.Y - FStartPointImg.Y;
if FModeMoveSize then
begin
FRubberRect.Offset(dx, dy);
end
else
begin
case FDragHandle of
hpLeftTop:
begin
FRubberRect.Left := curImg.X;
FRubberRect.Top := curImg.Y;
end;
hpTop:
FRubberRect.Top := curImg.Y;
hpRightTop:
begin
FRubberRect.Right := curImg.X;
FRubberRect.Top := curImg.Y;
end;
hpRight:
FRubberRect.Right := curImg.X;
hpRightBottom:
begin
FRubberRect.Right := curImg.X;
FRubberRect.Bottom := curImg.Y;
end;
hpBottom:
FRubberRect.Bottom := curImg.Y;
hpLeftBottom:
begin
FRubberRect.Left := curImg.X;
FRubberRect.Bottom := curImg.Y;
end;
hpLeft:
FRubberRect.Left := curImg.X;
hpNone:
begin
FRubberRect.Right := curImg.X;
FRubberRect.Bottom := curImg.Y;
end;
end;
end;
FStartPointImg := curImg;
NormalizeRect(FRubberRect);
//画像エリアを超えないよう制限
if FRubberRect.Left < 0 then FRubberRect.Left := 0;
if FRubberRect.Top < 0 then FRubberRect.Top := 0;
if FRubberRect.Right > FBitmap.Width then FRubberRect.Right := FBitmap.Width;
if FRubberRect.Bottom > FBitmap.Height then FRubberRect.Bottom := FBitmap.Height;
PaintBox1.Invalidate;
end;
procedure TForm1.EnsureRubberVisible;
var
R: TRect;
p: TPoint;
begin
R := ImageToScreenRect(FRubberRect);
p := PaintBox1.ClientToScreen(Point(R.Left, R.Top));
AutoScrollIfNeededFromScreen(p);
end;
procedure TForm1.UpdateRubberInfo(const Prefix: string);
var
R: TRect;
begin
if not FHasRubber then Exit;
R := FRubberRect;
if Memo1.Lines.Count = 0 then
Memo1.Lines.Add('')
else
Memo1.Lines[Memo1.Lines.Count - 1] := ''; //最終行を書き換える
Memo1.Lines[Memo1.Lines.Count - 1] :=
Format('%sL:%d T:%d W:%d H:%d',
[Prefix, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top]);
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if not (FRubberBandActive and FHasRubber) then Exit;
case Key of
VK_LEFT:
if ssShift in Shift then Dec(FRubberRect.Right)
else FRubberRect.Offset(-1, 0);
VK_RIGHT:
if ssShift in Shift then Inc(FRubberRect.Right)
else FRubberRect.Offset(1, 0);
VK_UP:
if ssShift in Shift then Dec(FRubberRect.Bottom)
else FRubberRect.Offset(0, -1);
VK_DOWN:
if ssShift in Shift then Inc(FRubberRect.Bottom)
else FRubberRect.Offset(0, 1);
end;
NormalizeRect(FRubberRect);
PaintBox1.Invalidate;
//ラバーバンドの座標を取得
UpdateRubberInfo('Key ');
end;
現在、Image1上に描画されているラバーバンドの座標を取得するコードです。 ごく一般的な記述では 3-a の座標形式だと思いますが、実際の運用では解答欄の矩形座標を取得し、これを保存する際、印刷やスキャン時のズレの問題を解消するため、画像上の特徴点からの距離で座標を記録するようにしていますので、3-b はその例となっています。
//Ctrl+Cで選択範囲をクリップボードへ送る
if plImage1.Visible then
begin
//Ctrl + C（Shiftを含まない）のみ許可
if (Key = Ord('C')) and (ssCtrl in Shift) and not (ssShift in Shift) then
begin
//plResizeImage の「クリップボードへ送る」を実行
if Assigned(plImage1.MenuClipboardRef) then
begin
plImage1.MenuClipboardRef.Click;
end;
//ショートカットキーを他に伝播させない
Key := 0;
end;
end;
これで Ctrl + C で、ラバーバンドで囲んだ範囲を、クリップボードへ画像データとして送信できるようになりました。
とにかく、これまでの矩形検出プログラムで解答欄矩形の座標を検出して、採点する順番になるように並び替える際、横書き答案であれば「 Y 座標の値が小さいものから順に、左から右へ並べ替える」アルゴリズムを採用しているため、解答用紙の画像が左へ傾いていると、座標原点 0,0 が左上であるため、右側の解答欄ほど Y 座標の値が小さくなり、検出した座標を並び替える際に「上から下へ」の順番はなんとか守れても、「左から右へ」が「右から左へ」と、「一部の解答欄座標の並びが逆転」してしまうわけです。
以下は、Delphi に埋め込んで使用している「横書き答案の解答欄座標を検出して、採点順に並べ替える」 Python Script です（ダウンロードしていただいた Zip ファイルのサイズが大きいのも、展開に時間がかかるのも、Python 用の OpenCV をバックグラウンドで動作させているためです）。
import cv2
import numpy as np
def imread_unicode(path):
with open(path, "rb") as f:
data = f.read()
img_array = np.frombuffer(data, np.uint8)
return cv2.imdecode(img_array, cv2.IMREAD_COLOR)
def deskew_image(gray):
edges = cv2.Canny(gray, 50, 150, apertureSize=3)
lines = cv2.HoughLines(edges, 1, np.pi / 180, 150)
if lines is None:
return gray
horizontal_angles = []
for rho, theta in lines[:, 0]:
angle_deg = (theta * 180 / np.pi)
if (angle_deg < 10) or (angle_deg > 170):
adjusted_angle = angle_deg if angle_deg < 90 else angle_deg - 180
horizontal_angles.append(adjusted_angle)
if len(horizontal_angles) < 5:
return gray
mean_angle = np.mean(horizontal_angles)
if abs(mean_angle) < 0.3:
return gray
(h, w) = gray.shape
center = (w // 2, h // 2)
M = cv2.getRotationMatrix2D(center, mean_angle, 1.0)
rotated = cv2.warpAffine(gray, M, (w, h), flags=cv2.INTER_LINEAR, borderValue=255)
return rotated
def detect_inner_boxes(image_path):
img_color = imread_unicode(image_path)
if img_color is None:
raise FileNotFoundError(f"画像が見つかりません: {image_path}")
img_gray = cv2.cvtColor(img_color, cv2.COLOR_BGR2GRAY)
thresh = cv2.adaptiveThreshold(
img_gray, 255,
cv2.ADAPTIVE_THRESH_GAUSSIAN_C,
cv2.THRESH_BINARY_INV,
15, 10
)
contours, _ = cv2.findContours(thresh, cv2.RETR_TREE, cv2.CHAIN_APPROX_SIMPLE)
boxes = []
for cnt in contours:
x, y, w, h = cv2.boundingRect(cnt)
if w > ' + cmbThreshold.Text + ' and h > ' + cmbThreshold.Text + ':
boxes.append((x, y, w, h))
inner_boxes = []
for i, box in enumerate(boxes):
x1, y1, w1, h1 = box
rect1 = (x1, y1, x1 + w1, y1 + h1)
contains_other = False
for j, other in enumerate(boxes):
if i == j:
continue
x2, y2, w2, h2 = other
rect2 = (x2, y2, x2 + w2, y2 + h2)
if rect1[0] <= rect2[0] and rect1[1] <= rect2[1] and rect1[2] >= rect2[2] and rect1[3] >= rect2[3]:
contains_other = True
break
if not contains_other:
inner_boxes.append(box)
if not inner_boxes:
return []
y_tolerance = max(5, int(np.median([h for (_,_,_,h) in inner_boxes]) * 0.5))
inner_boxes.sort(key=lambda b: b[1])
sorted_boxes = []
current_row = []
current_y = None
for b in inner_boxes:
x, y, w, h = b
if current_y is None:
current_y = y
current_row.append(b)
elif abs(y - current_y) <= y_tolerance:
current_row.append(b)
else:
current_row.sort(key=lambda b: b[0])
sorted_boxes.extend(current_row)
current_row = [b]
current_y = y
if current_row:
current_row.sort(key=lambda b: b[0])
sorted_boxes.extend(current_row)
inner_boxes = sorted_boxes
for idx, (x, y, w, h) in enumerate(inner_boxes, start=1):
var1.Value = str(x) + "," + str(y) + "," + str(x + w) + "," + str(y + h)
return inner_boxes
if __name__ == "__main__":
image_path = r"' + 'CutImage0' + IntToStr(i) + '.jpg' + '"
boxes = detect_inner_boxes(image_path)
横書き答案で、ブロックの指定が２以上である場合がありますので、この処理を for ループの中に埋め込んでいます。また、この横書きでブロックの指定が２以上である答案の場合には、２ブロック目に検出した座標の値のｘ座標を一律補正するような処理も Delphi 側で必要ですが、核心部分はなんと言っても、上のスクリプトです。思えば、ここに至るまで、はや幾年月･･･
TplResizeImage = class(TImage)
private
FSelected : Boolean;
･･･
if FSelected then begin
Screen.Cursor := crSizeAll;
end else begin
Screen.Cursor := crDefault;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN] then
Screen.Cursor := crDefault;
end;
さらに、より確実に動作するよう OnKeyUp イベントにも同じ処理を記述します。
procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN] then
Screen.Cursor := crDefault;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
KeyPreview:=True;
end;
これで完璧かと思いましたが、Application.OnMessage を使ってグローバルに押されたキーを監視し、矢印キーが押された場合にはマウスのカーソルをデフォルトに戻す処理も追加しておくことにしました。こちらは構造的な意味でも、保守性を高める意味でも Form のメンバーとして記述します。こうしておけば、何年か経って今日の作業内容を完全に忘れてしまった場合でも、Private 宣言部分を参照すれば、何を設定したのかがわかり、メンテナンスしやすいコードにすることができます。
私は、そのような意味から、手続きだけでなく関数も Form のメンバーとして記述するようにしています。むかしは何でもかんでも Form のメンバーにしていたのですが、この Blog を書くようになってから、他から呼び出す必要のない手続きや関数は、「ネストされた手続き（Nested Procedure）」 または 「ネストされた関数（Nested Function）」 として記述することも多くなりました。コードを読むのと、（ Blog の記事用に）コピペするのが楽だからというのが、その主な理由です。
type
TForm1 = class(TForm)
...
private
//Application.OnMessage を使ったグローバルキー監視
procedure AppMessageHandler(var Msg: TMsg; var Handled: Boolean);
end;
で、Shift + Ctrl + C で手続きを作成し、実装します。
procedure TForm1.AppMessageHandler(var Msg: TMsg; var Handled: Boolean);
begin
case Msg.message of
WM_KEYDOWN, WM_KEYUP:
case Msg.wParam of
VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN:
Screen.Cursor := crDefault;
end;
end;
end;
最後に、FormCreate で登録しました。
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := AppMessageHandler;
end;
これで Form がアクティブ（フォーカスがある）な時も、非アクティブ（フォーカスがない）な時も、常にマウスのカーソルをリセットできるようになったはずです。
余談ですが、このマウスカーソルの形状も含めて画面のハードコピーを取るのはどうしたらいいものかと、今回、少し悩んでしまいました。Windows11の機能のみで行うなら、拡大鏡を固定（？）にして PrintScreen を実行すれば出来るみたいなことを AI が言ってましたが、せっかく Delphi があるんだし、ヒマもあったので、マウスカーソルの形状も含めて画面のハードコピーを取るプログラムを自分で書いてしまいました。後日、機会がありましたら、この Blog でご紹介したいと思います。
こちらの問題も修正しようかとも思いましたが、このプログラムを実行する場合、画面は最大化して作業するのが最も効率がよく、何か他の画面と並べて作業する必要性もないので、Form は常に最大化して表示する設定とし、通常 Form の右上にある最大化及び最小化ボタンは表示しないようにプログラムを変更しました。
また、通常の場合、最大化状態で Form のタイトルバーをクリックしてアクティブにし、そのままタイトルバーをドラッグ＆ドロップすると Window 内の任意の位置へ、設計時の大きさになった Form を移動できますが、上記の理由から、この時やはりラバーバンド位置が解答欄矩形からズレます。これを防止するため、Form のタイトルバーをクリックしてドラッグ＆ドロップする機能は無効化しました。
この Form の設定に使用したコードは、以下の通りです。
private
//最初に１回だけ設定を実行するための確認フラグ
F_FormActivated: Boolean;
//タイトルバーは残したまま「最大化解除できない」ように設定
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
procedure WMNCLButtonDown(var Msg: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
procedure TForm1.FormCreate(Sender: TObject);
begin
//Formの最大化ボタン及びドラッグ＆ドロップを制御（禁止）する
F_FormActivated := False;
//最大化して表示する
Form1.WindowState := wsMaximized;
//ここで実行するとFormがタスクバーを覆い隠してしまう -> FormActiveで実行する
//BorderIcons := [biSystemMenu, biMinimize];
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
if not F_FormActivated then
begin
BorderIcons := [biSystemMenu];
F_FormActivated := True;
end;
end;
procedure TForm1.WMNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
if Msg.HitTest = HTCAPTION then
Exit; // タイトルバーをドラッグしても動かせない
inherited;
end;
procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
// 「元に戻す」「サイズ変更」を禁止
if (Msg.CmdType = SC_RESTORE) or (Msg.CmdType = SC_SIZE) then
begin
Exit;
end;
inherited;
end;
procedure TForm1.Memo2Click(Sender: TObject);
var
i:integer;
p1,p2:TPoint;
function RemoveToken(var s:string;delimiter:string):string;
var
p:Integer;
begin
p:=Pos(delimiter,s);
if p=0 then Result:=s
else Result:=Copy(s,1,p-1);
s:=Copy(s,Length(Result)+Length(delimiter)+1,Length(s));
end;
function GetTokenIndex(s:string;delimiter:string;index:Integer):string;
var
i:Integer;
begin
Result:='';
for i:=0 to index do
Result:=RemoveToken(s,delimiter);
end;
begin
if not EditTF then
begin
//座標を取得
i:=Memo2.Perform(EM_LINEFROMCHAR, Memo2.SelStart, 0);
//エラー対策
if Memo2.Lines[i]='' then Exit;
x1:=StrToInt(GetTokenIndex(Memo2.Lines[i],',',0));
y1:=StrToInt(GetTokenIndex(Memo2.Lines[i],',',1));
x2:=StrToInt(GetTokenIndex(Memo2.Lines[i],',',2));
y2:=StrToInt(GetTokenIndex(Memo2.Lines[i],',',3));
if Assigned(plImage1) then begin
FreeAndNil(plImage1);
end;
//コンポーネントを生成し，イベントを定義し，位置を指定して画像を表示
plImage1:= TplResizeImage.Create(Self);
plImage1.Parent:= ScrollBox1;
plImage1.TransEvent:= True;
//画像内座標
p1 := Point(x1, y1);
p2 := Point(x2, y2);
//クライアント座標 -> スクリーン座標（Image1基準）
p1 := Image1.ClientToScreen(p1);
p2 := Image1.ClientToScreen(p2);
//スクリーン座標 -> フォームのクライアント座標（Form基準）
p1 := Form1.ScreenToClient(p1);
p2 := Form1.ScreenToClient(p2);
//ラバーバンドの座標を設定（フォームのクライアント座標で配置）
plImage1.SetBounds(p1.X, p1.Y, p2.X - p1.X, p2.Y - p1.Y);
//SelectedプロパティをTrueにするとラバーバンドとグラブハンドルが表示される
plImage1.Selected := True;
plImage1.BringToFront;
end;
end;
詳しいことはわかりませんが、この表示位置は私の方で何かした覚えがありませんので、おそらく OS 側で決めているのではないか･･･と思うのですが、やはり、これは何とかしたいところです。
私は普段は「1366×768」サイズに設定したモニターを使ってプログラムを書いています。職場ではもっと高解像度のモニターを与えられていますが、もともと大きさ的に限界のあるノート PC のモニターに必要以上の解像度設定は不要だと思います。若い方ならいざ知らず、年寄りには小さな画面＆高解像度のモニター環境は厳しすぎる気がします。
で、通常状態に戻ったときに Form を中央に表示する AdjustFormPosition 手続きは･･･
procedure TForm1.AdjustFormPosition;
var
WorkArea: TRect;
begin
//フォームが属しているモニタのワークエリアを取得（マルチモニタ対応）
WorkArea := Monitor.WorkareaRect;
//横方向の調整
if Width < (WorkArea.Right - WorkArea.Left) then
Left := WorkArea.Left + ((WorkArea.Right - WorkArea.Left) - Width) div 2
else
//はみ出す場合は左端に寄せる
Left := WorkArea.Left;
//縦方向の調整
if Height < (WorkArea.Bottom - WorkArea.Top) then
Top := WorkArea.Top + ((WorkArea.Bottom - WorkArea.Top) - Height) div 2
else
//はみ出す場合は上端に寄せる
Top := WorkArea.Top;
end;
FormCreate 時に、Form の状態を取得しておきます。
procedure TForm1.FormCreate(Sender: TObject);
begin
//「最大化->元に戻す」で画面の中央に表示
FPrevWindowState := WindowState;
procedure TForm1.FormResize(Sender: TObject);
var
//for 高さの調整
MemoHight, btnHight:integer;
begin
//VCLの高さを調整
･･･ 省略 ･･･
//「最大化->元に戻す」で画面の中央に表示
//ユーザーが普通にフォームをドラッグして幅や高さを変えた場合を除外
if (FPrevWindowState = wsMaximized) and (WindowState = wsNormal) then
AdjustFormPosition;
FPrevWindowState := WindowState; //最新の状態を保存
end;
実行して、非最大化時の動作を確認します。
Form は、画面の中央に表示されました！
できたー☆
予定した（と言うか、気がついた）修正作業は、全部、無事完了しました！
どなた様も、お待ちになってないことと思いますが･･･
８．ダウンロードのご案内
今回、全面的に不具合を修正しました、この「解答欄矩形の座標を検出するプログラム」と、先日この Blog でご紹介した「自動採点機能みたいなモノを搭載した手書き答案の採点補助プログラム（こちらも様々に内在していた不具合を修正し、Version 3.1.0 としました）」及び「マークシートリーダー」、「採点結果通知表並びに成績一覧表作成プログラム」他を１つにまとめた zip ファイルを下記リンク先からダウンロードすることができます。
お使いの PC の設定によっては、ファイルの拡張子が表示されない場合もあると思います。その場合は、エクスプローラーの画面上部にある「表示」をクリックすると表示されるサブメニューのいちばん下にある「表示」をクリック（ or ポイント）し、横に表示されるサブメニューの「ファイル名拡張子」をクリックしてチェックマークを付けると拡張子が表示されます。
この PDF ファイルを「そのまま印刷して利用する」のであれば、もちろん何も問題など生じませんが、紙媒体でなく、そのまま電子データとして、例えば、重い障害のある方が iPad の Goodnotes で読み込んで利用するような場合、正しい方向に戻す（＝回転させる）ひと手間が（その方から見れば余計に）必要です。
たかが「ひと手間」ですが、この「ひと手間」が「ある」と「ない」とでは、当該 PDF ファイルを受け取った方の「気持ち」は大きく違ってくるのではないでしょうか？
しかも、それが毎回のことになると･･･
そのような観点から、手軽に PDF ファイルの向きを変換して、その状態を保存できるプログラムがないかと探してみたのですが、Web 上にデータをアップロードする必要があったり、例えその問題はクリアできても通信環境によっては、変換に「ちょっと我慢できないくらいの時間」を要したり、はたまたローカル環境 Only で作業できたとしても「単に向きを変換」するだけの工程の手順が、正直、とても使いにくいと感じてしまったり･･･、
「ただ向きを変える」それだけのことで、探し当てたどの方法を使っても、こんなにイライラするのであれば、（自分の知識と技術だけで PDF ファイルの向きを変更するプログラムなど、間違っても書けるわけがありませんので）サードパーティー製（？）ソフトウェアを使わせていただいて PDF ファイルを好きな向きに変更して保存できるプログラムを、自分で書けばいいのではないか？ と思った次第です。
自分の技術では PDF ファイルの内容をどうこうすることは到底できません。中身がどうなっているのかも、以前、ちょっとだけ勉強したことはあるのですが、今は全部忘れました。でも、他人様のお作りになられたとても良い Tool がたくさん公開されています。PDF ファイル操作のユーティリティは多数ありますが、あれこれダウンロードして実際に試用させていただき、今回は PDFtk Server を使わせていただくことにしました。
この PDFtk Server ですが、プラットフォームは、Windows、macOS、Linux に対応しており、PDF ファイルのマージ・分割・回転・その他、幅広い PDF 操作をコマンドラインで実行できる ユーティリティであるとのこと。
PDFtk Server のライセンスは、GNU GPL バージョン2 なので、非商用の個人利用であれば無償で使用可能です。ただし、GPLの下では自分のソフトウェアに PDFtk Server を同梱して、そのソフトウェアを配布する場合には、ソースコードの公開義務などが適用されますので、今回作成するソフトウェアでは PDFtk Server が動作に必要なことを明示して、利用者の責任で PDFtk Server のダウンロードをしていただき、プログラムの動作に必要な環境の整備を行ってもらう形をとりたいと思います。
操作方法は、回転させたい PDF ファイルを選択して、回転方向を選ぶ（オプションボタンをクリックする）だけです。回転を実行するボタンをクリックしなくても、回転方向を選んだだけで即回転が実行される機能を実現するチェックボックスも用意しました。
【注意】このプログラムは、ページを指定しての回転は実行することができません。
当初、回転した状態のプレビューを表示するような方向性も考えたのですが、たった３パターンの回転しかありませんし、ファイルの保存にもそれほど時間はかからない（何百ページもあるような PDF 文書はそもそも想定外で動作確認しておりませんので、それが必要な場合は利用者様各自の責任で検証作業を行っていただき、その結果に応じました運用をお願い申し上げます）ので、やや乱暴かもしれませんが、プログラムはオプションボタンをクリックするごとに回転を実行し、ファイルを固有の名称で（上書き）保存してしまう仕様としました。
コントロールが異なると、パスの区切り文字の表記が￥マークと \（バックスラッシュ）になるのは、それぞれのコントールの Font の違いによるものと思われます･･･。
５．CreateProcess で回転を実行
プログラムの設計当初、PDF ファイルの回転処理は先に記載した通り ShellExecute で実行していたのですが、プログラムの動作検証を行った際、200ページ以上ある PDF ファイルを回転元ファイルに指定したら、回転に失敗してしまいました。
ShellExecute では、何が起きて回転に失敗してしまったのかが皆目わかりませんので、原因を究明すべく、回転処理の実行（ PDFtk Server の呼び出しと実行部分）を CreateProcess に変更し、エラーが発生した場合はメッセージを PDFtk Server から取得して表示できるよう、次のようにプログラムを修正しました。
private
{ Private 宣言 }
//PDFtkでコマンドを実行
function RunPdftk(const ExePath, Params: string; out OutputStr: string): Boolean;
procedure TForm1.Button2Click(Sender: TObject);
var
InputFile, OutputFile, RotateArg: string;
Params, Msg:string;
strMsg: string;
begin
//カーソルを待機状態に変更
Screen.Cursor:=crHourGlass;
//CreateProcessで実行
try
PDFTK_PATH := ExtractFilePath(Application.ExeName) + 'pdftk.exe';
if not FileExists(PDFTK_PATH) then
begin
StatusBar1.SimpleText := 'pdftk.exe が見つかりません';
Exit;
end;
InputFile := strSrcPDFName;
if not FileExists(InputFile) then
begin
StatusBar1.SimpleText := 'PDFファイルが存在しません';
Exit;
end;
case RadioGroup1.ItemIndex of
0: RotateArg := 'west'; // 270°
1: RotateArg := 'south'; // 180°
2: RotateArg := 'east'; // 90°
else
StatusBar1.SimpleText := '回転方向を選択してください';
Exit;
end;
OutputFile := ChangeFileExt(strDstPDFName, '') + '_' + RotateArg + '.pdf';
strDstPDFName := OutputFile;
//end%sが正しい（end %sとしないこと:半角スペースは不要）
Params := Format('"%s" cat 1-end%s output "%s"', [
InputFile, RotateArg, OutputFile
]);
if RunPdftk(PDFTK_PATH, Params, Msg) then
begin
StatusBar1.SimpleText := FitPathWithMiddleEllipsis(
OutputFile, StatusBar1.Font, StatusBar1.ClientWidth);
if Msg.Trim <> '' then
begin
//ShowMessage('pdftk 出力: ' + Msg);
//コピーできるメッセージを表示する
strMsg:= 'pdftk 出力: ' + Msg + #13#10 + #13#10 +
'"Copied to clipboard"';
//Clipboard.AsText := strMsg; // クリップボードにコピー
Clipboard.AsText := Msg;
//ShowMonospaceMessage(strMsg);
//ShowMessage(strMsg);
Application.MessageBox(PChar(strMsg), PChar('エラー'), MB_ICONERROR);
end;
Sleep(500);
WebBrowser1.Navigate('file:///' + StringReplace(OutputFile, '\', '/', [rfReplaceAll]));
end
else
begin
StatusBar1.SimpleText := 'pdftk の実行に失敗しました';
if Msg.Trim <> '' then
ShowMessage('エラー詳細: ' + Msg);
end;
finally
//名前を元に戻しておく！
strSrcPDFName := OpenDialog1.FileName;
strDstPDFName := StringReplace(strSrcPDFName, 'SrcPDF', 'DstPDF', [rfReplaceAll, rfIgnoreCase]);
Screen.Cursor := crDefault;
end;
end;
function TForm1.RunPdftk(const ExePath, Params: string;
out OutputStr: string): Boolean;
var
SI: TStartupInfo;
PI: TProcessInformation;
SA: TSecurityAttributes;
StdOutRead, StdOutWrite: THandle;
Buffer: array[0..1023] of Byte;
BytesRead: DWORD;
OutputBytes: TBytes;
CmdLine: string;
begin
//Result := False;
OutputStr := '';
if not FileExists(ExePath) then
raise Exception.CreateFmt('実行ファイルが見つかりません: %s', [ExePath]);
ZeroMemory(@SA, SizeOf(SA));
SA.nLength := SizeOf(SA);
SA.bInheritHandle := True;
if not CreatePipe(StdOutRead, StdOutWrite, @SA, 0) then
RaiseLastOSError;
try
try
SetHandleInformation(StdOutRead, HANDLE_FLAG_INHERIT, 0);
ZeroMemory(@SI, SizeOf(SI));
SI.cb := SizeOf(SI);
SI.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
SI.wShowWindow := SW_HIDE;
SI.hStdOutput := StdOutWrite;
SI.hStdError := StdOutWrite;
ZeroMemory(@PI, SizeOf(PI));
CmdLine := Format('"%s" %s', [ExePath, Params]);
if not CreateProcess(
nil, PChar(CmdLine), nil, nil, True,
CREATE_NO_WINDOW, nil, nil, SI, PI) then
RaiseLastOSError;
CloseHandle(StdOutWrite);
SetLength(OutputBytes, 0);
repeat
if not ReadFile(StdOutRead, Buffer, SizeOf(Buffer), BytesRead, nil) then
Break;
if BytesRead > 0 then
begin
//W1024 符号付型と符号無し型の演算による、オペランドの拡張」と警告される
//SetLength(OutputBytes, Length(OutputBytes) + BytesRead);
//対策１:BytesRead を明示的に Integer にキャストする
SetLength(OutputBytes, Length(OutputBytes) + Integer(BytesRead));
//対策２:Length を NativeInt にキャストする（より安全か？）
//SetLength(OutputBytes, NativeInt(Length(OutputBytes)) + NativeInt(BytesRead));
//W1024 符号付型と符号無し型の演算による、オペランドの拡張」と警告される
//Move(Buffer[0], OutputBytes[Length(OutputBytes) - BytesRead], BytesRead);
//対策１:BytesRead を明示的に Integer にキャストする
Move(Buffer[0], OutputBytes[Length(OutputBytes) - Integer(BytesRead)], BytesRead);
end;
until BytesRead = 0;
WaitForSingleObject(PI.hProcess, INFINITE);
CloseHandle(PI.hProcess);
CloseHandle(PI.hThread);
if Length(OutputBytes) > 0 then
OutputStr := TEncoding.UTF8.GetString(OutputBytes);
Result := True;
except
on E: Exception do
begin
OutputStr := E.Message;
Result := False;
end;
end;
finally
CloseHandle(StdOutRead);
end;
end;
PDFtk Server の実行は、RunPdftk 関数側で行っています。
こうして CreateProcess での PDFtk Server の呼び出しに実行方法を変更し、何か問題が発生した場合には PDFtk Server 側からのエラーメッセージを取得して表示するようにできました。早速、先ほど回転に失敗した巨大な PDF ファイルを再度指定して、回転を実行してみました。
PDF_Rotator.exe をダブルクリックして起動後、回転させたい PDF ファイルを選択し、回転方向を指定してください。デフォルト設定では、回転方向の指定と同時に PDF ファイルの回転と保存が行われます。回転後の PDF ファイルは、左へ回転した場合は「元のファイル名_west.pdf」、上下反転した場合は「元のファイル名_south.pdf」、右へ回転した場合は「元のファイル名_east.pdf」のように北を上とした場合の方角が付加されて DstPDF フォルダ内に保存されます。
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.Grids, Vcl.StdCtrls;
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
CheckBox1: TCheckBox;
procedure FormCreate(Sender: TObject);
procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: LongInt;
var CanSelect: Boolean);
procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: LongInt;
Rect: TRect; State: TGridDrawState);
procedure StringGrid1KeyPress(Sender: TObject; var Key: Char);
procedure StringGrid1SetEditText(Sender: TObject; ACol, ARow: LongInt;
const Value: string);
private
{ Private 宣言 }
//StringGridの列数を設定 -> FormCreate時に設定する
StrGrid1ColCount: Integer;
//Formの表示終了イベントを取得
procedure CMShowingChanged(var Msg:TMessage); message CM_SHOWINGCHANGED;
public
{ Public 宣言 }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.CMShowingChanged(var Msg: TMessage);
begin
inherited; {通常の CMShowingChagenedをまず実行}
if Visible then
begin
Update; {完全に描画}
//セットフォーカス
StringGrid1.Col:=1;
StringGrid1.Row:=1;
StringGrid1.SetFocus;
//セルの編集を開始（ユーザーのクリックを待つ場合はコメント化する）
StringGrid1.Options := StringGrid1.Options + [goEditing];
//カーソルが見えるようにする
StringGrid1.EditorMode:=True;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i:integer;
begin
//列数
StrGrid1ColCount:=3;
StringGrid1.ColCount:=StrGrid1ColCount;
//FixedCols & FixedRows（固定列と固定行）を設定
StringGrid1.FixedCols:=1;
StringGrid1.FixedRows:=1;
StringGrid1.Rows[0].CommaText:='番号,連番,TF';
//FixedRows（固定行）に値をセット
for i:= 1 to StringGrid1.RowCount do
begin
StringGrid1.Rows[i].Append(IntToStr(i));
end;
end;
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: LongInt;
Rect: TRect; State: TGridDrawState);
begin
if StringGrid1.Cells[ACol,ARow]<>'' then
begin
//背景色を白に設定
StringGrid1.Canvas.Brush.Color:=clWhite;
//セルを塗りつぶす
StringGrid1.Canvas.FillRect(Rect);
//テキストを表示（中央寄せ）
DrawText(StringGrid1.Canvas.Handle,
PChar(StringGrid1.Cells[ACol,ARow]),
//[+1]は数値描画位置の調整のため
Length(StringGrid1.Cells[ACol,ARow])+1,Rect,
DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;
end;
procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);
begin
//[Enter]キーでコントロールを移動
if Ord(Key)=VK_RETURN then
begin
if ActiveControl is TStringGrid then
begin
if TStringGrid(ActiveControl).EditorMode then
begin
//VK_TABではカーソルがレコードの項目を右へ移動。
//ActiveControl.Perform(WM_KEYDOWN,VK_TAB,0);
//VK_DOWNにすると同じ項目の次のレコードへ移動。
ActiveControl.Perform(WM_KEYDOWN,VK_DOWN,0);
Key:=#0;
end;
end else begin
SelectNext(ActiveControl,True,True);
Key:=#0;
end;
end;
end;
列の編集の可否を制御したい場合は、以下のコードで実現可能。
procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, ARow: LongInt;
var CanSelect: Boolean);
begin
//列の編集の可否
if (ACol=StrGrid1ColCount-1) then
begin
//セルの編集は不可
TStringGrid(Sender).Options:=TStringGrid(Sender).Options-[goEditing];
end else begin
//セルは編集可能
TStringGrid(Sender).Options:=TStringGrid(Sender).Options+[goEditing];
end;
end;
procedure TForm1.StringGrid1SetEditText(Sender: TObject; ACol, ARow: LongInt;
const Value: string);
var
NewValue: Integer;
procedure UpdateColumnData(StartRow, NewValue: Integer);
var
i: Integer;
begin
for i := StartRow + 1 to StringGrid1.RowCount - 1 do
StringGrid1.Cells[StrGrid1ColCount-2, i] := IntToStr(NewValue + 1);
end;
begin
//チェックボックスがチェックされていたら
if CheckBox1.Checked then
begin
//行を自動入力
if ACol = StrGrid1ColCount-2 then
begin
if TryStrToInt(Value, NewValue) then
begin
UpdateColumnData(ARow, NewValue);
end;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
ColumnValues: TStringList;
i: Integer;
ErrorRows: TStringList;
ErrorMessage: string;
function IsSequential(Column: TStrings; out ErrorRows: TStringList): Boolean;
var
k, CurrentValue, ExpectedValue: Integer;
begin
Result := True; //初期状態で連番と仮定
ErrorRows.Clear;
if Column.Count = 0 then
Exit; //空の場合は連番とみなす
CurrentValue := StrToInt(Column[0]);
for k := 1 to Column.Count - 1 do
begin
//現在の値が同じであれば次の行へ
if StrToInt(Column[k]) = CurrentValue then
begin
Continue;
end else begin
//現在の値が変わった場合、期待される次の値は1増加
ExpectedValue := CurrentValue + 1;
//期待される次の値と一致しなければ連番ではない（同じ値のくり返しは許可する）
//if StrToInt(Column[k]) <> ExpectedValue then
if (StrToInt(Column[k]) = CurrentValue) or
(StrToInt(Column[k]) <> ExpectedValue) then
begin
Result := False;
//エラーの行番号を追加（1から始まるインデックスのため +1）
ErrorRows.Add(IntToStr(k + 1));
Exit;
end else begin
CurrentValue := ExpectedValue;
end;
end;
end;
end;
begin
//連番になっていることを確認
ColumnValues := TStringList.Create;
ErrorRows := TStringList.Create;
try
//StringGridの第1列（インデックス0）を取得
for i := 1 to StringGrid1.RowCount - 1 do
begin
ColumnValues.Add(StringGrid1.Cells[1, i]);
end;
if IsSequential(ColumnValues, ErrorRows) then
begin
ShowMessage('連番です'); //確認用
end else begin
//連番でない行がある場合のメッセージ
ErrorMessage := ErrorRows.CommaText + ' 行目が連番ではありません！';
Application.MessageBox(PChar(ErrorMessage), PChar('エラー'), MB_ICONSTOP);
StringGrid1.Col:=1;
StringGrid1.Row:=StrToInt(ErrorRows.CommaText);
StringGrid1.SetFocus;
Exit;
end;
finally
ColumnValues.Free;
ErrorRows.Free;
end;
end;
実行（F9）して、動作テスト。
10行目にわざと連番ではない値を入力して動作テスト
同じ値の繰り返しは許可するようにコーディングしたので、次のような場合は連番と判断する。
//期待される次の値と一致しなければ連番ではない（同じ値のくり返しは許可する）
//if StrToInt(Column[k]) <> ExpectedValue then
if (StrToInt(Column[k]) = CurrentValue) or
(StrToInt(Column[k]) <> ExpectedValue) then
begin
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: LongInt;
Rect: TRect; State: TGridDrawState);
var
Value: String;
CellColor: TColor;
ColorMap: TDictionary<String, TColor>;
function GetLightColor(BaseColor: TColor): TColor;
var
R, G, B: Byte;
pct: Double; //パーセントを指定する変数
begin
// RGB値を取得
R := GetRValue(ColorToRGB(BaseColor));
G := GetGValue(ColorToRGB(BaseColor));
B := GetBValue(ColorToRGB(BaseColor));
//薄い色に調整（50%白に近づける場合）
//R := (R + 255) div 2;
//G := (G + 255) div 2;
//B := (B + 255) div 2;
//80%白に近づける場合
//元のRGB値を20%だけ残し、残りの80%を白（255, 255, 255）に近づける
//R := Round(R * 0.2 + 255 * 0.8);
//G := Round(G * 0.2 + 255 * 0.8);
//B := Round(B * 0.2 + 255 * 0.8);
//薄い色に調整
pct:=StrToFloat('0.' + ComboBox1.Text);
R := Round(R * (1-pct) + 255 * pct);
G := Round(G * (1-pct) + 255 * pct);
B := Round(B * (1-pct) + 255 * pct);
Result := RGB(R, G, B);
end;
procedure AssignColorsToValues(ACol: Integer);
var
i: Integer;
Value: String;
BaseColors: TArray<TColor>; //動的配列として宣言（解放はDelphiにまかせる）
ColorIndex: Integer;
begin
ColorMap.Clear;
ColorIndex := 0;
BaseColors:=[clRed, clGreen, clBlue, clYellow, clAqua, clFuchsia];
for i := 1 to StringGrid1.RowCount - 1 do
begin
Value := StringGrid1.Cells[ACol, i];
if not ColorMap.ContainsKey(Value) then
begin
//色を薄く調整したものを登録
ColorMap.Add(Value, GetLightColor(BaseColors[ColorIndex mod Length(BaseColors)]));
Inc(ColorIndex);
end;
end;
end;
begin
//前掲のコードは、Gridの初期化も兼ねる
if StringGrid1.Cells[ACol,ARow]<>'' then
begin
//背景色を白に設定
StringGrid1.Canvas.Brush.Color:=clWhite;
//セルを塗りつぶす
StringGrid1.Canvas.FillRect(Rect);
//テキストを表示（中央寄せ）
DrawText(StringGrid1.Canvas.Handle,
PChar(StringGrid1.Cells[ACol,ARow]),
//[+1]は数値描画位置の調整のため
Length(StringGrid1.Cells[ACol,ARow])+1,Rect,
DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;
if ARow = 0 then Exit; //ヘッダー行はスキップ
ColorMap := TDictionary<String, TColor>.Create;
//色分け対象列を指定
AssignColorsToValues(1); //ColorMapをCreateしてから呼び出すこと！
try
if ACol = 1 then //対象列をチェック
begin
Value := StringGrid1.Cells[ACol, ARow];
if ColorMap.TryGetValue(Value, CellColor) then
begin
StringGrid1.Canvas.Brush.Color := CellColor;
StringGrid1.Canvas.FillRect(Rect);
//テキストを表示（中央寄せ）_[+1]は数値描画位置の調整のため
DrawText(StringGrid1.Canvas.Handle,
PChar(StringGrid1.Cells[ACol,ARow]),
Length(StringGrid1.Cells[ACol,ARow])+1,Rect,
DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;
end else begin
StringGrid1.Canvas.FillRect(Rect);
//テキストを表示（中央寄せ）_[+1]は数値描画位置の調整のため
DrawText(StringGrid1.Canvas.Handle,
PChar(StringGrid1.Cells[ACol,ARow]),
Length(StringGrid1.Cells[ACol,ARow])+1,Rect,
DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;
finally
ColorMap.Free;
end;
end;
さらに、FormCreate 手続きで ComboBox の選択肢の準備と初期化を行うように設定。
procedure TForm1.FormCreate(Sender: TObject);
var
i:integer;
begin
//前掲の通りなので略
//色の濃さを調節
for i := 1 to 99 do
begin
ComboBox1.Items.Add(IntToStr(i));
end;
//初期値を設定
ComboBox1.Text:='50';
end;
procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, ARow: LongInt; var CanSelect: Boolean); begin //列の編集の可否 if (ACol=StrGrid1ColCount-1) then begin //セルの編集は不可 TStringGrid(Sender).Options:=TStringGrid(Sender).Options-[goEditing]; end else begin //セルは編集可能 TStringGrid(Sender).Options:=TStringGrid(Sender).Options+[goEditing]; end; end;
procedure TForm1.ToggleSGCell(ACol, ARow: Integer);
begin
//現在の値を切り替え
if StringGrid1.Cells[ACol, ARow] = '1' then
StringGrid1.Cells[ACol, ARow] := '0'
else
StringGrid1.Cells[ACol, ARow] := '1';
//再描画をトリガ（即座に変更を表示）
StringGrid1.Invalidate;
end;
UpdateColumnData のコードは、次の通り。
procedure TForm1.UpdateColumnData(Value: Integer; IsChecked: Boolean);
var
i: Integer;
NewValue: string;
begin
if IsChecked then
begin
NewValue := '1';
end else begin
NewValue := '0';
end;
for i := 1 to StringGrid1.RowCount - 1 do
begin
if StrToInt(StringGrid1.Cells[StrGrid1ColCount-2, i]) = Value then
begin
StringGrid1.Cells[StrGrid1ColCount-1, i] := NewValue;
end;
end;
//再描画をトリガ（即座に変更を表示）
StringGrid1.Invalidate;
end;
procedure TForm1.StringGrid1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
ACol, ARow: Integer;
begin
//マウスでクリックして、指を離したときのイベント
StringGrid1.MouseToCell(X, Y, ACol, ARow);
//if (ACol = StrGrid1ColCount-1) and (ARow >= 0) then
//0行目（FixedRow）では動作しないように設定
if (ACol = StrGrid1ColCount-1) and (ARow > 0) then
//UpdateColumnData(ARow);
//引数にはCMS設定値が入る
UpdateColumnData(StrToInt(StringGrid1.Cells[StrGrid1ColCount-2, ARow]), True);
end;
TF列の任意のセルをクリックして、スペースキー押し下げで入力値を「０」に切り替える。
procedure TForm1.StringGrid1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
//スペースキーで０と１を切り替え
if (StringGrid1.Col = StrGrid1ColCount-1) and (StringGrid1.Row > 0) and (Key = VK_SPACE) then
begin
ToggleSGCell(StringGrid1.Col, StringGrid1.Row);
UpdateColumnData(StrToInt(StringGrid1.Cells[StrGrid1ColCount-2, StringGrid1.Row]), False);
Key := 0;
end;
end;
TF列をゼロで初期化するため、FormCreate 手続きの既存のコードに次のコードを追加。
//FixedRows（固定行）に値をセット
for i:= 1 to StringGrid1.RowCount do
begin
StringGrid1.Rows[i].Append(IntToStr(i));
//TF列をゼロで初期化
StringGrid1.Cells[2,i] := '0';
end;
Combination Matching System -> 組み合わせの「一致性」に基づく評価。 Combination Marking System -> 採点（marking）を強調。教育や試験で使える表現。 Composite Marking System -> 要素を統合してスコアを出す評価システム。
いずれも頭文字を組み合わせると CMS になる。 自分的には、マークシートの採点だから Combination Marking System かな？
それから「順不同」を英語で言うと、No Particular Order だから、こちらは略して NPO だ。
procedure TForm1.UpdateColumnData(Value: Integer; IsChecked: Boolean);
var
i: Integer;
NewValue: string;
begin
if IsChecked then
begin
NewValue := '1';
end else begin
NewValue := '0';
end;
for i := 1 to StringGrid1.RowCount - 1 do
begin
if StrToInt(StringGrid1.Cells[StrGrid1ColCount-2, i]) = Value then
begin
StringGrid1.Cells[StrGrid1ColCount-1, i] := NewValue;
end;
end;
end;
procedure TForm1.StringGrid1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
ACol, ARow: Integer;
begin
//マウスでクリックして、指を離したときのイベント
StringGrid1.MouseToCell(X, Y, ACol, ARow);
if (ACol = StrGrid1ColCount-1) and (ARow >= 0) then
//引数にはCMS設定値が入る
UpdateColumnData(StrToInt(StringGrid1.Cells[StrGrid1ColCount-2, ARow]), True);
end;
private
procedure UpdateColumnData(Value: Integer; IsChecked: Boolean);
procedure TForm1.UpdateColumnData(Value: Integer; IsChecked: Boolean);
var
i: Integer;
NewValue: string;
begin
if IsChecked then
begin
NewValue := '1';
end else begin
NewValue := '0';
end;
for i := 1 to StringGrid1.RowCount - 1 do
begin
if StrToInt(StringGrid1.Cells[StrGrid1ColCount-2, i]) = Value then
begin
StringGrid1.Cells[StrGrid1ColCount-1, i] := NewValue;
end;
end;
//再描画をトリガ（即座に変更を表示）
StringGrid1.Invalidate;
end;
procedure TForm1.StringGrid1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
ACol, ARow: Integer;
begin
//マウスでクリックして、指を離したとき実行
StringGrid1.MouseToCell(X, Y, ACol, ARow);
//0行目（FixedRow）では動作しないように設定
if (ACol = StrGrid1ColCount-1) and (ARow > 0) then
//UpdateColumnData(ARow);
//引数にはCMS設定値が入る
UpdateColumnData(StrToInt(StringGrid1.Cells[StrGrid1ColCount-2, ARow]), True);
end;
type
//動的配列の宣言（配列要素の並べ替え他）
TString2DArray = array of array of string;
TString1DArray = array of string;
TString2DBoolArray = array of array of Boolean;
procedure TForm1.TM(Sender: TObject);
var
intQ: Integer //設問数
intCMS: Integer; //組み合わせ採点数
pArr: array of Integer; //配点を入れる動的配列
cArr: array of Integer; //正解を入れる動的配列
kArr: array of Integer; //観点別評価の区分を入れる動的配列
c4_Arr: array of Integer; //CMS設定番号を入れる動的配列
c5_Arr: array of Integer; //NPO設定番号を入れる動的配列
mArr: array of array of Integer; //マークを入れる２次元の動的配列
sArr: array of array of Boolean; //採点結果を入れる２次元の動的配列
cms_mArr: TString2DArray; //マークの組み合わせを入れる２次元の動的配列
cms_cArr: TString1DArray; //正解の組み合わせを入れる１次元の動的配列
cms_sArr: TString2DBoolArray; //採点結果をTrue or Falseで保存
cms_jArr: array of Boolean; //順不同採点の実施の有無をTrue or Falseで保存
プログラムコードは、
//注意：コードは一部の抜粋（重要な部分のみ）であり、これだけでは動作しません。
//一部の変数は、説明用の文字列で代替しています。
var
//マークを取得_20250228訂正
function GenerateDynamicArray: TArray<string>;
var
i,j: UInt64; #jを追加
CurrentValue, NextValue: string;
ResultArray: TArray<string>;
TempStr: string;
begin
TempStr := '';
j:=0; #初期化
for i := 1 to StringGrid1.RowCount - 2 do
begin
CurrentValue := StringGrid1.Cells[4, i];
NextValue := StringGrid1.Cells[4, i + 1];
if CurrentValue = NextValue then
begin
TempStr := TempStr + IntToStr(mArr[i-1,'答案画像の番号']);
end else begin
TempStr := TempStr + IntToStr(mArr[i-1,'答案画像の番号']);
ResultArray := ResultArray + [TempStr];
TempStr := '';
end;
j:=i; #値を取得
end;
//最後の要素を追加_20250228訂正
//TempStr := TempStr + StringGrid1.Cells[0, StringGrid1.RowCount - 1];
TempStr := TempStr + IntToStr(mArr[j, '答案画像の番号']);
ResultArray := ResultArray + [TempStr];
Result := ResultArray;
end;
//正解を取得
function GenerateDynamicArray2: TArray<string>;
var
i: UInt64;
CurrentValue, NextValue: string;
ResultArray: TArray<string>;
TempStr: string;
begin
TempStr := '';
for i := 1 to StringGrid1.RowCount - 2 do
begin
CurrentValue := StringGrid1.Cells[4, i];
NextValue := StringGrid1.Cells[4, i + 1];
if CurrentValue = NextValue then
begin
//正解を取得
TempStr := TempStr + StringGrid1.Cells[1, i];
end else begin
//正解を取得
TempStr := TempStr + StringGrid1.Cells[1, i];
ResultArray := ResultArray + [TempStr];
TempStr := '';
end;
end;
//最後の要素を追加_20250228訂正
//TempStr := TempStr + StringGrid1.Cells[0, StringGrid1.RowCount - 1];
TempStr := TempStr + StringGrid1.Cells[1, StringGrid1.RowCount - 1];
ResultArray := ResultArray + [TempStr];
Result := ResultArray;
end;
//配列要素の並べ替え
procedure SortStringWithZeroPriority(var Str: string);
var
CharArray: array of Char;
i, j: Integer;
Temp: Char;
begin
// 文字列を文字配列に変換
SetLength(CharArray, Length(Str));
for i := 1 to Length(Str) do
CharArray[i - 1] := Str[i];
// 昇順にソート (バブルソートを使用)
for i := Low(CharArray) to High(CharArray) - 1 do
for j := i + 1 to High(CharArray) do
begin
if (CharArray[j] = '0') or (CharArray[i] > CharArray[j]) then
begin
Temp := CharArray[i];
CharArray[i] := CharArray[j];
CharArray[j] := Temp;
end;
end;
// ソートされた文字配列を元の文字列に戻す
Str := '';
for i := Low(CharArray) to High(CharArray) do
Str := Str + CharArray[i];
end;
begin
//設問数を取得
intQ:=StringGrid1.RowCount-1;
//組み合わせ採点数を取得する -> 組み合わせ採点数は、最終行の値
intCMS:=StrToInt(StringGrid1.Cells[4,intQ]);
//動的配列を生成
SetLength(cArr, intQ); //正解（Correct answer）
SetLength(pArr, intQ); //配点（Point allocation）
SetLength(kArr, intQ); //観点別評価の区分
SetLength(c4_Arr, intQ); //組み合わせ採点の区分
SetLength(c5_Arr, intQ); //順不同採点の区分
//正解・配点・観点別評価の区分を配列に取得
for i := 1 to intQ do
begin
if StringGrid1.Cells[2,i]<>'' then
begin
cArr[i-1]:=StrToInt(StringGrid1.Cells[1,i]);
pArr[i-1]:=StrToInt(StringGrid1.Cells[2,i]);
kArr[i-1]:=StrToInt(StringGrid1.Cells[3,i]);
c4_Arr[i-1]:=StrToInt(StringGrid1.Cells[4,i]);
c5_Arr[i-1]:=StrToInt(StringGrid1.Cells[5,i]);
end else begin
pArr[i-1]:=0;
end;
end;
//１問１答の通常採点用の配列を準備
SetLength(mArr, intQ, ListBox1.Items.Count); //マーク読み取り結果
SetLength(sArr, intQ, ListBox1.Items.Count); //採点結果
//組み合わせ採点用の配列を準備
SetLength(cms_mArr, intCMS, ListBox1.Items.Count); //マーク読み取り結果の組み合わせ
SetLength(cms_cArr, intCMS); //正解読み取り結果の組み合わせ
SetLength(cms_sArr, intCMS, ListBox1.Items.Count); //組み合わせの採点結果
SetLength(cms_jArr, intCMS); //順不同採点実施の有無
//まず全てのデータを取得する
//マークを配列に取得・採点結果の初期化（False）
for i := 1 to ListBox1.Items.Count do //答案枚数分Loopする
begin
for j := 1 to intQ do //設問数分Loopする
begin
if strGrid.Cells[j,i]<>'' then
begin
//空欄（999）も、ダブルマーク（99）もそのまま取得する
mArr[j-1][i-1]:=StrToInt(strGrid.Cells[j,i]);
//デフォルトFalseで初期化
sArr[j-1][i-1]:=False;
end else begin
mArr[j-1][i-1]:=999; //Gridが空欄であればマークは空欄として扱う
sArr[j-1][i-1]:=False;
end;
end;
end;
//組み合わせ採点用の動的配列にデータをセットする
for i := 1 to ListBox1.Items.Count do //答案枚数分Loopする
begin
//マークを配列に取得・採点結果の初期化（False）
DynamicArray := GenerateDynamicArray;
for j := 0 to intCMS-1 do
begin
if strGrid.Cells[j,i]<>'' then
begin
cms_mArr[j][i-1]:=DynamicArray[j];
end else begin
mArr[j-1][i-1]:=999; //Gridが空欄であればマークは空欄として扱う
sArr[j-1][i-1]:=False;
end;
end;
//正解を配列に取得・採点結果の初期化（False）
DynamicArray := GenerateDynamicArray2;
for j := 0 to intCMS-1 do
begin
if strGrid.Cells[j,i]<>'' then
begin
cms_cArr[j]:=DynamicArray[j];
end else begin
mArr[j-1][i-1]:=999; //Gridが空欄であればマークは空欄として扱う
sArr[j-1][i-1]:=False;
end;
end;
end;
//答案枚数分Loop
for i := 1 to ListBox1.Items.Count do
begin
//組み合わせ採点数分Loop
for j := 0 to intCMS-1 do
begin
//もし、マークが正解と等しかったら
if cms_mArr[j][i-1]=cms_cArr[j] then
begin
cms_sArr[j][i-1]:=True;
end else begin
cms_sArr[j][i-1]:=False;
end;
end;
end;
var
CurrentCMSValue: UInt64;
//配列要素の並べ替え
procedure SortStringWithZeroPriority(var Str: string);
var
CharArray: array of Char;
i, j: Integer;
Temp: Char;
begin
// 文字列を文字配列に変換
SetLength(CharArray, Length(Str));
for i := 1 to Length(Str) do
CharArray[i - 1] := Str[i];
// 昇順にソート (バブルソート)
for i := Low(CharArray) to High(CharArray) - 1 do
for j := i + 1 to High(CharArray) do
begin
if (CharArray[j] = '0') or (CharArray[i] > CharArray[j]) then
begin
Temp := CharArray[i];
CharArray[i] := CharArray[j];
CharArray[j] := Temp;
end;
end;
//ソートされた文字配列を元の文字列に戻す
Str := '';
for i := Low(CharArray) to High(CharArray) do
Str := Str + CharArray[i];
end;
begin
//組み合わせ採点用の動的配列にデータをセットする
for i := 1 to ListBox1.Items.Count do //答案枚数分Loopする
begin
･･･
end;
//順不同採点のフラグを設定
for i := 1 to StringGrid1.RowCount-1 do
begin
if StringGrid1.Cells[2, i] <> '0' then
begin
CurrentCMSValue := StrToInt(StringGrid1.Cells[4, i]);
case StrToInt(StringGrid1.Cells[5, i]) of
0:begin
cms_jArr[CurrentCMSValue-1]:= False;
end;
1:begin
cms_jArr[CurrentCMSValue-1]:= True;
end;
end;
end;
end;
//答案枚数分Loop
for i := 1 to ListBox1.Items.Count do
begin
//組み合わせ採点数分Loop
for j := 0 to intCMS-1 do
begin
//順不同採点を実施する場合の処理
if cms_jArr[j] then
begin
//マーク並べ替え
SortStringWithZeroPriority(cms_mArr[j][i-1]);
//正解並べ替え
SortStringWithZeroPriority(cms_cArr[j]);
end;
//もし、マークが正解と等しかったら
if cms_mArr[j][i-1]=cms_cArr[j] then
begin
//採点結果をTrue
cms_sArr[j][i-1]:=True;
end else begin
cms_sArr[j][i-1]:=False;
end;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
//CSVファイルの読み込み
CSVFileName: string;
CsvFile:TextFile;
CsvRowStr: string;
i: Integer;
strMsg: string;
//列幅の調整
iCOL: Integer;
MaxColWidth: Integer;
iROW: Integer;
TmpColWidth: Integer;
begin
//表示設定
StringGrid1.Visible:=False;
//列数
StringGrid1.ColCount:=7;
//OpenDialogのプロパティはExecuteする前に設定しておくこと
With OpenDialog1 do begin
//表示するファイルの種類をcsvに設定
Filter:='CSVファイル(*.csv)|*.csv';
//データの読込先フォルダを指定
InitialDir:=ExtractFilePath(Application.ExeName)+'sName';
end;
//ダイアログ呼び出し
if OpenDialog1.Execute then
begin
CsvFileName:=OpenDialog1.FileName;
AssignFile(CsvFile, CsvFileName);
Reset(CsvFile);
end else begin
strMsg:='ユーザーによる処理のキャンセル';
Application.MessageBox(PChar(strMsg), PChar('情報'), MB_ICONINFORMATION);
Exit;
end;
//フィールド名が必要なCSVファイルなら記述する
//StringGrid1.Rows[0].CommaText:=
// '通し番号,氏名,よみがな,年齢,生年月日,性別,血液型';
//Fixed Colが１列あって、そこに行番号を設定する場合
// ',通し番号,氏名,よみがな,年齢,生年月日,性別,血液型';
//読込み開始行を指定（FixedRowがある場合 -> ない場合は[0]にする）
i:=0;
try
while not EOF(CsvFile) do
begin
//CSVファイルを1行読み込み、その1行分を文字列として代入する。
Readln(CsvFile, CsvRowStr);
//グリッドの行数が読み込み行数より少なければ、グリッドの行数を追加する。
if StringGrid1.RowCount <= i then StringGrid1.RowCount := i + 1;
//グリッドの指定行目に読み込み行を代入
//[0]列はFixedCol-> 行番号を設定したい場合
//StringGrid1.Rows[i].CommaText:=IntToStr(i)+','+CsvRowStr;
StringGrid1.Rows[i].CommaText:=CsvRowStr;
i := i + 1;
end;
finally
//行番号を設定した場合
//StringGrid1.Cells[0,0]:='行番号';
CloseFile(CsvFile);
end;
//列幅の自動調整
for iCOL := 0 to StringGrid1.ColCount-1 do
begin
MaxColWidth := 0;
for iROW := 0 to StringGrid1.RowCount-1 do
begin
TmpColWidth := Canvas.TextWidth(StringGrid1.Cells[iCOL,iROW]) + 10;
if MaxColWidth < TmpColWidth then
MaxColWidth := TmpColWidth;
end;
StringGrid1.ColWidths[iCOL] := MaxColWidth;
end;
//表示設定
StringGrid1.Visible:=True;
end;
//データを出力
//Image1.Picture.Bitmap.Canvas.TextOut(MarginX+k,MarginY+(iPlus*20),Fields[j]);
//数値データは右揃えで出力する
if TryStrToInt(Fields[j], intValue) then
begin
//数値である -> 右揃えで出力する
Image1.Picture.Bitmap.Canvas.TextOut(MarginX+k,MarginY+(iPlus*20),
Format('%3d', [strToInt(Fields[j])]));
end else begin
//数値でない -> 左揃えで出力する
Image1.Picture.Bitmap.Canvas.TextOut(MarginX+k,MarginY+(iPlus*20),Fields[j]);
end;
【実行結果】
通し番号（と年齢）が右揃えになった！
追記（20240819）ここまで
２ページ目以降も先頭行にフィールド名を表示
今までの自分には罫線付きでこのように表示することが、どうしてもできなかった･･･
先頭行にフィールド名を表示する部分は、いちばん悩んだところ。 最終的に変数eNum（LoopのEndNumber）から印刷に必要なページ数を取得し、StringListに格納した印刷データの０番目の要素をコピーして、これをStringListの51、101、151のように、eNumの現在の値( i * 50)+1番目に挿入して行く方法が計算的にも、処理的にも、いちばんラクなのではないか？･･･と考え、このアルゴリズムでプログラムを作成。
eNum:=StringList.Count div 50;
//51,101,151,201,251,301・・・番目にフィールド名を挿入
//0番目の要素をコピー
myFieldElement:=StringList[0];
//要素を追加
if eNum<>0 then
begin
for i := 1 to eNum do
begin
StringList.Insert((50*i)+1, myFieldElement);
end;
end;
for intLoop := 0 to eNum do
begin
k:=0;
iPlus:=0;
for i := LowNum to HighNum do
begin
for j := 0 to Fields.Count - 1 do
begin
//フィールド名に「備考」を追加する
if i=0 then
begin
if j=Fields.Count-1 then
begin
Fields[j]:=Fields[j]+' 備考';
end;
end;
//データを出力
Image1.Picture.Bitmap.Canvas.TextOut(MarginX+k,MarginY+(iPlus*20),Fields[j]);
end;
inc(iPlus);
end;
//大きさを指定
MyRect.Top:=0;
MyRect.Left:=0;
MyRect.Bottom:= Trunc((Printer.PageWidth / Image1.Picture.Width) * Image1.Picture.Height);
MyRect.Right:= Printer.PageWidth;
//ファイルを描画
StretchDrawBitmap(Printer.Canvas, MyRect, Image1.Picture.Bitmap);
Application.ProcessMessages;
end; //intLoopの終わり
procedure TForm1.btnPrintASheetClick(Sender: TObject);
var
i, j: Integer;
strMsg: string;
PrintALL: Boolean;
intLoopNum: Integer;
rect:TRect;
StrCaption:String;
StrPrompt:String;
StrValue1, StrValue2:String;
Chr : array [0..255] of char;
// ビットマップ用印刷ルーチン
procedure StretchDrawBitmap(Canvas:TCanvas; // 描画先キャンバス
r : TRect; // 描画先範囲
Bitmap:TBitmap); // ビットマップ
・・・省略・・・
begin
if PrinterSetupDialog1.Execute then
begin
//背景を塗りつぶす
Image1.Picture.Bitmap.Canvas.Brush.Color := clWhite;
Image1.Picture.Bitmap.Canvas.FillRect(rect(0, 0, 827, 1169)); //エラーになる部分
//Info
strMsg:='全員分印刷しますか？'+#13#10+'（個別印刷は「いいえ」）';
if Application.MessageBox(PChar(strMsg), PChar('情報'), MB_YESNO or MB_ICONINFORMATION) = mrYes then
begin
PrintALL:=True;
end else begin
PrintALL:=False;
end;
//全部印刷
if PrintAll then
begin
//先頭のデータを表示
btnFirstClick(Sender);
for i := 1 to ListBox1.Items.Count do
begin
//まず現在のImageを印刷
with Printer do
begin
if i=1 then
begin
BeginDoc;
end else begin
NewPage;
end;
//大きさを指定
rect.Top:=0;
rect.Left:= 0;
rect.Bottom:= Trunc(( PageWidth / Image1.Picture.Width) * Image1.Picture.Height);
rect.Right:= PageWidth;
//TImageのBitmapをPrinterのCanvasに描画
StretchDrawBitmap(Printer.Canvas, rect, Image1.Picture.Bitmap);
if i=ListBox1.Items.Count then
begin
EndDoc;
end;
end;
//次を表示
btnNextClick(Sender);
end;
・・・
procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
LDelta:Integer;
//追加
LWinCtrl:TWinControl;
LCurPos:TPoint;
begin
{
//TScrollBox のマウスホイールによるスクロール
//マウスがTScrollBoxの外にあってもスクロールする・・・ならこちら☆
LDelta:=WheelDelta div 5;
if ssCtrl in Shift then
begin
ScrollBox1.HorzScrollBar.Position:=ScrollBox1.HorzScrollBar.Position-LDelta;
end else begin
ScrollBox1.VertScrollBar.Position:=ScrollBox1.VertScrollBar.Position-LDelta;
end;
Handled:=True;
}
//マウスカーソルが TScrollBox の領域内にある時だけスクロールを可能にする
LCurPos := ScrollBox1.Parent.ScreenToClient(MousePos);
if PtInRect(ScrollBox1.BoundsRect, LCurPos) then
begin
LDelta := WheelDelta div 3;
if ssCtrl in Shift then
begin
ScrollBox1.HorzScrollBar.Position := ScrollBox1.HorzScrollBar.Position - LDelta;
end else begin
ScrollBox1.VertScrollBar.Position := ScrollBox1.VertScrollBar.Position - LDelta;
//Memoも連動してスクロールさせる
{
if LDelta > 0 then
begin
Memo2.Perform(WM_VSCROLL, SB_LINEUP, 0);
end else begin
Memo2.Perform(WM_VSCROLL, SB_LINEDOWN, 0);
end;
}
end;
end else begin
//マウス直下のコントロールを取得
LWinCtrl := FindVCLWindow(MousePos);
//TStringGridの場合
if LWinCtrl is TStringGrid then
begin
if WheelDelta > 0 then
begin
LWinCtrl.Perform(WM_VSCROLL, SB_LINEUP, 0);
end else begin
LWinCtrl.Perform(WM_VSCROLL, SB_LINEDOWN, 0);
end;
end;
end;
//この１行を忘れないこと！
Handled:=True;
end;
当Blogで紹介してきた自作のデジタル採点プログラムを一つにまとめました。次のリンク先にその紹介とダウンロードリンクがあります。この記事で紹介している手書き答案のデジタル採点プログラムAC_Reader Version 2.1.1 と、AC_Reader Version 2.1.1 に自動採点機能を追加で搭載した Version 3.1.1 がプログラムセットに同梱されています。
2025年8月25日更新版に含まれている「手書き答案採点補助プログラム AC_Reader Version 3.1.0 ）には自動採点機能が新しく追加で搭載されています。プログラムのダウンロード＆展開後、初めてこの自動採点機能を実行する際に、Windows Defender や McAfee などの Anti-Virus Software : AV による『未知バイナリの初回スキャン』が行われるようです。このため２～３分間程度 PC は待機状態になります（２回目以降はスムース？に動作します）。また、実行形式ファイルの PC 内での位置が変わった場合にも AV によっては再度『未知バイナリの初回スキャン』が行われ、初回同様の待機状態となる場合があります。このことについては、この Blog の別の記事に詳しい説明があります。下記リンク先の記事をご参照ください。
するとPDFiumというライブラリがあるとCopilotさんが教えてくれました。ただ、紹介されたのは「PDFium Component Suite for FireMonkey」だったので、どちらかというとWindows専用にVCLコンポーネントを使ってプログラムを書きたい自分的には（FireMonkeyはちょっと･･･）という感じだったのですが･･･、「溺れる者は藁をもつかむ」と、まさにそんな気持ちでありましたから･･･記事に目を通してみることに。
Swanman (id:tales)さんのBlogの記事に紹介されていた Windows Runtime（略称がWinRT）なるものの存在を、これまで僕は知りませんでした。Win32 API なら名前だけは知ってましたが、どうやらそれより新しいAPI であるとのこと。難しいことはわかりませんが、このWinRTでPDFの画像化ができるのであれば、Windowsの機能を使ってそれが実現できるのですから、新規に何かライブラリを追加したりする必要がなく、それこそ理想的です。
procedure TForm1.UpDown1Click(Sender: TObject; Button: TUDBtnType);
var
Value: Real;
begin
//注意：このコードは、期待通りに動作しません
Value := StrToFloatDef(Edit1.Text, 0);
case Button of
btNext: Value := Value + 0.1;
btPrev: Value := Value - 0.1;
end;
Edit1.Text := FloatToStrF(Value, ffNumber, 1, 1);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Value: Double;
begin
if TryStrToFloat(Edit2.Text, Value) then
begin
Value := Value + 0.1;
Edit2.Text := FloatToStr(Value);
end
else
ShowMessage('Invalid number');
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Value: Double;
begin
if TryStrToFloat(Edit2.Text, Value) then
begin
Value := Value - 0.1;
Edit2.Text := FloatToStr(Value);
end
else
ShowMessage('Invalid number');
end;
var
Value: Double;
Epsilon: Double;
begin
Epsilon := 1E-15; //閾値を設定
Value := SomeCalculation(); //計算を実行
if Abs(Value) < Epsilon then
Value := 0;
Edit1.Text := FloatToStr(Value);
end;
４．コードを修正
Copilotさんが教えてくれたコードを読んで、「0.0」と表示されるように修正しました。
procedure TForm1.Button3Click(Sender: TObject);
var
Value: Double;
Epsilon: Double;
begin
Epsilon := 1E-15; //閾値を設定
if TryStrToFloat(Edit3.Text, Value) then
begin
Value := Value + 0.1;
if Abs(Value) < Epsilon then
begin
Value := 0;
Edit3.Text := '0.0';
end else begin
Edit3.Text := FloatToStr(Value);
end;
end;
end;
procedure TForm1.Button4Click(Sender: TObject);
var
Value: Double;
Epsilon: Double;
begin
Epsilon := 1E-15; //閾値を設定
if TryStrToFloat(Edit3.Text, Value) then
begin
Value := Value - 0.1;
if Abs(Value) < Epsilon then
begin
Value := 0;
Edit3.Text := '0.0';
end else begin
Edit3.Text := FloatToStr(Value);
end;
end;
end;
procedure TForm1.UpDown1Click(Sender: TObject; Button: TUDBtnType);
begin
Assert(Sender is TUpDown);
with TUpDown(Sender) do
begin
Assert(Associate is TEdit);
TEdit(Associate).Text := FloatToStrF(Position / 10, ffNumber, 1, 1);
end;
end;
procedure TFormXXX.PanelXStartDock(Sender: TObject;
var DragObject: TDragDockObject);
begin
DragObject:= TToolDockObject.Create(Sender as TPanel);
end;
procedure TFormXXX.PanelXStartDock(Sender: TObject;
var DragObject: TDragDockObject);
begin
//これでちらつかなくなった
DragObject:= TToolDockObject.Create(Sender as TPanel);
//設定し忘れないための予防的措置
if not FormXXX.DockSite then
begin
FormXXX.DockSite:=True;
end;
end;
ドロップ時のOnDockDropイベントは･･･
procedure TFormXXX.FormDockDrop(Sender: TObject;
Source: TDragDockObject; X, Y: Integer);
var
r:TRect;
begin
if IsDragObject(Source) then
begin
r.Left:=X;
r.Top:=Y;
r.Right:=X+PanelX.Width;
r.Bottom:=Y+PanelX.Height;
PanelX.ManualFloat(r);
//解放
Source.Free;
if FormXXX.DockSite then
begin
FormXXX.DockSite:=False;
end;
end;
end;
procedure TFormCollaboration.PanelXStartDock(Sender: TObject;
var DragObject: TDragDockObject);
begin
DragObject:= TToolDockObject.Create(Sender as TPanel);
try
if not FormXXX.DockSite then
begin
FormXXX.DockSite:=True;
Application.ProcessMessages; //おまじない
end;
finally
DragObject.Free; //メモリの解放
end;
FormXXX.DockSite:=False;
end;
DragObject:= TToolDockObject.Create(Sender as TPanel);
try
if not FormXXX.DockSite then
begin
FormXXX.DockSite:=True;
Application.ProcessMessages; //おまじない
end;
finally
DragObject.Free; //メモリの解放
end;
2023年11月８日、RAD Studio 12.0（僕にとってはDelphi 12.0）がリリースされた（ようです）。 アップデート・サブスクリプションの支払いを終え（個人で購入しているのは僕くらいだろうが･･･）、届いたメールの製品アップデートリンクをクリックして、最新の更新をチェックしたら、12.0が！
## P4D Installation using [MultiInstaller](https://github.com/pyscripter/MultiInstaller)
Use for Delphi Seattle (10.4) or later to install all packages in one step.
1. Clone or copy the Python4Delphi git repository to a folder of your choice. **The setup.ini file assumes that the folder is called "P4D"**. If you chose to name your folder differently then modify the "Folder" option in setup.ini.
2. Close all Delphi IDEs running.
3. Run MultiInstaller.exe
4. Select the packages you want and press Next
5. In the dialog box specify the _**parent folder**_ of "P4D" (i.e. the folder containing the directory to which you have copied Python4Delphi) and the Delphi target version. Then press Next to install the components
RAD Studio 12.0 対応版のP4D付属 MultiInstaller.exe を起動して表示されるフォルダの選択ダイアログは、前掲の通り。
Browseボタンをクリックして･･･
Compile packages ～の欄には RAD Studio 12 Athens が増えましたが、欄の上下に「まだまだ余裕」があります。これを見て、先ほどの予感は大きく自信を得て･･･「これはつまり、今後数十年以上先までDelphiのメジャーバージョンアップが続々と行われることを見通して、必要十分と思われる余白を予め用意した先見の明溢れる非常に大胆な先進的設計である」という確信に変わりました。
function GetCommaText(aStr:String; aIndex:Integer):string;
var
subList:TStringList;
begin
subList := TStringList.Create;
subList.Delimiter := ',';
subList.DelimitedText := aStr;
Result := subList.Strings[aIndex];
subList.Free;
end;
function MyCustomSort(List: TStringList; Index1, Index2: Integer): Integer;
begin
case fStyle of
ssText:begin
Result:=CompareText(GetCommaText(List.Strings[Index1],
fIndex),
GetCommaText(List.Strings[Index2],fIndex));
end;
ssInteger:begin
//一重ソート
//Result:=StrToInt(GetCommaText(List.Strings[Index1],fIndex))
// -StrToInt(GetCommaText(List.Strings[Index2],fIndex));
//二重ソート
Result:=StrToInt(GetCommaText(List.Strings[Index1],fIndex))
-StrToInt(GetCommaText(List.Strings[Index2],fIndex));
if Result=0 then
//-1することで１番目の項目がソートキーになる
Result:=StrToInt(GetCommaText(List.Strings[Index1],fIndex-1))
-StrToInt(GetCommaText(List.Strings[Index2],fIndex-1));
if fAscending then
begin
Result:=Result*-1;
end else begin
Result:=Result*1;
end;
end;
else
//これを入れておかないとコンパイラが警告を表示する
Result:=0;
end;
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
var
i:integer;
begin
//行番号をLines[i]で取得
i:=StrToInt(LBRow.Caption)-1;
EditTF:= not EditTF;
if EditTF then
begin
BitBtn1.Caption:='編集中';
BitBtn1.Font.Color:=clRed;
Memo2.ReadOnly:=False;
btnSave.Enabled:=False;
//i行目の文字全てを選択状態にしたい場合
//先頭にカーソルをセット
Memo2.SelStart:=Memo2.Perform(EM_LINEINDEX, i, 0);
//全ての文字を選択
Memo2.SelLength:=Length(WideString(Memo2.Lines[i]));
//Memo2.Perform(WM_VSCROLL,SB_TOP,0); //先頭にスクロール
end else begin
BitBtn1.Caption:='編 集';
BitBtn1.Font.Color:=clBlack;
Memo2.ReadOnly:=True;
Memo2.SelStart:=SendMessage(Memo2.Handle,EM_LineIndex,i,0);
btnSave.Enabled:=True;
Memo2Click(Sender);
end;
//SetFocus
Memo2.SetFocus;
end;
Delete or Backspaceキーで不要なデータを削除すると同時に、Memoの行も削除する。で、ボタンを「編集」（＝意味的には「編集したい場合はクリックせよ」）に戻す。次のデータをラバーバンドで囲む。この一連の動作がすべて自動的に流れ作業で行われるように手続きを作成。
コードは次の通り。
procedure TForm1.Memo2KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
var
LineNo:integer;
begin
//現在、カーソルがある行を取得
LineNo:=Memo2.Perform(EM_LINEFROMCHAR, UINT(-1), 0);
//空欄なら行を削除
if Memo2.Lines[LineNo]='' then
begin
Memo2.Lines.Delete(LineNo);
end;
//表示
GetLinePos;
if not EditTF then
begin
Memo2Click(Sender);
end else begin
BitBtn1Click(Sender);
end;
end;
procedure TForm1.GetLinePos;
var
CurPos,Line:Integer;
begin
with Memo2 do
begin
CurPos:=SelStart;
Line:=Perform(EM_LINEFROMCHAR, CurPos, 0);
//LBRowは現在フォーカスがある行番号を表示するラベル
LBRow.Caption:=Format('%d', [Line+1]);
LBRow2.Left:=LBRow.Left+LBRow.Width;
LBRow2.Caption:='行目';
end;
end;
procedure TForm1.Memo2Click(Sender: TObject);
var
i:integer;
p1,p2:TPoint;
function RemoveToken(var s:string;delimiter:string):string;
var
p:Integer;
begin
p:=Pos(delimiter,s);
if p=0 then Result:=s
else Result:=Copy(s,1,p-1);
s:=Copy(s,Length(Result)+Length(delimiter)+1,Length(s));
end;
function GetTokenIndex(s:string;delimiter:string;index:Integer):string;
var
i:Integer;
begin
Result:='';
for i:=0 to index do
Result:=RemoveToken(s,delimiter);
end;
begin
if not EditTF then
begin
//座標を取得
i:=Memo2.Perform(EM_LINEFROMCHAR, Memo2.SelStart, 0);
//エラー対策
if Memo2.Lines[i]='' then Exit;
x1:=StrToInt(GetTokenIndex(Memo2.Lines[i],',',0));
y1:=StrToInt(GetTokenIndex(Memo2.Lines[i],',',1));
x2:=StrToInt(GetTokenIndex(Memo2.Lines[i],',',2));
y2:=StrToInt(GetTokenIndex(Memo2.Lines[i],',',3));
if Assigned(plImage1) then begin
FreeAndNil(plImage1);
end;
//コンポーネントを生成し，イベントを定義し，位置を指定して画像を表示
plImage1:=TplResizeImage.Create(Self);
plImage1.Parent:=ScrollBox1;
plImage1.TransEvent:=True;
//クライアント座標をスクリーン座標へ変換
//GetSystemMetrics(SM_CYCAPTION) -> タイトルバーの高さ
//GetSystemMetrics(SM_CYFRAME) -> ウィンドウの枠幅
p1.X:=x1-(GetSystemMetrics(SM_CYFRAME) div 2);
p1.Y:=y1-GetSystemMetrics(SM_CYCAPTION)-(GetSystemMetrics(SM_CYFRAME) div 2);
p2.X:=x2-(GetSystemMetrics(SM_CYFRAME) div 2);
p2.Y:=y2-GetSystemMetrics(SM_CYCAPTION)-(GetSystemMetrics(SM_CYFRAME) div 2);
p1:=Image1.ClientToScreen(p1);
p2:=Image1.ClientToScreen(p2);
plImage1.SetBounds(p1.X, p1.Y, p2.X-p1.X, p2.Y-p1.Y);
//SelectedプロパティをTrueにするとラバーバンドとグラブハンドルが表示される
plImage1.Selected := True;
plImage1.BringToFront;
end;
end;
procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
var
StrText: string;
begin
//何かキーが押し下げられたら
if Msg.message = WM_KEYDOWN then
begin
try
if ActiveControl is TMemo then
begin
//キー操作を「通常動作」にするおまじない
case Msg.Message of
WM_USER + $0500:
Handled := True;
end;
end else begin
//上位ビットが1ならShiftキーが押されている
if GetKeyState(VK_SHIFT) and $8000 <> 0 then
begin
if plImage1.Visible then
begin
//右矢印キー
if Msg.wParam=VK_RIGHT then
begin
plImage1.Width := plImage1.Width + 1;
Msg.wParam:=0;
end;
//左矢印キー
if Msg.wParam=VK_LEFT then
begin
plImage1.Width := plImage1.Width - 1;
Msg.wParam:=0;
end;
//上矢印キー
if Msg.wParam=VK_UP then
begin
plImage1.Height := plImage1.Height - 1;
Msg.wParam:=0;
end;
//下矢印キー
if Msg.wParam=VK_DOWN then
begin
plImage1.Height := plImage1.Height + 1;
Msg.wParam:=0;
end;
end;
end else begin
//Shiftキーは押されていない
//対象を限定（どちらでも動いた）
//if TplResizeImage(ActiveControl).Visible then
if plImage1.Visible then
begin
//右矢印キー
if Msg.wParam=VK_RIGHT then
begin
plImage1.Left := plImage1.Left +1;
Msg.wParam:=0;
end;
//左矢印キー
if Msg.wParam=VK_LEFT then
begin
plImage1.Left := plImage1.Left -1;
Msg.wParam:=0;
end;
//上矢印キー
if Msg.wParam=VK_UP then
begin
plImage1.Top := plImage1.Top - 1;
Msg.wParam:=0;
end;
//下矢印キー
if Msg.wParam=VK_DOWN then
begin
plImage1.Top := plImage1.Top + 1;
Msg.wParam:=0;
end;
//Deleteキー
if Msg.wParam=VK_DELETE then
begin
//plImage1を解放
if Assigned(plImage1) then begin
FreeAndNil(plImage1);
end;
Msg.wParam:=0;
end;
end;
end;
end;
except
on E: Exception do
begin
StrText := E.ClassName + sLineBreak + E.Message;
Application.MessageBox(PChar(StrText), '情報', MB_ICONINFORMATION);
end;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
//Python39-32へのPath
AppDataDir:string;
begin
・・・
if DirectoryExists(AppDataDir) then
begin
//フォルダが存在したときの処理（コメント化）
//MessageDlg('Embeddable Pythonが利用可能です。',
// mtInformation, [mbOk] , 0);
PythonEngine1.AutoLoad:=True;
GitHubのPython4Delphiのダウンロードページには「The project is licensed under the MIT License.」とある。これは「改変・再配布・商用利用・有料販売すべてが自由かつ無料」であること、及び使用するにあたっての必須条件はPython4Delphiの「著作権を表示すること」と「MITライセンスの全文」or 「 MITライセンス全文へのLink」をソフトウェアに記載する、もしくは、別ファイルとして同梱しなさい･･･ということを意味する。
procedure TForm1.CMShowingChanged(var Msg: TMessage);
begin
inherited; {通常の CMShowingChagenedをまず実行}
if Visible then
begin
Update; {完全に描画}
//Formの表示終了時に以下を実行
Panel1.Height:=intPH;
intPH:=Panel1.Height;
intFH:=Form1.Height;
end;
end;
Formが生成される際に、Panel1とFormの高さをプログラムから指示して決定。
procedure TForm1.FormCreate(Sender: TObject);
begin
//Panel1とFormの高さを記憶する変数を初期化
intPH:=200;
intFH:=480;
end;
Formの大きさの変更イベントに合わせて、Panel1の高さを計算して決定。
procedure TForm1.FormResize(Sender: TObject);
begin
//比率を維持してPanel1の高さを変更
Panel1.Height:=Trunc(Form1.Height * intPH/intFH);
end;
