上のリンク先『ダウンロードとプロダクト キー』へ行き、表示される画面の左側の『Developer Tools』に『Visual Studio 2022』（リンク）をクリック。
表示されたページの中ほどに「Visual C++ Redistributable for Visual Studio 2022」があるので、その右側の ComboBox みたいな部分で x64 を x86 に変更して『ダウンロード』ボタンをクリック。
「Visual C++ Redistributable for Visual Studio 2022」は「VC_redist.x86.exe」で保存されました。これをインストールすると、2015 以降のランタイム（2015, 2017, 2019, 2022）は統合されているため、「Visual C++ 2015 Redistributable」も含まれてインストールされるようです。
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 で、ラバーバンドで囲んだ範囲を、クリップボードへ画像データとして送信できるようになりました。
A3 サイズのシートも作成してみたのだが、A3 サイズだとインクジェット複合機を利用して印刷（輪転機での印刷はマークの濃度が濃くなり、誤判定が出やすくなることから非推奨･･･というか、ユーザーには禁止と案内している）する時間が B4 サイズのそれより明らかに遅くなる、スキャナーでの読み取り処理にも時間がかかる等、いろいろ問題があり、少々マークの文字は小さくなるが A 版に比べて何かとメリットが多い B 版の用紙を使うことに決定。
もちろん、国際的にはやはり A 版だと思うが、欧米文化圏で My マークシートリーダーが使われるシーンはさすがに想像できない。できないが、今年、いちばんの夢は英語バージョンを作成することだ。これは新年早々に思いつき、数学用シートの処理プログラムが完成したら、今年の次のチャレンジ・イベントはそれだと思っている。
当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 の別の記事に詳しい説明があります。下記リンク先の記事をご参照ください。
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;
