procedure TForm1.ButtonExitClick(Sender: TObject);
var
hWndPSWindow: HWND;
begin
//PowerShellを閉じる
hWndPSWindow:=FindWindow(nil, PChar('Windows PowerShell'));
if hWndPSWindow <> 0 then
begin
SetForegroundWindow(hWndPSWindow);
//文字列の送信
SendKeys('Exit');
//Enterキーの送信
SendKeys(#13#10);
end else begin
ShowMessage('PowerShellのウィンドウが見つかりません！');
end;
end;
すると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;
Microsoft Windows [Version 10.0.22631.3007]
(c) Microsoft Corporation. All rights reserved.
C:\Windows\System32>cd \
C:\>cd C:\Users\XXX\Downloads\ViVeTool-v0.3.3
C:\Users\XXX\Downloads\ViVeTool-v0.3.3>vivetool /query /id:41799415
ViVeTool v0.3.3 - Windows feature configuration tool
[41799415]
Priority : Service (4)
State : Enabled (2)
Type : Experiment (1)
C:\Users\XXX\Downloads\ViVeTool-v0.3.3>vivetool /disable /id:41799415
ViVeTool v0.3.3 - Windows feature configuration tool
Successfully set feature configuration(s)
C:\Users\XXX\Downloads\ViVeTool-v0.3.3>
そうやって新しいマクロ有効Excel Bookを作成。これを入れる所定のフォルダを作り、保存。準備万端にして、新しい Windows VCLアプリケーションも作成。で、これまで勉強した中で、いちばん動作が確実と思えるコードで「ワークシート間で式をコピーする」手続きを作成、コンパイル、そして「実行」。期待通りに、エラーなく、データのコピー（読み出しと書き込み）終了。胸がすっきり。Bookを開いて結果を確認。データはちゃんと書き込まれ、ワークシートが初期化されてる。もちろん、Excelもきれいに終了。タスクマネージャーで確認してもプロセスは残ってない。
お使いのPCで、Visual C++ ランタイム ライブラリのインストール状況を確認するには、[スタート] ボタンを右クリックし、「ファイル名を指定して実行」をクリックして、appwiz.cpl と入力して[Enter]を押します。Python環境を組み込んだ MS_Reader が動作する環境であれば、システムにインストールされている Microsoft Visual C++ ランタイム ライブラリが以下のように表示されるはずです。
現在、私のシステム（Windows 11 Pro 23H2）にインストールされているC++ランタイムライブラリの一覧。 もちろん、このシステムでPython環境を組み込んだマークシートリーダーが正常に動作しています。
エラーを解決するには、Visual C++ランタイムライブラリをインストールすればいいわけですが、上の例のように Visual C++ ランタイムはたくさんあるので、手動でひとつひとつダウンロードしてインストールするより、Visual C++ ランタイムインストーラーを使って全ての Visual C++ ランタイムを一括インストールする方が簡単です。
システムをリカバリする前は、次のようにして Visual C++ ランタイムをインストールしていました。
【ご注意願います！】
ここで紹介する方法で Visual C++ ランタイムをインストールする場合、他のプログラムの実行環境との整合性は、一切保証できません。また、最悪の場合、Windowsが起動しなくなるトラブルが発生することも十分に考えられます。インストール作業の全てが自己責任であることを十分ご理解の上、重大な問題が発生した場合は元の環境に戻せるよう、システムのバックアップを取る・現在の設定をメモに記録する等、不具合の発生に備え、必要かつ十分な準備を整えた上で、Visual C++ ランタイムのインストールを行ってください。
以下のサイトから「Visual C++ v56.exe」をダウンロードしてインストール（私の環境にインストールする分には、なんの問題も起きませんでした。もちろん、マークシートリーダーも問題なく起動し、安定動作しました）。
ここから先は、上記のインストーラーを用いて Visual C++ ランタイムをインストールした際、私が実際に経験したトラブル？です（最終的にインストールは成功しました）。
お決まりのUAC起動後（PCの設定によっては）管理者ID 及びパスワードの入力が求められますが、これを入力すると、そのままPCがフリーズしたような状態になり、数分待機しても進展が見られないので、いったん作業を Ctrl＋Alt＋Delete でキャンセルし、再度、「Visual C++ v56.exe」を起動して Visual C++ ランタイムのインストール作業を実行、今度はトラブルなくインストールに成功する事例です。これは「ある特定のAD環境下にあるPCのすべてに共通して見られた」現象です。現在もその原因はわかりませんが、ご参考まで。
この初期化を「するか・しないか」で、MS_Reader 起動後、初めてマークを「読む」ボタンをクリックした際のプログラムの挙動がまるで違ったものになります。初期化を行った場合は、ごくスムーズにマーク読み取りが始まるのに対し、行わなかった場合は PC が一瞬フリーズしたような状態になり、その後、息を吹き返すかのようにマークの読み取りが始まります。
Python Engine の初期化コードです。
AppDataDir:=ExtractFilePath(Application.ExeName)+'Python39-32';
if DirectoryExists(AppDataDir) then
begin
//フォルダが存在したときの処理
CheckPython.Enabled:=True;
CheckPython.Checked:=True;
PythonEngine1.AutoLoad:=True;
PythonEngine1.IO:=PythonGUIInputOutput1;
PythonEngine1.DllPath:=AppDataDir;
PythonEngine1.SetPythonHome(PythonEngine1.DllPath);
PythonEngine1.LoadDll;
PythonDelphiVar1.Engine:=PythonEngine1;
PythonDelphiVar1.VarName:=AnsiString('var1');
PythonEngine1.Py_Initialize;
//イニシャライズされたことを記憶
P4D_ini:=True;
end else begin
CheckPython.Checked:=False;
CheckPython.Enabled:=False;
PythonEngine1.AutoLoad:=False;
P4D_ini:=False;
end;
（どこに問題があるのでしょうか？）
PC によっては、この Python Engine の初期化に非常に長い時間を要することがあるようです（エラーメッセージは出ません。この沈黙の時間が終わった後、プログラムは問題なく動作します）。偶然、ある PC でこの現象に巡り合い、あわてて時間を計ってみたところ、その PC では初期化に４分必要でした！ なぜ、このような現象が発生するのか、その理由がわからないのですが、「そのようなことがある」ことだけは経験的に明らかですので、ここに書いておくことにしました。
Excel Book への読み取り結果の書き出しは、自分用に（あれば便利かなー☆）と思って作成したものです。ですので、式の入ったセルを保護する等、第三者が使うことへの配慮は何一つ行っていません。セルに入力された式やVBAの内容をご自身でメンテナンスできる方なら、お使いいだけるかな？ という程度のシロモノです。
添付した Excel Book はこれまでに何度も「実際に使用して動作に誤りがないことを確認済み」ですが、誤って式を削除したりした場合は（当然ですが）意図した通りに動作しません。ですので、こちらも動作保証は一切ありません。ご使用はあくまでも自己責任でお願いします。この Excel Book に対しても、このプログラムの使用要件にあります免責事項がそのまま適用されますことを申し添えます。
以下、試験実施前に行っておくとよい採点準備作業です。
eFile フォルダに「一般用マークと手書き併用採点シート.xltm」というマクロ有効テンプレートがあります。これをダブルクリックすると「一般用マークと手書き併用採点シート1.xlsx」という名前で新しい Excel Book が作られます。拡張子に注意してください。「.xlsx」です。このままでは期待通りに動作しませんので、適切な名前を付け、拡張子を「.xlsm」（マクロが有効な Excel Book ）に変更して eFile フォルダ（必ずこのフォルダに保存してください！）に保存します。
ここでは test.xlsm という名前で保存したことにして説明を続けます。
「コンテンツの有効化」をクリックしてマクロが実行できるようにしてください。
【インターネットからダウンロードしたマクロ有効 Excel Book の取り扱い】
いつからこうなったのか、わかりませんが、インターネットからダウンロードした拡張子 xlsm の Excel Book をダブルクリックして開くと、次のメッセージが表示されるようになりました。
「編集を有効にする」をクリックすると･･･マクロを動かすことができません！
こうなった時は、いったん Book を閉じて、その Excel ファイルを右クリックして表示されるサブメニューのプロパティをクリックして、全般タブのいちばん下にある「セキュリティ：」の「許可する」にチェックします（チェックする＝マクロの実行をご自身の責任で行うことになります。どうか、ご注意ください）。
Excel Book を利用して採点する場合、大変重要な注意事項があります。それは欠席者がいた場合の処理です。該当試験に欠席者がいる場合は、その欠席者の出席番号位置に未使用のマークシートを挿入し、シートが確実に出席番号順に並んでいることを確認してから、スキャナーでスキャンしてください。 ※ 可能であれば、この用途専用に未使用のマークシートを複数枚、最初から手元に準備しておくとよいと思います。
Excel へデータを書き込む際は、上記注意事項を必ずお守りください。この注意を忘れて Excel が起動したまま、Excel Book への書き込みを実行すると最悪の場合、Excel のプロセスが幽霊のように残り、これを終了することが出来なくなって、復旧するには、システムの再起動しかない状態になります。未保存の重要なデータがあるような場合、当然そのデータは失われます。Excel Book へのデータ書き込み時は、Excel が起動していないことを（タスクバーに眠っている Excel Book がないことも含めて）十分確認した上で、書き込み作業を行ってください。
【書き出し処理】
マークシートを読み取り後、読み取り結果のチェックまで完了したら、Excel Book への読み取り結果の書き出しが可能となります。次のようにマークシートリーダーを操作してください。
ファイル名がなぜ「Scanner_A.xlsm」になったかというと、マークシートの読み取り元フォルダとして選択したのが、ProcData\Scanner_A であったためです。プログラムは、マークシートの読み取り元フォルダの名称をそのまま、原本「test.xlsm」をコピーして生成する読み取り結果書き込み先 Excel Book の名称として利用します。
function MessageBox(const Text, Caption: PChar; Flags: Longint = MB_OK): Integer;
所有者ウィンドウへのハンドルが確かに省略されている。
実際のコードで、Windows.MessageBox とした場合には･･･
procedure TForm1.Button4Click(Sender: TObject);
begin
Winapi.Windows.MessageBox(Handle, PChar('Do you know Delphi?'), PChar('情報'), MB_OK or MB_ICONINFORMATION);
end;
だったのが、第一引数のHandle は必要なくなり、（ OK ボタンのみの表示でよければ）MB_OK も省略できるようなので、次のように
procedure TForm1.Button3Click(Sender: TObject);
begin
Application.MessageBox(PChar('Do you know Delphi?'), PChar('情報'), MB_ICONINFORMATION);
end;
･･･とずい分、短くなる。それどころか、PChar型への型変換も省略可能なようで･･･
procedure TForm1.Button5Click(Sender: TObject);
begin
Application.MessageBox('Do you know Delphi?', '情報', MB_ICONINFORMATION);
end;
var
strMsg:string;
begin
strMsg:='メッセージ';
Application.MessageBox(PChar(strMsg), PChar('情報'), MB_ICONINFORMATION);
end;
別の文字列型変数をさらに代入したり、また、改行を含む表示も、
procedure TForm1.Button2Click(Sender: TObject);
var
strMsg, strPath:string;
begin
strPath:='C:\abc\def';
strMsg:='出力先は次の場所です。' + #13#10 + #13#10 + strPath;
Application.MessageBox(PChar(strMsg), PChar('情報'), MB_ICONINFORMATION);
end;
複数のボタンを表示。例えば、「はい」・「いいえ」の二択なら、
procedure TForm1.Button3Click(Sender: TObject);
begin
//Information
if Application.MessageBox(PChar('Do you know Delphi?'), PChar('情報'), MB_YESNO or MB_ICONINFORMATION) = mrYes then
begin
//[はい]が選ばれた時
Application.MessageBox(PChar('Gooooooooooooood!'), PChar('情報'), MB_ICONINFORMATION);
end else begin
//[いいえ]が選ばれた時
Application.MessageBox(PChar('No!'), PChar('情報'), MB_ICONINFORMATION);
end;
end;
二択だから「キャンセルはない」 （閉じるボタンは自動的に無効になる）
ユーザーに「キャンセル」も許可するなら、
procedure TForm1.Button4Click(Sender: TObject);
var
StrMsg: String;
intRet: Integer;
begin
StrMsg := 'Do you know Delphi?';
intRet := Application.MessageBox(PChar(StrMsg), PChar('情報'),
MB_YESNOCANCEL or MB_ICONQUESTION);
if intRet = mrYes then begin
//[はい]を選択した時の処理
end else
if intRet = mrNo then begin
//[いいえ]を選択した時の処理
end else
if intRet = mrCancel then begin
//[キャンセル]を選択した時の処理
Application.MessageBox(PChar('ユーザーによる処理のキャンセル'), PChar('情報'), MB_ICONINFORMATION);
end;
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
Application.MessageBox('Do you know Delphi?', '情報', MB_OK or MB_RETRYCANCEL or MB_ICONINFORMATION);
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 部分を「ムダ」だと思う方もいらっしゃるかもしれませんが、「画像の使用権を購入」してまで表示したスプラッシュ画面なので、せめて２秒間だけ！必要以上に長く表示させてください･･･。
「著者： 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;
