begin
//StringGridに読み取り結果を表示
//オリジナルのプログラムは１行で終わってた
//StringGrid1.Cells[intSG_Col,intSG_Row]:=strAnsList[intSG_k];
//選択肢の０始まりに対応できるようコードを改良
if cmbOneZeroSelect.Text='1' then
begin
StringGrid1.Cells[intSG_Col,intSG_Row]:=strAnsList[intSG_k];
end else begin
if (strAnsList[intSG_k]='99') or (strAnsList[intSG_k]='999') then
begin
StringGrid1.Cells[intSG_Col,intSG_Row]:=strAnsList[intSG_k];
end else begin
strAnsList[intSG_k]:=IntToStr(StrToInt(strAnsList[intSG_k])-1);
StringGrid1.Cells[intSG_Col,intSG_Row]:=strAnsList[intSG_k];
end;
end;
・・・
end;
Please get out of my mind.
Please get out of my mind.
抜け殻になっちまうからさ。
Please get out of my mind.
Please get out of my mind.
何処かへ、消え失せてくれ。
THE STREET SLIDERS 「GET OUT OF MY MIND」より引用
そうだ。BYOD（Bring Your Own Device）環境があった。 カラー印刷の「紙」じゃなくて、「画像データ」、または「PDF文書」を、個人所有のタブレットに送信するんだ･･･。せっかく整備したBYOD環境の活用にもつながるし･･･。なにより「紙」を大量に消費するという、My Secret Weapon の最大の弱点も解消できる！
//TEditのonKeyPress イベント
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
//Enterキーで次のコントロールへ
if key = #13 then begin
keybd_event(VK_TAB,0,0,0);
Key := #0;
end;
//入力制限する場合 ここに記述する
end;
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
//リターンキーで移動させる
if Key = #13 then
begin
SelectNext(ActiveControl, True, True);
Key := #0;
end;
end;
Private Sub CommandButton1_Click()
Dim PrintNo1 As Integer
Dim PrintNo2 As Integer
Dim i As Integer
'PDF出力用に追加
Dim Rng As Range
Dim fName As String
If UserForm1.TextBox1.Text = "" Then
MsgBox ("開始番号を半角数字で入力してください。")
TextBox1.SetFocus
Exit Sub
End If
If UserForm1.TextBox2.Text = "" Then
MsgBox ("終了番号を半角数字で入力してください。")
TextBox2.SetFocus
Exit Sub
End If
PrintNo1 = UserForm1.TextBox1.Text
PrintNo2 = UserForm1.TextBox2.Text
i = PrintNo1
For i = PrintNo1 To PrintNo2
Range("A2").Select
ActiveCell.FormulaR1C1 = i
Range("B6:AB38").Select
ActiveSheet.PageSetup.PrintArea = "$B$6:$AB$38"
'PDFにする範囲を指定
Set Rng = ActiveSheet.Range("B6:AB38")
'PDFファイル名
If i < 10 Then
fName = Range("C8") & "0" & Range("E8") & "_" & Range("G8")
Else
fName = Range("C8") & Range("E8") & "_" & Range("G8")
End If
'全角＆半角スペースを削除する
fName = Replace(fName, " ", "")
fName = Replace(fName, " ", "")
If Not CheckBox1.Value Then
'紙に印刷（テスト時にはここをコメント化する）
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Else
'PDF出力
Rng.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ActiveWorkbook.Path & "\" & fName & ".pdf"
End If
Next i
Range("A2").Select
End Sub
//手動でEmbeddable PythonへのPathを切り替え（存在の有無を調査）
AppDataDir:=ExtractFilePath(Application.ExeName)+'Python39-32';
//AppDataDir:=ExtractFilePath(Application.ExeName)+'Python39-64';
if DirectoryExists(AppDataDir) then
begin
end;
Traceback (most recent call last):
File "E:\採点プログラム\xxx.py", line 138, in <module>
model.load()
File "E:\採点プログラム\xxx.py", line 58, in load
self.interpreter = tflite.Interpreter(model_path=self.model_file)
File "E:\WPy64-3980\python-3.9.8.amd64\lib\site-packages\tensorflow\lite\python\interpreter.py", line 455, in __init__
_interpreter_wrapper.CreateWrapperFromFile(
ValueError: Could not open 'E:\採点プログラム\saved_model.tflite'.
[Finished in 5.174s]
implementation
uses
System.AnsiStrings;
//System.AnsiStringsは、起動Path中の全角文字の有無を調査するために追加
procedure TFormCollaboration.FormCreate(Sender: TObject);
var
i,j:integer;
･･･ 略 ･･･
//引数に指定した文字列が半角か全角かチェックする
function OnlySingleByte(const S: AnsiString): Boolean;
var
i: Integer;
begin
for i:=1 to Length(S) do
//System.SysUtilsのByteType関数（非推奨）が呼び出される
//if ByteType(S, i) <> mbSingleByte then
//usesにSystem.AnsiStringsが必要
if System.AnsiStrings.ByteType(S, i) <> mbSingleByte then
begin
Result := False;
Exit;
end;
Result := True;
end;
begin
//起動Path中の全角文字の有無を調査
//[dcc64 警告]データ損失の可能性がある文字列の暗黙のキャスト ('string' から
//'AnsiString')を表示しないようにAnsiString()で明示的に型キャストした
if not OnlySingleByte(AnsiString(Application.ExeName)) then
begin
MessageDlg('AC_Reader.exeへのPath中に全角文字が含まれていないか、'+
'確認してください。'+
'全角文字が含まれているとPythonEngineの初期化作業を行うことができません。'+#13#10+#13#10+
'全角文字を含まないPathに変更後、再度実行してください。',mtError,[mbOk],0);
//プログラムの終了
//Close; //止まらない！
Application.ShowMainForm:=False;
Application.Terminate; //停止するが、エラーが発生する
//halt; //停止するが、エラーが発生する
end else begin
//カーソルを待機状態にする
Screen.Cursor := crHourGlass;
･･･ 略 ･･･
end;
end;
contours = cv2.findContours(thresh, cv2.RETR_LIST, cv2.CHAIN_APPROX_SIMPLE)[0]
num = len(contours)
mylist = np.zeros((num, 4))
i = 0
# red = (0, 0, 255)
for cnt in contours:
x, y, w, h = cv2.boundingRect(cnt)
# 高さが小さい場合は無視（ここを調整すれば設問番号を無視できる）
#if h < '+cmbStrHeight.Text+': <- Delphi埋め込み用
if h < 30:
mylist[i][0] = 0
mylist[i][1] = 0
mylist[i][2] = 0
mylist[i][3] = 0
else:
mylist[i][0] = x
mylist[i][1] = y
mylist[i][2] = x + w
mylist[i][3] = y + h
#cv2.rectangle(img, (x, y), (x+w, y+h), red, 2)
i += 1
どうやら元画像の「色が薄い」 or 「画像の線が太い」と問題が発生する傾向が強い気がしてきた。僕はこの実験に「えんぴつ」を使ったが、普通、試験時解答に使うのはシャーペンだから線が太くなることはあまり考えられない、むしろ、なるべく濃く書くことを注意事項に入れるべきかもしれない。なお、幅が狭くなっているように見えるのは、画像を強制的に幅64×高さ63にリサイズしているためだ。
//リソースに読み込んだ初期化用ファイルを再生
//ファイルの位置を指定
strFileName:=ExtractFilePath(Application.ExeName)+'imgAuto\tmp\maru.png';
//ファイルの存在を確認
if not FileExists(strFilename) then
begin
//リソースを再生
with TResourceStream.Create(hInstance, 'pngImage_1', RT_RCDATA) do
begin
try
SaveToFile(strFileName);
finally
Free;
end;
end;
end;
次に、Python Engineそのものを初期化。
//embPythonの存在の有無を調査
AppDataDir:=ExtractFilePath(Application.ExeName)+'Python39-64';
if DirectoryExists(AppDataDir) then
begin
//フォルダが存在したときの処理
PythonEngine1.AutoLoad := True;
PythonEngine1.IO := PythonGUIInputOutput1;
PythonEngine1.DllPath := AppDataDir;
PythonEngine1.SetPythonHome(PythonEngine1.DllPath);
PythonEngine1.LoadDll;
//PythonDelphiVar1のOnSeDataイベントを利用する
PythonDelphiVar1.Engine := PythonEngine1;
PythonDelphiVar1.VarName := AnsiString('var1');
//初期化
PythonEngine1.Py_Initialize;
end else begin
//MessageDlg('Python実行環境が見つかりません！',mtInformation,[mbOk], 0);
PythonEngine1.AutoLoad := False;
end;
最後に初期化用画像を読み込んで、１回だけ自動採点を実行する。
//スプラッシュ画面を表示してPython Engineを初期化
try
theSplashForm.Show;
theSplashForm.Refresh
//Scriptを入れるStringList
strScrList := TStringList.Create;
//結果を保存するStringList
strAnsList := TStringList.Create;
try
strScrList.Add('import json');
･･･略（自動採点用のPythonスクリプトをStringListに作成）･･･
//０による浮動小数除算の例外をマスクする
MaskFPUExceptions(True);
//Execute
PythonEngine1.ExecStrings(strScrList);
//先頭に認識した文字が入っている
if GetTokenIndex(strAnsList[0],',',0)='○' then
begin
//ShowMessage('The Python engine is now on standby!');
theSplashForm.StandbyLabel.Font.Color:=clBlue;
theSplashForm.StandbyLabel.Caption:='The P_Engine is now on standby!';
theSplashForm.StandbyLabel.Visible:=True;
Application.ProcessMessages;
//カウントダウン
for j:= 2 downto 1 do
begin
theSplashForm.TimeLabel.Caption:=Format('起動まであと%d秒', [j]);
Application.ProcessMessages;
Sleep(1000);
end;
end else begin
ShowMessage('Unable to initialize python engine!');
MessageDlg('Auto-scoring is not available!'+#13#10+
'Please contact your system administrator.',mtInformation,[mbOk],0);
end;
finally
//StringListの解放
strAnsList.Free;
strScrList.Free;
end;
finally
theSplashForm.Close;
theSplashForm.Destroy;
end;
これで「自動採点GroupBox」内の「実行」ボタンをクリックした際の処理が、ほぼ待ち時間なしで行われるようになった。これをやっておくのと、おかないのとでは、プログラムの使用感がまったく異なってくる･･･。上記のプログラムの for j := 2 downto 1 do 部分を「ムダ」だと思う方もいらっしゃるかもしれませんが、「画像の使用権を購入」してまで表示したスプラッシュ画面なので、せめて２秒間だけ！必要以上に長く表示させてください･･･。
# 輝度反転
from PIL import Image
import numpy as np
from matplotlib import pylab as plt
for i in range(2898):
# 画像の読み込み
im = np.array(Image.open(r"X:\Path"+r"\a"+'{0:04d}'.format(i)+".png").convert('L'))
# 輝度反転
im = 255 - im[:,:]
# print(im.shape, im.dtype)
#保存
Image.fromarray(im).save(r"X:\Path"+r"\a"+'{0:04d}'.format(i)+".png")
様々に思い悩んだが、結局、新規に作成する文字データは、白 or 黒いずれかの色のみで構成すると決めたので、中途半端なシミや汚れは排除することにして、シミや汚れのある画像を徹底的に手動で削除。これは修行だと考えて、１万枚を超える画像を１枚ずつチェックしながら、一心不乱に作業した。せっせ、せっせ、せっせ、せっせ･･･
this is the example where you need to put the "MaskFPUExceptions(True);"
procedure TForm1.Button1Click(Sender: TObject);
begin
MaskFPUExceptions(True);
PythonEngine1.ExecStrings( Memo1.Lines );
end;
そもそも「FPU」なるモノは、「Floating-point number Processing Unit：浮動小数点数演算装置」の略称とのことで、その「Exceptions」＝例外の「Mask」だから、「浮動小数点例外のマスク」ということでMaskFPUExceptions。実に覚えやすい良い名前。
「著者： Embarcadero Japan Support 2021年11月09日」ってコトは ･･･
（へぇー！ DelphiでもMNISTできるんだ。知らなかったー！！）
（しかも、日付がどちらかと言えば 最近！）
急に興味関心が湧いて、しばらく記事を読んでみる。記事によれば、現在 TensorFlow LiteがDelphiで利用可能とのこと（気分的には TensorFlow Super Heavy の方がマッチするんだけど、残念ながらそれはないようだ）。４年前にPythonでやったのと同じ、マウスで画面に数字を書いて、それが０～９の何なのかを判定するプログラムの画像が掲載され、「プロジェクト全体をダウンロードしてテストすることができます。」とある。
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.ToolBar1StartDock(Sender: TObject;
var DragObject: TDragDockObject);
begin
DragObject := TToolDockObject.Create(Sender as TToolBar);
end;
procedure TForm1.ControlBar1GetSiteInfo(Sender: TObject; DockClient: TControl;
var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);
begin
if Not (DockClient is TToolBar) then
Candock := False;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
r:TRect;
begin
r.Left:=ScrollBox1.Width div 2;
r.Top:=ScrollBox1.Height div 2;
r.Right:=r.Left+ToolBar1.Width;
r.Bottom:=r.Top+ToolBar1.Height;
ToolBar1.ManualFloat(r);
end;
//手続きを記述
procedure TToolDockSite.WMSysCommand(var Msg: TWMSysCommand);
var
hBarHandle : HMENU;
begin
case Msg.CmdType of
SC_CLOSE: begin
//処理
MessageDlg('閉じるボタンを無効化しました！', mtInformation, [mbOk] , 0);
//閉じたい場合
//inherited;
//閉じたくない場合
//ハンドルを取得
hBarHandle := GetSystemMenu(Self.Handle,False);
if hBarHandle <> 0 then
begin
//閉じるボタンを無効化する
EnableMenuItem(hBarHandle, SC_CLOSE,
(MF_BYCOMMAND or MF_DISABLED or MF_GRAYED));
//グレイアウトして無効化されるが、削除はできない
//DeleteMenu(hBarHandle, SC_CLOSE,
// (MF_BYCOMMAND or MF_DISABLED or MF_GRAYED));
end;
DrawMenuBar(Self.Handle);
//メッセージは「なかった」ことにする
Msg.Result:=0;
end;
else
inherited;
end;
end;
で、FormCreate時に、ドッキングを制御するクラスを指定。
procedure TForm1.FormCreate(Sender: TObject);
begin
//ToolBarの閉じるボタンを無効化
ToolBar1.FloatingDockSiteClass:=TToolDockSite;
end;
