{ --▽---------------------------▼-- 汎用共通処理関数ユニット 2003/09/16 BooleanToStr PressKeyCodeなど作成 2003/10/12 AppIniFilePathを追加 2003/10/20 OutputLogFile OutputLogMemo を追加 2003/10/28 ByteToStrを追加 2003/11/10 EasyCreateProcessを追加 2003/11/10 GetFilterExtを追加 2003/12/21 ・ AppMsgBox/ApiMsgBoxを追加 ・ EasyCreateProcessにShowオプションをつけた 若干実装が不完全っぽい 2004/03/05 ・ FontToStr2/StrToFont2を実装した 2005/04/10 ・ AppFolderPathを追加 2005/04/21 ・ AppFolderPathに引数を追加 2005/04/23 ・ EasyCreateProcessにCurrentDirectory指定機能をつけた Exeを指定する呼び出しは成功するが普通にCommandLine指定では うまく動かないみたいだね。 2007/07/20 ・CheckRangeをMathUnitに移動させた 2007/08/01 ・CreateProcess系をCreateProcessUnitに移動 2010/02/26(金) ・IntToStrDigitとIntToStrSpaceを実装した 2010/11/24 ・OrValue/AndValueを実装 ・BenchmarkProcedureを実装 ・TProcessItemなどのProcessList系の処理をProcessListUnitに移動した 2010/11/25(木) ・DebugPrintNotepad/DebugPrintEmEditor /OutputLogText/OutputLogFile/OutputLogMemoをDebugLogUnitに移動 ・IntToStrDigitなど変換処理をConvertToTypeUnitに移動した。 2011/06/10(金) ・DelimitedTextUnit>>StringSplitterUnit //--▲---------------------------△-- } unit SystemUnit; interface uses Forms, Contnrs, SysUtils, Windows, Controls, Classes, Dialogs, Graphics, Typinfo, uses_end; function PressKeyCode(const VirtualKey: Integer): Boolean; function ScreenSaverOn: Boolean; function ScreenSaverRunning: boolean; function GetFilterExt(FilterIndex: Integer; Dlg: TOpenDialog): String; //procedure testGetFilterExt; function AppMsgBox(Text, Caption: String; Flags: Longint): Integer; function ApiMsgBox(hwnd: HWND; Text, Caption: String; Flags: Longint): Integer; procedure AllControlEnabled(Parent: TWinControl; Value: Boolean); procedure AllCompornentEnabled(Parent: TComponent; Value: Boolean); procedure AllDoubleBufferd(Parent: TWinControl); procedure AllControlFontColor(Parent: TWinControl; Value: TColor); function BenchmarkProcedure(proc: TProcedure): Double; function OrValue(Value: Variant; Compares: array of Variant): Boolean; overload; function OrValue(Value: Integer; Compares: array of Integer): Boolean; overload; function AndValue(Value: Variant; Compares: array of Variant): Boolean; implementation uses StringSplitterUnit, StringUnit, ProcessListUnit, end_uses; {------------------------------- // キーを押しているかどうかを判定する 備考: 履歴: 2003/09/15 //--▼----------------------▽--} function PressKeyCode(const VirtualKey: Integer): Boolean; begin if ((GetAsyncKeyState( VirtualKey ) and $8000) = 0) then Result := False else Result := True; end; { ----------------------------------- procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if PressKeyCode(VK_CONTROL) then Label1.Caption := 'Ctrlキーを押している' else Label1.Caption := 'Ctrlキーを押していない'; if PressKeyCode(VK_SHIFT) then Label2.Caption := 'Shiftキーを押している' else Label2.Caption := 'Shiftキーを押していない'; end; //----------------------------------- } //--△----------------------▲-- {------------------------------- // スクリーンセーバーが起動中かどうかを調べる 機能: 引数説明: 備考: ScreenSaverOnはWin9x系しか動作しないそうな。 使う価値ないですな。 ScreenSaverRunningはWin2kで動作確認。 履歴: 2003/09/17 //--▼----------------------▽--} function ScreenSaverOn: Boolean; var ProcessList: TObjectList; i: Integer; begin Result := False; ProcessList := TObjectList.Create; try GetProcExeNameList(ProcessList); for i := 0 to ProcessList.Count-1 do begin if SameText(ExtractFileExt(TProcessItem(ProcessList.Items[i]).Path) , '.scr') then begin Result := True; end; end; finally ProcessList.Free; end; end; function ScreenSaverRunning: boolean; const SPI_GETSCREENSAVERRUNNING = 114; var VI: TOSVersionInfo; Running: integer; hDesktop: HDESK; begin Result := False; FillChar(VI, SizeOf(VI), 0); VI.dwOSVersionInfoSize := SizeOf(VI); if not GetVersionEx(VI) then exit; if (VI.dwPlatformid = 1) and (VI.dwMinorVersion > 0) or (VI.dwPlatformid = 2) and (VI.dwMajorVersion >= 5) or (VI.dwPlatformid > 2) then begin // Windows 98 or greater, or Windows NT 5 or greater SystemParametersInfo(SPI_GETSCREENSAVERRUNNING, 0, @Running, 0); Result := Running <> 0; end else if (VI.dwPlatformid = 2) and (VI.dwMajorVersion < 5) then begin // Windows NT 3 or Windows NT 4 // We try to open the desktop "screen-saver" hDesktop := OpenDesktop('screen-saver', 0, False, MAXIMUM_ALLOWED); if hDesktop = 0 then // Couldn't open the desktop. Let's see the cause... if GetLastError() = ERROR_ACCESS_DENIED then // If access was denied, this means the screensaver has the // desktop and therefore it is running. Result := True else // If it's for any other reason, the screensaver isn't running Result := False else begin // We could open the desktop ==> screensaver running CloseDesktop(hDesktop); // We should close the desktop Result := True; end; end; end; //--△----------------------▲-- {------------------------------- // GetFilterExt 機能: DialogのFiltersプロパティから拡張子を取り出す 引数説明: FilterIndex: フィルタ番号(0から始まる) Dlg: 対象のダイアログ 戻り値: "*.PAS"などの拡張子 FilterIndexが見付からない場合ヌル文字を返す 大文字小文字も反映される 備考: Filterプロパティの値が 『Text files (*.txt)|*.TXT|Pascal files (*.pas)|*.PAS』の時 FilterIndex=1を指定すると *.PASを取得できる 履歴: 2001/09/06 2003/11/10 WordDecomposeで実装しなおし 2010/06/10 TWordSplitedに変更 //--▼----------------------▽--} //function GetFilterExt(FilterIndex: Integer; Dlg: TOpenDialog): String; //var // WordDecompose1: TWordDecompose; //begin // Result := ''; // WordDecompose1 := TWordDecompose.Create('|', Dlg.Filter, dmDelimiterExactly); // try // if (0 <= FilterIndex) and ((FilterIndex*2+1) <= WordDecompose1.Count) then // begin // //0→1 1→3 2→5 // Result := WordDecompose1.Words[FilterIndex*2+1]; // end; // finally // WordDecompose1.Free; // end; //end; function GetFilterExt(FilterIndex: Integer; Dlg: TOpenDialog): String; var WordSplited1: TStringSplitter; begin Result := ''; WordSplited1 := TStringSplitter.Create(Dlg.Filter, ['|'], dmDelimiterExactly); try if (0 <= FilterIndex) and ((FilterIndex*2+1) <= WordSplited1.Count) then begin //0→1 1→3 2→5 Result := WordSplited1.Words[FilterIndex*2+1]; end; finally WordSplited1.Free; end; end; //procedure testGetFilterExt; //var // SD: TSaveDialog; //begin // SD := TSaveDialog.Create(nil); // with SD do // try // Filter := 'データ(*.dat)|*.dat|'+ // 'テキスト*.txt|*.txt|'+ // 'Text files (*.txt)|*.TXT|'+ // 'Pascal files (*.pas)|*.PAS|'+ // 'ALL (*.*)|*.*'; // // Check('', GetFilterExt(-1, SD)); // Check('*.dat', GetFilterExt(0, SD)); // Check('*.txt', GetFilterExt(1, SD)); // Check('*.TXT', GetFilterExt(2, SD)); // Check('*.PAS', GetFilterExt(3, SD)); // Check('*.*' , GetFilterExt(4, SD)); // Check('', GetFilterExt(5,SD)); // // finally // Free; // end; //end; //--△----------------------▲-- {--------------------------------------- Application.MessageBox と Windows.MessageBoxをラッピング 機能: PCharで指定するところをStringにしてるだけ。 備考: Messageのオプションは次の通り ボタンのフラグ MB_ABORTRETRYIGNORE [中止]、[再試行]、[無視] MB_OK [OK] MB_OKCANCEL [OK]、[キャンセル] MB_RETRYCANCEL [再試行]、[キャンセル] MB_YESNO [はい]、[いいえ] MB_YESNOCANCEL [はい]、[いいえ]、[キャンセル] アイコンのフラグ MB_ICONEXCLAMATION (= MB_ICONWARNING) 黄色三角形の中に黒で感嘆符「！」 MB_ICONINFORMATION (= MB_ICONASTERISK) 吹き出しの中に青で小文字の「 i 」 MB_ICONQUESTION 吹き出しの中に青で疑問符「？」 MB_ICONSTOP (= MB_ICONERROR = MB_ICONHAND) 赤丸に白で「×」 デフォルトプッシュボタン MB_DEFBUTTON1 最初のボタン MB_DEFBUTTON2 2 番目のボタン MB_DEFBUTTON3 3 番目のボタン MB_DEFBUTTON4 4 番目のボタン 戻り値 IDOK 1 ［OK］ IDCANCEL 2 ［キャンセル］ IDABORT 3 ［中止］ IDRETRY 4 ［再試行］ IDIGNORE 5 ［無視］ IDYES 6 ［はい］ IDNO 7 ［いいえ］ 例 if Application.MessageBox( '確認してください', '確認ダイアログ', MB_OKCANCEL or MB_DEFBUTTON1) = IDOK then 他にも設定はありますが、実用的なものは上記のとおりです。 APIのMessageBoxのマニュアルは MSDNが参考になります。 http://www.microsoft.com/JAPAN/developer/library/jpuipf/_win32_messagebox.htm http://www.microsoft.com/JAPAN/developer/library/vcmfc/_mfc_message.2d.box_styles.htm 注意 if Application.MessageBox( '確認してください', '確認ダイアログ', MB_OK or MB_DEFBUTTON1 or MB_ICONINFORMATION) = IDOK then ボタンが1つしかない、この場合、ダイアログを閉じるボタンで閉じても OKが押された事になるので、条件判断につかえません。 注意してください。 履歴: 2002/03/09 ・ 作成 2002/06/07 ・ Windows.MessageBoxのコードも追加しました。 Applicationを使わないCUIアプリ等で使いましょう 2004/11/06 ・ ApiMsgBoxにハンドル指定引数を追加した }//(*----------------------------------- function AppMsgBox(Text, Caption: String; Flags: Longint): Integer; begin Result := Application.MessageBox(PChar(Text), PChar(Caption), Flags); end; function ApiMsgBox(hwnd: HWND; Text, Caption: String; Flags: Longint): Integer; begin Result := Windows.MessageBox(hwnd, PChar(Text), PChar(Caption), Flags); end; //------------------------------------*) {------------------------------- // 全ての子コントロールのEnabledを制御する 備考: 履歴: 2004/09/05 //--▼----------------------▽--} procedure AllControlEnabled(Parent: TWinControl; Value: Boolean); var i: Integer; begin for i := 0 to Parent.ControlCount-1 do begin if (Parent.Controls[i] is TWinControl) then begin Parent.Controls[i].Enabled := Value; AllControlEnabled( TWinControl(Parent.Controls[i]), Value ); end else begin Parent.Controls[i].Enabled := Value; end; end; end; procedure AllCompornentEnabled(Parent: TComponent; Value: Boolean); var i: Integer; begin for i := 0 to Parent.ComponentCount-1 do if (Parent.Components[i] is TControl) then (Parent.Components[i] as TControl).Enabled := Value; end; procedure AllDoubleBufferd(Parent: TWinControl); var i: Integer; begin for i := 0 to Parent.ComponentCount-1 do if (Parent.Components[i] is TWinControl) then (Parent.Components[i] as TWinControl).DoubleBuffered := true; end; type TControlPrivateAccess = class(TControl); procedure AllControlFontColor(Parent: TWinControl; Value: TColor); var i: Integer; begin for i := 0 to Parent.ComponentCount-1 do if (Parent.Components[i] is TWinControl) then TControlPrivateAccess(Parent.Components[i]).Font.Color := Value; end; //--△----------------------▲-- //処理時間を秒単位で返します function BenchmarkProcedure(proc: TProcedure): Double; var Frequency, CountStart, CountEnd: Int64; begin QueryPerformanceFrequency(Frequency); QueryPerformanceCounter(CountStart); proc; QueryPerformanceCounter(CountEnd); Result := (CountEnd - CountStart) / Frequency; end; {--------------------------------------- 値を比較する関数 OrValue/AndValue 機能: 備考: 履歴: 2012/06/04(月) ・ 作成済み }//(*----------------------------------- function OrValue(Value: Variant; Compares: array of Variant): Boolean; var I: Integer; begin Result := False; for I := 0 to Length(Compares) - 1 do begin if Value = Compares[I] then begin Result := True; Exit; end; end; end; function OrValue(Value: Integer; Compares: array of Integer): Boolean; var I: Integer; begin Result := False; for I := 0 to Length(Compares) - 1 do begin if Value = Compares[I] then begin Result := True; Exit; end; end; end; function AndValue(Value: Variant; Compares: array of Variant): Boolean; var I: Integer; begin Result := True; for I := 0 to Length(Compares) - 1 do begin if Value <> Compares[I] then begin Result := False; Exit; end; end; end; //------------------------------------*) end.