procedure TForm1.btnGetSquareClick(Sender: TObject);
var
//PythonのScriptを入れる
strScrList:TStringList;
//Pythonから送られたデータを保存する -> グローバル変数化
//strAnsList:TStringList;
//Sort
i,j:integer;
//strFileName:string;
strList:TStringList;
//画像の等幅分割
//切り出し領域
top_x, top_y:integer;
yHeight:integer;
//xの増分
xWidth, iMax:integer;
//for Imageの読み込み
sourceImage: PIplImage;
//画像データのファイル名
p1:PAnsiChar;
//x座標の補正
str1, str2, str3, str4:string;
begin
//画像分割処理なし（初期状態）
{
//初期化
Memo1.Clear;
//Scriptを入れるStringList
strScrList:=TStringList.Create;
//結果を保存するStringList
strAnsList:=TStringList.Create;
try
//Python Script
strScrList.Add('import cv2');
strScrList.Add('import numpy as np');
strScrList.Add('from PIL import Image');
//strScrList.Add('img = cv2.imread("./ProcData/sample2.jpg")');
//strScrList.Add('img = cv2.imread(r"'+StatusBar1.SimpleText+'")');
strScrList.Add('pil_img = Image.open(r"'+StatusBar1.SimpleText+'")');
strScrList.Add('img = np.array(pil_img)');
strScrList.Add('gray = cv2.cvtColor(img, cv2.COLOR_BGR2GRAY)');
strScrList.Add('gray = 255 - gray');
strScrList.Add('ret, bin_img = cv2.threshold(gray, 20, 255, cv2.THRESH_BINARY)');
strScrList.Add('contours, hierarchy = cv2.findContours(bin_img, cv2.RETR_LIST, cv2.CHAIN_APPROX_SIMPLE)');
strScrList.Add('contours = list(filter(lambda x: cv2.contourArea(x) > '+cmbThreshold.Text+', contours))');
strScrList.Add('for i in range(len(contours)):');
strScrList.Add(' im_con = img.copy()');
strScrList.Add(' x, y, w, h = cv2.boundingRect(contours[i])');
strScrList.Add(' var1.Value =str(x)+","+str(y)+","+str(x+w)+","+str(y+h)');
//Scriptを表示
Memo1.Lines.Assign(strScrList);
//「０による浮動小数点数除算」のエラーを出ないようにするおまじない
MaskFPUExceptions(True);
//Execute
PythonEngine1.ExecStrings(Memo1.Lines);
//結果を表示
Memo2.Lines.Assign(strAnsList);
finally
//StringListの解放
strAnsList.Free;
strScrList.Free;
end;
}
//画像分割処理ここから
//初期化
//Memo1.Clear;
Memo2.Clear;
MemoTemp.Clear;
//初期化（定数的に利用する）
top_y:=0;
//分割数
iMax:=StrToInt(cmbPartition.Text);
//結果を保存するStringList
strAnsList:=TStringList.Create;
//初期化
xWidth:=0;
try
for i := 0 to iMax-1 do
begin
//画像を読み込む(Bitmap・JPEGどちらも読み込み可能)
p1:=PAnsiChar(AnsiString(StatusBar1.SimpleText));
sourceImage := cvLoadImage(p1, CV_LOAD_IMAGE_ANYDEPTH or CV_LOAD_IMAGE_ANYCOLOR);
//intとTruncは小数点以下を切り捨て。異なるのは、戻り値がintは実数、Truncは整数になること
xWidth:=Trunc(SimpleRoundTo(sourceImage.Width/iMax,0));
yHeight:=sourceImage.Height;
//切り出す座標を指定
top_x:= xWidth * i;
try
//指定範囲の画像を切り出して保存
//cvRect(x, y, Width, Height)
cvSetImageROI(sourceImage,cvRect(top_x, top_y, xWidth, yHeight));
//String 型の文字列を PAnsiChar 型の文字列に変換
//AnsiString 型でキャストして更に PAnsiChar でキャスト
p1:=PAnsiChar(AnsiString('CutImage0'+IntToStr(i)+'.jpg'));
//画像を保存する
cvSaveImage(p1, sourceImage);
finally
//イメージの解放
cvReleaseImage(sourceImage);
end;
end;
for i := 0 to iMax-1 do
begin
//Scriptを入れるStringList
strScrList:=TStringList.Create;
//x座標の補正値を計算
top_x:= xWidth * i;
try
//Python Script
strScrList.Add('import cv2');
strScrList.Add('import numpy as np');
strScrList.Add('from PIL import Image');
//strScrList.Add('img = cv2.imread("./ProcData/sample2.jpg")');
//strScrList.Add('img = cv2.imread(r"'+StatusBar1.SimpleText+'")');
//strScrList.Add('pil_img = Image.open(r"'+StatusBar1.SimpleText+'")');
strScrList.Add('pil_img = Image.open(r"'+'CutImage0'+IntToStr(i)+'.jpg'+'")');
strScrList.Add('img = np.array(pil_img)');
strScrList.Add('gray = cv2.cvtColor(img, cv2.COLOR_BGR2GRAY)');
strScrList.Add('gray = 255 - gray');
strScrList.Add('ret, bin_img = cv2.threshold(gray, 20, 255, cv2.THRESH_BINARY)');
strScrList.Add('contours, hierarchy = cv2.findContours(bin_img, cv2.RETR_LIST, cv2.CHAIN_APPROX_SIMPLE)');
strScrList.Add('contours = list(filter(lambda x: cv2.contourArea(x) > '+cmbThreshold.Text+', contours))');
strScrList.Add('for i in range(len(contours)):');
strScrList.Add(' im_con = img.copy()');
strScrList.Add(' x, y, w, h = cv2.boundingRect(contours[i])');
strScrList.Add(' var1.Value =str(x)+","+str(y)+","+str(x+w)+","+str(y+h)');
//Scriptを表示
Memo1.Clear;
Memo1.Lines.Assign(strScrList);
//「０による浮動小数点数除算」のエラーを出ないようにするおまじない
MaskFPUExceptions(True);
//Execute
PythonEngine1.ExecStrings(Memo1.Lines);
//結果を表示
if RadioButton1.Checked then
begin
//x座標を補正する
MemoTemp.Lines.Assign(strAnsList);
if i<>0 then
begin
for j := 0 to MemoTemp.Lines.Count-1 do
begin
//値を取得
str1:=GetTokenIndex(MemoTemp.Lines[j],',',0);
str2:=GetTokenIndex(MemoTemp.Lines[j],',',1);
str3:=GetTokenIndex(MemoTemp.Lines[j],',',2);
str4:=GetTokenIndex(MemoTemp.Lines[j],',',3);
//カンマ区切りの文字列の1,3番目にtop_x値を加える（座標を修正）
str1:=IntToStr(StrToInt(str1)+top_x);
str3:=IntToStr(StrToInt(str3)+top_x);
//書き戻し
MemoTemp.Lines[j]:=str1+','+str2+','+str3+','+str4;
end;
end;
end else begin
Memo2.Lines.Assign(strAnsList);
end;
finally
//StringListの解放
//strAnsList.Free;
strAnsList.Clear;
strScrList.Free;
end;
//横書きの場合のみ実行
if RadioButton1.Checked then
begin
//strFileName:=ExtractFilePath(StatusBar1.SimpleText)+'Temp.csv';
//MemoTemp.Lines.SaveToFile(strFileName);
strList := TStringList.Create;
try
for j := 0 to MemoTemp.Lines.Count-1 do
begin
strList.Add(MemoTemp.Lines[j]);
end;
//並び替え 降順 -> True
//if RadioButton1.Checked then
//begin
fAscending := False;
fIndex := 1; //２番目の項目を
fStyle := ssInteger; //整数型でソート
strList.CustomSort(MyCustomSort); //ソート開始
//end else begin
// fAscending := True;
// fIndex := 0; //１番目の項目を
// fStyle := ssInteger; //整数型でソート
// strList.CustomSort(MyCustomSort); //ソート開始
//end;
//データ抽出
//Memo2.Clear;
for j := 0 to strList.Count - 1 do
begin
Memo2.Lines.Add(strList[j]);
end;
finally
MemoTemp.Clear;
strList.Free;
end;
end;
end;
finally
//StringListの解放
strAnsList.Free;
end;
//画像分割処理ここまで
//縦書きの場合のみ実行
if RadioButton2.Checked then
begin
//strFileName:=ExtractFilePath(StatusBar1.SimpleText)+'Temp.csv';
//Memo2.Lines.SaveToFile(strFileName);
strList := TStringList.Create;
try
for i := 0 to Memo2.Lines.Count-1 do
begin
strList.Add(Memo2.Lines[i]);
end;
//並び替え 降順 -> True
//if RadioButton2.Checked then
//begin
// fAscending := False;
// fIndex := 1; //２番目の項目を
// fStyle := ssInteger; //整数型でソート
// strList.CustomSort(MyCustomSort); //ソート開始
//end else begin
fAscending := True;
fIndex := 0; //１番目の項目を
fStyle := ssInteger; //整数型でソート
strList.CustomSort(MyCustomSort); //ソート開始
//end;
//データ抽出
Memo2.Clear;
for i := 0 to strList.Count - 1 do
begin
//Memo2.Lines.Add(GetCommaText(strList.Strings[i],fIndex));
Memo2.Lines.Add(strList[i]);
end;
finally
strList.Free;
end;
end;
if RadioButton2.Checked then
begin
ScrollBox1.HorzScrollBar.Position:=ScrollBox1.HorzScrollBar.Range;
end else begin
//ScrollBarが表示されていなくてもエラーにならない
ScrollBox1.HorzScrollBar.Position:=0;
end;
//表示
LBRow.Visible:=True;
LBRow2.Visible:=True;
//操作可能に設定
btnOpen.Enabled:=True;
btnSave.Enabled:=True;
//操作不可に設定
btnGetSquare.Enabled:=False;
//先頭へスクロール
Memo2.Perform(WM_VSCROLL,SB_TOP,0);
//先頭行へ
Memo2.SelStart:=SendMessage(Memo2.Handle, EM_LineIndex, 0, 0);
Memo2.Perform(EM_SCROLLCARET, 0, 0); //キャレット位置までスクロール
Memo2.SetFocus;
GetLinePos;
//矩形を表示
Memo2Click(Sender);
end;
ちなみに、最後の解答欄矩形を表示する処理は･･･
procedure TForm1.Memo2Click(Sender: TObject);
var
i:integer;
//x1,x2,x3,x4:integer;
//y1,y2,y3,y4: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);
//ShowMessage(IntToStr(i));
//エラー対策
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.FormCreate(Sender: TObject);
var
dllFileName:string;
begin
//リソースからDLLを（なければ）生成
dllFileName:=ExtractFilePath(Application.ExeName)+'XXX.dll';
//ファイルの存在を確認
if not FileExists(dllFilename) then
begin
//リソースを再生
with TResourceStream.Create(hInstance, 'Resource_1', RT_RCDATA) do
begin
try
SaveToFile(dllFileName);
finally
Free;
end;
end;
end;
end;
private
{ Private 宣言 }
Setup_FolderPath:string;
Setup_ExeName:string;
implementation
{$R *.dfm}
uses
Winapi.ShlObj, Vcl.FileCtrl, System.UITypes, plShortcutUtils;
//ShlObjはSHGetKnownFolderPath関数を使用するために追加
//ShellExecute関数を使用してフォルダを開いて表示する場合はWinapi.ShellAPIも追加する
//Vcl.FileCtrlは、新しいフォルダ作成ボタン付きフォルダの選択ダイアログの表示に必要
procedure TForm1.btnAutoClick(Sender: TObject);
var
FolderID:TGUID;
FolderPath:PChar;
rsFileName:string;
LDir:String;
begin
//マイドキュメントフォルダへのPathを取得する
FolderID:=StringToGUID('{FDD39AD0-238F-46AF-ADB4-6C85480369C7}');
if SHGetKnownFolderPath(FolderID,0,0,FolderPath)= S_OK then
begin
Setup_FolderPath := FolderPath;
end;
//インストール先フォルダの有無を調査->なければ作成
if not System.SysUtils.DirectoryExists(ExtractFileDir(Setup_FolderPath+'\'+Setup_ExeName+'\')) then
begin
//フォルダ階層を作成
System.SysUtils.ForceDirectories(ExtractFileDir(Setup_FolderPath+
'\'+Setup_ExeName+'\'));
end;
//Path
rsFileName:=Setup_FolderPath+'\'+Setup_ExeName+'\'+Setup_ExeName+'.exe';
//ファイルがある場合は削除
if FileExists(rsFilename) then
begin
//ファイルが存在したときの処理
DeleteFile(rsfileName);
end;
//リソースを再生
with TResourceStream.Create(hInstance, 'Resource_1', RT_RCDATA) do
begin
try
SaveToFile(rsFileName);
finally
Free;
end;
end;
//デスクトップにこのプログラムのショートカットを作成
if CheckCreateShortCut.Checked then
begin
//plShortcutUtilsユニット内の関数類を使用
//CSIDL_DESKTOP等の定数名の使用にはusesにShlObjが必要
//CSIDLの値からフルパスを取得
//ショートカットを作成する場所
LDir := GetDirectoryFromCSIDL(CSIDL_DESKTOP);
if CreateShortCutLink(rsFileName, LDir, Setup_ExeName) then begin
//ショートカットの作成場所によっては，以下のコードで更新が必要
//SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0);
end;
MessageDlg('Done!', mtInformation, [mbOk] , 0);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
FolderID:TGUID;
FolderPath:PChar;
begin
//インストールするEXEの名前
Setup_ExeName:=EditExeName.Text;
//マイドキュメントフォルダへのPathを取得する
FolderID:=StringToGUID('{FDD39AD0-238F-46AF-ADB4-6C85480369C7}');
if SHGetKnownFolderPath(FolderID,0,0,FolderPath)= S_OK then
begin
Setup_FolderPath := FolderPath;
EditPath.Text:= Setup_FolderPath;
end;
end;
procedure TForm1.RadioGroup1Click(Sender: TObject);
var
FolderID:TGUID;
FolderPath:PChar;
begin
case RadioGroup1.ItemIndex of
0:begin
//マイドキュメントフォルダへのPathを取得する
FolderID:=StringToGUID('{FDD39AD0-238F-46AF-ADB4-6C85480369C7}');
if SHGetKnownFolderPath(FolderID,0,0,FolderPath)= S_OK then
begin
Setup_FolderPath := FolderPath;
EditPath.Text:= Setup_FolderPath;
end;
end;
1:begin
//マイコンピュータへのPathを取得する
Setup_FolderPath := 'C:\';
EditPath.Text:= Setup_FolderPath;
end;
end;
end;
ちなみに、PCを選択した場合に表示される「フォルダーの参照」ダイアログは･･･
PCのフォルダ構成に詳しい人向きの表示になります･･･
で、インストール先を選ぶ「変更」ボタンをクリックした際の挙動は･･･
procedure TForm1.btnGetPathClick(Sender: TObject);
var
SelectDir: String;
begin
case RadioGroup1.ItemIndex of
0:begin
//フォルダを選択 -> MyDocumentsを指定
//if SelectDirectory('', '::' + GUIDToString(CLSID_MyDocuments), SelectDir) then
//MyDocumentsを指定 -> MyDocumentsを指定 & 新しいフォルダ作成ボタン付き
if SelectDirectory('', '::' + GUIDToString(CLSID_MyDocuments), SelectDir,
[sdNewUI, sdNewFolder, sdShowEdit], Self) then
begin
EditPath.Text:=SelectDir;
Setup_FolderPath:=EditPath.Text;
end;
end;
1:begin
//フォルダを選択 -> を指定
//if SelectDirectory('', '::' + GUIDToString(CLSID_MyComputer), SelectDir) then
//MyMyComputerを指定 -> MyMyComputerを指定 & 新しいフォルダ作成ボタン付き
if SelectDirectory('', '::' + GUIDToString(CLSID_MyComputer), SelectDir,
[sdNewUI, sdNewFolder, sdShowEdit], Self) then
begin
EditPath.Text:=SelectDir;
Setup_FolderPath:=EditPath.Text;
end;
end;
end;
end;
procedure TForm1.btnOKClick(Sender: TObject);
var
rsFileName:string;
LDir:String;
begin
//Path
rsFileName:=Setup_FolderPath+'\'+Setup_ExeName+'.exe';
//ファイルがある場合は削除
if FileExists(rsFilename) then
begin
//ファイルが存在したときの処理
DeleteFile(rsfileName);
end;
//リソースを再生
with TResourceStream.Create(hInstance, 'Resource_1', RT_RCDATA) do
begin
try
SaveToFile(rsFileName);
//MessageDlg('Generate!', mtInformation, [mbOk] , 0);
finally
Free;
end;
end;
//デスクトップにこのプログラムのショートカットを作成
if CheckCreateShortCut.Checked then
begin
//plShortcutUtilsユニット内の関数類を使用
//CSIDL_DESKTOP等の定数名の使用にはusesにShlObjが必要
//CSIDLの値からフルパスを取得
//ショートカットを作成する場所
LDir := GetDirectoryFromCSIDL(CSIDL_DESKTOP);
if CreateShortCutLink(rsFileName, LDir, Setup_ExeName) then begin
//ショートカットの作成場所によっては，以下のコードで更新が必要
//SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0);
end;
MessageDlg('Done!', mtInformation, [mbOk] , 0);
end;
end;
procedure TForm1.chkPWClick(Sender: TObject);
begin
if chkPW.Checked then
begin
EditPW.PasswordChar := #0;
end else begin
EditPW.PasswordChar := '*';
end;
end;
procedure TForm1.chkZahyoClick(Sender: TObject);
begin
if chkZahyo.Checked then
begin
//Enabled
Timer1.Enabled:=True;
end else begin
//Enabled
Timer1.Enabled:=False;
LabelXY.Caption:='[X座標, Y座標]';
end;
end;
procedure TForm1.chkSettingClick(Sender: TObject);
begin
if chkSetting.Checked then
begin
LabelID.Visible:=True;
btnCopy.Visible:=True;
btnCopy.Enabled:=True;
Edit1.Visible:=True;
LabelX.Visible:=True;
EditX.Visible:=True;
LabelY.Visible:=True;
EditY.Visible:=True;
btnSave.Visible:=True;
chkZahyo.Visible:=True;
LabelXY.Visible:=True;
LabelWaitTime.Visible:=True;
cmbWaitTime.Visible:=True;
end else begin
LabelID.Visible:=False;
btnCopy.Visible:=False;
Edit1.Visible:=False;
LabelX.Visible:=False;
EditX.Visible:=False;
LabelY.Visible:=False;
EditY.Visible:=False;
btnSave.Visible:=False;
chkZahyo.Visible:=False;
LabelXY.Visible:=False;
LabelWaitTime.Visible:=False;
cmbWaitTime.Visible:=False;
end;
end;
（３）入力値の保存／読み込みと暗号化
各VCLコントロールに入力された値は、必要な個所は暗号化してiniファイルに保存する。
uses
System.IniFiles;
procedure TForm1.btnSaveClick(Sender: TObject);
var
strID:string;
Ini:TIniFile;
begin
//入力の有無をCheck
if Edit1.Text='' then
begin
MessageDlg('IDとして利用するメールアドレスを入力してください', mtInformation, [mbOk] , 0);
Edit1.SetFocus;
Exit;
end;
if (EditX.Text='') or (EditY.Text='') then
begin
if EditX.Text='' then
begin
MessageDlg('自動クリックするＸ座標を入力してください', mtInformation, [mbOk] , 0);
EditX.SetFocus;
end;
if EditY.Text='' then
begin
MessageDlg('自動クリックするＹ座標を入力してください', mtInformation, [mbOk] , 0);
EditY.SetFocus;
end;
Exit;
end;
if cmbWaitTime.Text='' then
begin
MessageDlg('カーソル移動の待機時間をミリ秒単位で入力してください', mtInformation, [mbOk] , 0);
cmbWaitTime.SetFocus;
Exit;
end;
//暗号化
strID:=EDText(Edit1.Text, IntToStr(HashOf('XXXXXXXX')), True);
//iniファイルに保存
Ini := TIniFile.Create(ChangeFileExt(Application.ExeName, '.ini'));
try
//保存
Ini.WriteString('Section', 'ID', strID);
Ini.WriteString('Section', 'IchiX', EditX.Text);
Ini.WriteString('Section', 'IchiY', EditY.Text);
Ini.WriteString('Section', 'WaitTime', cmbWaitTime.Text);
//Userに通知
MessageDlg('現在の設定を保存しました！', mtInformation, [mbOk] , 0);
if not btnCopy.Enabled then btnCopy.Enabled:=True;
finally
Ini.Free;
end;
end;
コードの中で使用しているEDText関数はテキスト暗号化の関数。
private
{ Private 宣言 }
//HashNameMBCS(Create hashed values from a Unicode string)
//MBCS:Multibyte Character Set=マルチバイト文字セット
function HashOf(const key: string): cardinal;
//テキスト暗号化/復号化
Function EDText(KeyStr,PassW:string; EncOrDec:Boolean):string;
//KeyStr:平文 or 暗号化文のいずれかを指定
//PassW:パスワード
//EncOrDec:True -> Encode / False -> Decode
public
{ Public 宣言 }
end;
function TForm1.HashOf(const key: string): cardinal;
var
I: integer;
begin
Result := 0;
for I := 1 to length(key) do
begin
Result := (Result shl 5) or (Result shr 27);
Result := Result xor Cardinal(key[I]);
end;
end;
function TForm1.EDText(KeyStr, PassW: string; EncOrDec: Boolean): string;
var
{暗号化用変数}
Source, Dest, Password:TStringBuilder;
lpSource, lpPass:Integer;
PassValue, SourceValue, EDValue:Word;
{共用変数}
//乱数の種
Seed1,Seed2,Seed3:integer;
//実数の一様乱数
RandNum:Double;
//秘密鍵Seed
Seed:string;
{復号化用変数}
DecSource:string;
begin
//１．シード値を準備
// (1)Passwordを整数へ変換→シード値１へ代入
Password := TStringBuilder.Create;
//Seed1を初期化
//Seed1:=0;
try
Password.Append(PassW);
PassValue := 0;
for lpPass := 0 to Password.Length - 1 do
begin
//パスワード→整数
PassValue := PassValue + Word(Password.Chars[lpPass]);
end;
Seed1:=PassValue;
finally
Password.Free;
end;
// (2)パスワード文字列の長さを取得→シード値２へ代入
Seed2:= ElementToCharLen(PassW,Length(PassW));
// (3)シード値１とシード値２の排他的論理和を計算して、シード値３へ代入
Seed3 := Seed1 xor Seed2;
//２．実数の一様乱数を計算
//---------------------------------------------------------------------------
// ０より大きく１より小さい実数の一様乱数を発生する関数
// B.A.Wichmann and I.D.Hill, Applied Statistics, 31, 1982, p.188 に基づく
// Seed1-3に入れる初期値（整数）は16bit長(maxint=32767)で十分
// Seed1-3には1から30000までの任意の整数値を準備する(０ではいけない)
//---------------------------------------------------------------------------
//Seed1:=171*Seed1 mod 30269 と同値
Seed1:=(Seed1 mod 177)*171-(Seed1 div 177)* 2;
if Seed1<0 then Seed1:=Seed1+30269;
//Seed2:=172*Seed1 mod 30307 と同値
Seed2:=(Seed2 mod 176)*172-(Seed2 div 176)* 35;
if Seed2<0 then Seed2:=Seed2+30307;
//Seed1:=170*Seed1 mod 30323 と同値
Seed3:=(Seed3 mod 178)*170-(Seed3 div 178)* 63;
if Seed3<0 then Seed3:=Seed3+30323;
//See1-3それぞれの乱数を0<RandNum<1となるように
//計算結果が０より大きく、１未満の実数に直し、和の小数部分をとる
RandNum:=(Seed1/30269.0) + (Seed2/30307.0) + (Seed3/30323.0);
while RandNum>=1 do RandNum:=RandNum-1;
//３．秘密鍵を生成
//整数の一様乱数の上限値を決めて、整数の一様乱数を生成し、
//これに上で計算した実数の一様乱数を加えて秘密鍵を生成する
//Seedが秘密鍵（文字列として利用）となる
Seed:= FloatToStr(RandNum + trunc((Seed1+Seed2+Seed3)*RandNum));
//４．暗号化 / 復号化
if (EncOrDec) then
begin
//暗号化（Encode）
Source := TStringBuilder.Create;
Dest := TStringBuilder.Create;
Password := TStringBuilder.Create;
try
Source.Append(KeyStr);
//秘密鍵をセット
Password.Append(Seed);
lpPass := 0;
//テキストのエンコード
for lpSource := 0 to Source.Length - 1 do
begin
//パスワード→整数
if Password.Length = 0 then
PassValue := 0
else begin
PassValue := Word(Password.Chars[lpPass]);
Inc(lpPass);
if lpPass >= Password.Length then lpPass := 0;
end;
//テキスト→整数
SourceValue := Word(Source.Chars[lpSource]);
//XOR演算
EDValue := PassValue xor SourceValue;
//16進数文字列に変換
Dest.Append(IntToHex(EDValue, 4));
//処理結果を返り値にセット
Result:=Dest.ToString;
end;
finally
Password.Free;
Dest.Free;
Source.Free;
end;
end else begin
//復号化（Decode）
DecSource:=keyStr;
Dest := TStringBuilder.Create;
Password := TStringBuilder.Create;
try
//暗号化テキストのデコード
Dest.Clear;
Password.Clear;
//秘密鍵をセット
Password.Append(Seed);
lpPass := 0;
for lpSource := 1 to Length(DecSource) div 4 do
begin
SourceValue := StrToInt('$' + Copy(DecSource, (lpSource - 1) * 4 + 1, 4));
if Password.Length = 0 then
PassValue := 0
else
begin
PassValue := Word(Password.Chars[lpPass]);
Inc(lpPass);
if lpPass >= Password.Length then lpPass := 0;
end;
EDValue := SourceValue xor PassValue;
Dest.Append(Char(EDValue));
end;
//処理結果を返り値にセット
Result:=Dest.ToString;
finally
Password.Free;
Dest.Free;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Ini: TIniFile;
strID, strX, strY, strWaitTime: String;
i:integer;
begin
//Formを最大化して表示
Form1.WindowState:=wsMaximized;
//待ち時間の選択肢（100～3000ミリ秒を100ミリ秒単位で用意）
for i := 1 to 30 do
begin
cmbWaitTime.Items.Add(IntToStr(i*100));
end;
//iniファイルの存在を確認
if FileExists(ChangeFileExt(Application.ExeName, '.ini')) then
begin
//iniファイルからデータを読込み
Ini := TIniFile.Create(ChangeFileExt(Application.ExeName, '.ini'));
try
strID:=Ini.ReadString('Section', 'ID', '');
strX:=Ini.ReadString('Section', 'IchiX', '580');
strY:=Ini.ReadString('Section', 'IchiY', '420');
strWaitTime:=Ini.ReadString('Section', 'WaitTime', '500');
finally
Ini.Free;
end;
//復号して表示
Edit1.Text:=EDText(strID, IntToStr(HashOf('XXXXXXXX')), False);
EditX.Text:=strX;
EditY.Text:=strY;
cmbWaitTime.Text:=strWaitTime;
end;
//Navigate
EdgeBrowser1.Navigate('https://onedrive.live.com/about/ja-jp/signin/');
end;
（４）カーソル位置の座標を取得
マウスのカーソルが現在置かれている位置のスクリーン座標を取得してLabelに表示。
procedure TForm1.chkZahyoClick(Sender: TObject);
begin
if chkZahyo.Checked then
begin
//Enabled
Timer1.Enabled:=True;
end else begin
//Enabled
Timer1.Enabled:=False;
LabelXY.Caption:='[X座標, Y座標]';
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Ini: TIniFile;
strID, strX, strY, strWaitTime: String;
i:integer;
dllFileName:string;
begin
//リソースからDLLを（なければ）生成
//rijnファイルの位置を指定
dllFileName:=ExtractFilePath(Application.ExeName)+'WebView2Loader.dll';
//rijnファイルの存在を確認
if not FileExists(dllFilename) then
begin
//リソースを再生
with TResourceStream.Create(hInstance, 'Resource_1', RT_RCDATA) do
begin
try
SaveToFile(dllFileName);
finally
Free;
end;
end;
end;
･･･
end;
procedure TForm1.chkInfoClick(Sender: TObject);
var
strInfo:string;
strWidth:integer;
begin
if chkInfo.Checked then
begin
//表示する文字列
strInfo:='ID（メールアドレス）が自動入力されないときは、Ctrl＋V で入力できます！';
strWidth:=StatusBar1.Canvas.TextWidth(strInfo);
btnOK.Visible:=True;
with btnOK do
begin
Parent:=StatusBar1;
Left:=strWidth-20;
Top:=1;
end;
//StatusBar1の設定（重要：このプロパティがFalseだとStatusBarにテキストが表示されない）
StatusBar1.SimplePanel:=True;
//Info
StatusBar1.SimpleText:=strInfo;
end else begin
StatusBar1.SimpleText:='';
btnOK.Visible:=False;
end;
end;
案内を「表示する」が選ばれていた場合はFormCreate時に案内表示を出すよう設定。
procedure TForm1.FormCreate(Sender: TObject);
var
Ini: TIniFile;
strID, strX, strY, strWaitTime: String;
i:integer;
dllFileName:string;
strWidth:Integer;
strInfo:string;
boolInfo:boolean;
begin
if chkInfo.Checked then
begin
//表示する文字列
strInfo:='ID（メールアドレス）が自動入力されないときは、Ctrl＋V で入力できます！';
strWidth:=StatusBar1.Canvas.TextWidth(strInfo);
with btnOK do
begin
Parent:=StatusBar1;
Left:=strWidth-20;
Top:=1;
end;
//StatusBar1の設定（重要：このプロパティがFalseだとStatusBarにテキストが表示されない）
StatusBar1.SimplePanel:=True;
//Info
StatusBar1.SimpleText:=strInfo;
end;
･･･
//iniファイルの存在を確認
if FileExists(ChangeFileExt(Application.ExeName, '.ini')) then
begin
//iniファイルからデータを読込み
Ini := TIniFile.Create(ChangeFileExt(Application.ExeName, '.ini'));
try
strID:=Ini.ReadString('Section', 'ID', '');
strX:=Ini.ReadString('Section', 'IchiX', '580');
strY:=Ini.ReadString('Section', 'IchiY', '420');
strWaitTime:=Ini.ReadString('Section', 'WaitTime', '500');
boolInfo:=Ini.ReadBool('Section','Info',True);
finally
Ini.Free;
end;
//復号して表示
Edit1.Text:=EDText(strID, IntToStr(HashOf('adminy')), False);
EditX.Text:=strX;
EditY.Text:=strY;
cmbWaitTime.Text:=strWaitTime;
chkInfo.Checked:=boolInfo;
end;
･･･
end;
案内そのものを表示したくない場合は、ユーザーの自由意思でその設定も可能に。
procedure TForm1.btnSaveClick(Sender: TObject);
var
strID:string;
Ini:TIniFile;
begin
//入力の有無をCheck
･･･
//暗号化
strID:=EDText(Edit1.Text, IntToStr(HashOf('adminy')), True);
//iniファイルに保存
Ini := TIniFile.Create(ChangeFileExt(Application.ExeName, '.ini'));
try
//保存
Ini.WriteString('Section', 'ID', strID);
Ini.WriteString('Section', 'IchiX', EditX.Text);
Ini.WriteString('Section', 'IchiY', EditY.Text);
Ini.WriteString('Section', 'WaitTime', cmbWaitTime.Text);
Ini.WriteBool('Section','Info',chkInfo.Checked);
//Userに通知
MessageDlg('現在の設定を保存しました！', mtInformation, [mbOk] , 0);
if not btnCopy.Enabled then btnCopy.Enabled:=True;
finally
Ini.Free;
end;
end;
WebView4Delphi is an open source project created by Salvador Díaz Fau to embed Chromium-based browsers in applications made with Delphi or Lazarus/FPC for Windows.
function TMiniBrowserFrm.WaitTime(const t: integer): Boolean;
var
Timeout: TDateTime;
begin
//待ち関数 指定カウントが経過すれば True, 中断されたならば False
fgWaitBreak := False;
Timeout := Now + t/24/3600/1000;
while (Now < Timeout)and not fgWaitBreak do begin
Application.ProcessMessages;
Sleep(1);
end;
Result := not fgWaitBreak;
end;
procedure NetErrorProc(err: DWORD);
var
s: String;
begin
case err of
ERROR_ACCESS_DENIED: s := ERR_ACCESS_DENIED;
ERROR_ALREADY_ASSIGNED: s := ERR_ALREADY_ASSIGNED;
ERROR_BAD_DEV_TYPE: s := ERR_BAD_DEV_TYPE;
ERROR_BAD_NET_NAME: s := ERR_BAD_NET_NAME;
ERROR_BAD_PROFILE: s := ERR_BAD_PROFILE;
ERROR_BAD_PROVIDER: s := ERR_BAD_PROVIDER;
ERROR_BUSY: s := ERR_BUSY;
ERROR_CANCELLED: s := ERR_CANCELLED;
ERROR_CANNOT_OPEN_PROFILE: s := ERR_CANNOT_OPEN_PROFILE;
ERROR_DEVICE_ALREADY_REMEMBERED: s := ERR_DEVICE_ALREADY_REMEMBERED;
ERROR_EXTENDED_ERROR: s := ERR_EXTENDED_ERROR;
ERROR_INVALID_PASSWORD: s := ERR_INVALID_PASSWORD;
ERROR_NO_NET_OR_BAD_PATH: s := ERR_NO_NET_OR_BAD_PATH;
ERROR_NO_NETWORK: s := ERR_NO_NETWORK;
//次の行はエラーメッセージから調べて追加
53: s := ERROR_BAD_NETPATH;
1200: s := ERROR_BAD_DEVICE;
2202: s := NERR_BadUsername;
else
s := IntToStr(err);
end;
MessageDlg(s, mtError, [mbOk], 0);
end;
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;
