{ ----------------------------------- 汎用共通処理関数ユニット 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指定では うまく動かないみたいだね。 //----------------------------------- } unit SystemUnit; interface uses Forms, Contnrs, IniFiles, SysUtils, Windows, TLHelp32, PsApi, Messages, Controls, Classes, WordDecompose, Dialogs, Types, StdCtrls, Graphics, Typinfo, MathUnit, FileUnit, XPtest; function AppFolderPath(LastPathDelim: Boolean = False): String; function AppIniFilePath: String; function AppLogFilePath: String; function AppDatFilePath: String; function AppDateLogFilePath: String; function BooleanToStr(Value: Boolean): String; overload; procedure WriteBoolStr(Ini: TCustomIniFile; Section, Ident:String; Value: Boolean); function ReadBoolStr(Ini: TCustomIniFile; Section, Ident: String; Default: Boolean): Boolean; procedure WriteQuoteStr(Ini: TCustomIniFile; Section, Ident:String; Value: String); function ReadQuoteStr(Ini: TCustomIniFile; Section, Ident: String; Default: String): String; function PressKeyCode(const VirtualKey: Integer): Boolean; procedure DebugPrintNotepad( S:string ); procedure DebugPrintEmEditor( S:string ); type TProcessItem = class(TPersistent) public ID: Cardinal; Name: String; Path: String; Handle: THandle; ThreadCount: DWORD; ParentProcessID: DWORD; PriClassBase: Longint; {↓PsAPI.pas/_PROCESS_MEMORY_COUNTERSから引用} PageFaultCount: DWORD; //ページフォルト PeakWorkingSetSize: DWORD; //最大メモリ使用量 WorkingSetSize: DWORD; //メモリ使用量 QuotaPeakPagedPoolUsage: DWORD; //最大ページプール QuotaPagedPoolUsage: DWORD; //ページプール QuotaPeakNonPagedPoolUsage: DWORD; //最大非ページプール QuotaNonPagedPoolUsage: DWORD; //非ページプール PagefileUsage: DWORD; //ページファイル PeakPagefileUsage: DWORD; //最大ページファイル //↓データが取得できないのでコメントアウトしておく // dwSize: DWORD; // UsageCount: DWORD; // DefaultHeapID: DWORD; // ModuleID: DWORD; // dwFlags: DWORD; // ProcessHandle: THandle; procedure Assign(Source: TProcessItem); overload; end; function GetWindowsDirectory: string; procedure GetProcExeNameList(Dest: TObjectList); procedure ProcessTerminate(ProcessID: DWORD); function GetProcessID(ExeFullPath: String): Integer; function ProcessExist(ExeFullPath: String): Boolean; function ScreenSaverOn: Boolean; function ScreenSaverRunning: boolean; type TLogWritePosition = (lwpLastAddWrite, lwpFirstInsertWrite); function OutputLogText(const LogText: String; OutputText: String; LogLineCount: Integer; WritePos: TLogWritePosition): String; procedure OutputLogFile(const FileNameFullPath: String; OutputText: String; LogLineCount: Integer; WritePos: TLogWritePosition); procedure OutputLogMemo(const Memo: TMemo; OutputText: String; LogLineCount: Integer; WritePos: TLogWritePosition); type TByteFormat = (bfComma, bfByteToKilo, bfByteToMega, bfByteToGiga, bfKiloToByte, bfKiloToMega, bfKiloToGiga, bfMegaToByte, bfMegaToKilo, bfMegaToGiga, bfGigaToByte, bfGigaToKilo, bfGigaToMega); TByteFormatDigit = 0..6; TByteFormatAdjust = (bfaRoundOff, bfaCeil); function ByteToStr(Value: Extended; Format: TByteFormat; Digit: TByteFormatDigit; Adjust: TByteFormatAdjust = bfaRoundOff): String; procedure EasyCreateProcess(ExeName: String; Argument: String = ''; CurrentDirectory: String = ''; Modal: Boolean = False; Show: Boolean = True); overload; procedure EasyCreateProcessCmd(CommandLine: String; Modal: Boolean = False; Show: Boolean = True); procedure testEasyCreateProcessCmd; 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; function IntToBin(x:Integer) : String; function Int64ToBin(x:Int64) : String; function BinToInt(s: ShortString): Integer; function BinToInt64(s: ShortString): Int64; function FontToStr2(Font: TFont): string; procedure StrToFont2(Font: TFont; val: string); procedure AllControlEnabled(Parent: TWinControl; Value: Boolean); procedure AllCompornentEnabled(Parent: TComponent; Value: Boolean); procedure AllDoubleBufferd(Parent: TWinControl); procedure AllControlFontColor(Parent: TWinControl; Value: TColor); function CheckRange(Min, Value, Max: Integer): Boolean; implementation uses StringRecordList, StringUnitHeavy, StringUnitLight; function AppFolderPath(LastPathDelim: Boolean = False): String; begin if LastPathDelim then begin Result := ExtractFilePath(ParamStr(0)); end else begin Result := ExtractFileDir(ParamStr(0)); end; end; function AppIniFilePath: String; begin Result := ChangeFileExt(ParamStr(0), '.ini'); end; function AppLogFilePath: String; begin Result := ChangeFileExt(ParamStr(0), '.log'); end; function AppDateLogFilePath: String; begin Result := ChangeFileExt( ExtractFilePath(ParamStr(0))+ FormatDateTime('YYYY-MM-DD', Now), '.log'); end; function AppDatFilePath: String; begin Result := ChangeFileExt(ParamStr(0), '.dat'); end; {------------------------------- // IniファイルにTrue/Falseの形式で Booleanを保存する為の関数 機能: WriteBoolStr(Ini, 'Section', 'Ident', True); ReadBoolStr(Ini, 'Section', 'Ident', False); このように書くと [Section] Ident=True このようにIniファイルに記述される 引数説明: TIniFileクラスと同等 備考: 履歴: 2003/09/06 //------------------------------} //気に食わないのでSysUtils.BoolToStrのデフォルト引数を変更する。 function BooleanToStr(Value: Boolean): String; overload; begin Result := SysUtils.BoolToStr(Value, True); end; procedure WriteBoolStr(Ini: TCustomIniFile; Section, Ident:String; Value: Boolean); begin Ini.WriteString(Section, Ident, BooleanToStr(Value)); end; function ReadBoolStr(Ini: TCustomIniFile; Section, Ident: String; Default: Boolean): Boolean; begin Result := StrToBoolDef( Ini.ReadString(Section, Ident, ''), Default); end; (*----------------------------------- procedure TForm1.Button1Click(Sender: TObject); var Ini: TMemIniFile; begin Ini := TMemIniFile.Create(AppIniFilePath); try WriteBoolStr(Ini, 'Section', 'Ident', True); finally Ini.UpdateFile; Ini.Free; end; end; procedure TForm1.Button2Click(Sender: TObject); var Ini: TMemIniFile; Value1: Boolean; begin Ini := TMemIniFile.Create(AppIniFilePath); try Value1 := ReadBoolStr(Ini, 'Section', 'Ident', False); finally Ini.UpdateFile; Ini.Free; end; Label1.Caption := BoolToStr(Value1) end; //-----------------------------------*) //------------------------------ {------------------------------- // IniファイルにStringを"ABC"の形式で 読み込みと書き込みを行う関数 機能: WriteQuoteStr(Ini, 'Section', 'Ident', s); ReadQuoteStr(Ini, 'Section', 'Ident', s); このように書くと [Section] Ident=True このようにIniファイルに記述される 引数説明: TIniFileクラスと同等 備考: 履歴: 2006/03/03 //------------------------------} procedure WriteQuoteStr(Ini: TCustomIniFile; Section, Ident:String; Value: String); begin Ini.WriteString(Section, Ident, AnsiQuotedStr(Value, '"')); end; function ReadQuoteStr(Ini: TCustomIniFile; Section, Ident: String; Default: String): String; begin Result := TrimChar( Ini.ReadString(Section, Ident, AnsiQuotedStr(Default, '"')), '"'); end; //------------------------------ {------------------------------- // キーを押しているかどうかを判定する 備考: 履歴: 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; //----------------------------------- } //------------------------------ {------------------------------- // 起動プロセスのフルパス一覧を得る関数 GetProcExeNameList 引数説明: Dest: Processの情報が出力されるリスト TProcessItemが格納される 備考: 参考: [Delphi:70691][Delphi:49296] http://msdn.microsoft.com/msdnmag/issues/02/06/debug/default.aspx 履歴: 2003/08/10 2005/01/24 プロセス毎のメモリ使用量(WorkingSet/Peak...)を 求められるようにした 参考 http://www.experts-exchange.com/Programming/Programming_Languages/Delphi/Q_20974300.html 2005/04/05 PageFaultCount/QuotaPagedPoolUsage/QuotaNonPagedPoolUsage/PagefileUsage などを取得できるようにした。 参考 http://nienie.com/~masapico/api_sample_ps05_c.html //------------------------------} { TProcessItem } procedure TProcessItem.Assign(Source: TProcessItem); begin // if Source is TProcessItem then begin Self.ID := TProcessItem(Source).ID; Self.Name := TProcessItem(Source).Name; Self.Path := TProcessItem(Source).Path; Self.Handle := TProcessItem(Source).Handle; Self.ThreadCount := TProcessItem(Source).ThreadCount; Self.ParentProcessID := TProcessItem(Source).ParentProcessID; Self.PriClassBase := TProcessItem(Source).PriClassBase; Self.PageFaultCount := TProcessItem(Source).PageFaultCount; Self.WorkingSetSize := TProcessItem(Source).WorkingSetSize; Self.PeakWorkingSetSize := TProcessItem(Source).PeakWorkingSetSize; Self.QuotaPeakPagedPoolUsage := TProcessItem(Source).QuotaPeakNonPagedPoolUsage; Self.QuotaPagedPoolUsage := TProcessItem(Source).QuotaPagedPoolUsage; Self.QuotaPeakNonPagedPoolUsage := TProcessItem(Source).QuotaPeakNonPagedPoolUsage; Self.QuotaNonPagedPoolUsage := TProcessItem(Source).QuotaNonPagedPoolUsage; Self.PagefileUsage := TProcessItem(Source).PagefileUsage; Self.PeakPagefileUsage := TProcessItem(Source).PeakPagefileUsage; end; end; //Windowsインストールファルダを調べる関数 function GetWindowsDirectory: string; var Buffer:array [0..MAX_PATH-1] of Char; begin Windows.GetWindowsDirectory(Buffer,MAX_PATH); Result:=StrPas(Buffer); end; { ----------------------------------- 変なパス名を変換する関数 参考:http://msdn.microsoft.com/msdnmag/issues/02/06/debug/default.aspx このページのdebug.exeを解凍して現れる .\debug\Common\Helpers.cpp の void TranslateFilename(LPCTSTR szFilename, LPTSTR szWin32Name) の機能と同じ //----------------------------------- } function TranslateFilename(SourceFileName: String): String; begin Result := SourceFileName; Result := StringReplace(Result, '\SystemRoot', GetWindowsDirectory, []); Result := StringReplace(Result, '\??\', '', []); end; procedure GetProcExeNameList(Dest: TObjectList); var hProcessSnapshot: THandle; ProcessEntry: TProcessEntry32; PID: Cardinal; ProcessStatus: Boolean; hProcess: THandle; ModuleFileName: array[0..MAX_PATH] of Char; Item: TProcessItem; psmemCounters: _PROCESS_MEMORY_COUNTERS; i: Integer; OwnsObjBuffer: Boolean; begin OwnsObjBuffer := Dest.OwnsObjects; Dest.OwnsObjects := False; for i := Dest.Count-1 downto 0 do begin Item := TProcessItem(Dest.Items[i]); FreeAndNil(Item); Dest.Delete(i); end; Dest.OwnsObjects := OwnsObjBuffer; hProcessSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); if hProcessSnapshot <> $FFFFFFFF then begin try {↓プロセスを列挙してループ} ProcessEntry.dwSize := sizeof(TProcessEntry32); ProcessStatus := Process32First(hProcessSnapshot, ProcessEntry); while ProcessStatus do begin PID := ProcessEntry.th32ProcessID; hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, PID); if hProcess <> 0 then try {↓プロセスのファイルパスを取得} Item := TProcessItem.Create; Item.ID := PID; //Item.ID := ProcessEntry.th32ProcessID; Item.Name := ProcessEntry.szExeFile; Item.Handle := hProcess; if GetModuleFileNameEx(hProcess, 0, ModuleFileName, Sizeof(ModuleFileName)) = 0 then begin Item.Path := '[System]'; end else begin Item.Path := TranslateFilename(ModuleFileName); end; Item.ThreadCount := ProcessEntry.cntThreads; Item.ParentProcessID := ProcessEntry.th32ParentProcessID; Item.PriClassBase := ProcessEntry.pcPriClassBase; psmemCounters.cb:=SizeOf(_PROCESS_MEMORY_COUNTERS); if GetProcessMemoryInfo(hProcess, @psmemCounters, SizeOf(_PROCESS_MEMORY_COUNTERS)) then begin Item.PageFaultCount := psmemCounters.PageFaultCount; Item.WorkingSetSize := psmemCounters.WorkingSetSize; Item.PeakWorkingSetSize := psmemCounters.PeakWorkingSetSize; Item.QuotaPeakPagedPoolUsage := psmemCounters.QuotaPeakNonPagedPoolUsage; Item.QuotaPagedPoolUsage := psmemCounters.QuotaPagedPoolUsage; Item.QuotaPeakNonPagedPoolUsage := psmemCounters.QuotaPeakNonPagedPoolUsage; Item.QuotaNonPagedPoolUsage := psmemCounters.QuotaNonPagedPoolUsage; Item.PagefileUsage := psmemCounters.PagefileUsage; Item.PeakPagefileUsage := psmemCounters.PeakPagefileUsage; end else begin Item.PageFaultCount := 0; Item.WorkingSetSize := 0; Item.PeakWorkingSetSize := 0; Item.QuotaPeakPagedPoolUsage := 0; Item.QuotaPagedPoolUsage := 0; Item.QuotaPeakNonPagedPoolUsage := 0; Item.QuotaNonPagedPoolUsage := 0; Item.PagefileUsage := 0; Item.PeakPagefileUsage := 0; end; Dest.Add(Item); finally CloseHandle(hProcess); end; ProcessStatus := Process32Next(hProcessSnapshot, ProcessEntry) end finally CloseHandle(hProcessSnapshot); end; end else raise Exception.Create(SysErrorMessage(GetLastError)); end; //------------------------------ {------------------------------- // プロセスを強制終了する関数 ProcessTerminate 引数説明: ProcessID:停止したいプロセスIDを指定する 備考: 参考: [Delphi:47838] Re: プログラムを強制終了する方法 履歴: 2005/03/30 作成 //------------------------------} procedure ProcessTerminate(ProcessID: DWORD); var hProcess: THandle; begin {↓プロセス強制終了} hProcess := OpenProcess(PROCESS_TERMINATE, False, ProcessID); TerminateProcess(hProcess , 0 ); CloseHandle(hProcess); end; //------------------------------ {------------------------------- // ExeのパスからProcessIDを求める関数 備考: プロセスが無い場合は-1が返る 複数のProcessがある場合でも先に見つかった ProcessIDを返す 履歴: 2005/10/12 2006/12/21(木) ファイル名をSameFile関数で比較することにした //------------------------------} function GetProcessID(ExeFullPath: String): Integer; var i: Integer; ProcessList: TObjectList; begin Result := -1; {↓プロセス終了コード} ProcessList := TObjectList.Create; try GetProcExeNameList(ProcessList); for i := 0 to ProcessList.Count - 1 do begin if SameFileName(TProcessItem(ProcessList.Items[i]).Path, ExeFullPath) then begin Result := TProcessItem(ProcessList.Items[i]).ID; break; end; end; finally ProcessList.Free; end; end; //------------------------------ {------------------------------- // ExeのパスからProcessの存在をみつける関数 機能: GetProcessIDをそのまま利用 備考: この関数を利用して次のような記述が可能 var Timer: TDateTime; //↓プロセスが起動している間、待つ関数 Timer := Now; while ProcessExist('C:\WINDOWS\system32\notepad.exe') do begin Application.ProcessMessages; if 10<=SecondSpan(Now, Timer) then Exit; //↑ループが10秒以上経過したら関数を抜ける処理 end; 履歴: 2006/12/21(木) 12:01 //------------------------------} function ProcessExist(ExeFullPath: String): Boolean; begin if GetProcessID(ExeFullPath) = -1 then begin Result := False; end else begin Result := True; end; 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; //------------------------------ {------------------------------- // ログをファイルに出力する関数 OutputLogFile ログをTMemoに出力する関数 OutputLogMemo ログを文字列として出力する(内部的な関数) OutputLogText 機能: 引数説明: type TLogWritePosition = (lwpLastAddWrite, lwpFirstInsertWrite); 書き込み位置 lwpLastAddWrite 最後に追加 lwpFirstInsertWrite 最初に挿入 OutputTextには改行コードありのものでも許可されますが LogLineCountの行数は純粋に改行コードにしたがって計算されます 備考: uses StringRecordList, StringUnitHeavy, StringUnitLight, Types; が必要 履歴: 2003/10/20 2004/11/20 OutputLogFileの内部処理を OutputLogTextとして別関数にした 2007/06/01 OutputLogFileにフォルダ存在確認コードをいれた //------------------------------} function OutputLogText(const LogText: String; OutputText: String; LogLineCount: Integer; WritePos: TLogWritePosition): String; var StrRecList: TStringRecordList; begin Result := ''; StrRecList := TStringRecordList.Create; try StrRecList.Text := LogText; if LastLineBreakStyle(OutputText) = lbsNoLineBreaks then OutputText := OutputText + CRLF; case WritePos of lwpLastAddWrite: begin if StrRecList.Count = 0 then begin StrRecList.Add( OutputText ); end else if LastLineBreakStyle(StrRecList.Text) = lbsNoLineBreaks then begin StrRecList.Add( CRLF + OutputText); end else begin StrRecList.Add( OutputText ); end; end; lwpFirstInsertWrite: begin StrRecList.Insert(0, OutputText); end; end; StrRecList.Text := StrRecList.Text; if (LogLineCount) <= StrRecList.Count then begin while (LogLineCount) < StrRecList.Count do begin case WritePos of lwpLastAddWrite: StrRecList.Delete(0); lwpFirstInsertWrite: StrRecList.Delete(StrRecList.Count-1); end; end; end; Result := StrRecList.Text; finally StrRecList.Free; end; end; procedure OutputLogFile(const FileNameFullPath: String; OutputText: String; LogLineCount: Integer; WritePos: TLogWritePosition); begin if not DirectoryExists(ExtractFileDir(FileNameFullPath)) then begin ForceDirectories(ExtractFileDir(FileNameFullPath)); //raise Exception.Create('ログフォルダがありません'); end; if FileExists(FileNameFullPath) then begin SaveStringToFile(FileNameFullPath, OutputLogText(LoadStringFromFile(FileNameFullPath), OutputText, LogLineCount, WritePos) ); end else begin SaveStringToFile(FileNameFullPath, OutputLogText('', OutputText, LogLineCount, WritePos) ); end; end; (*----------------------------------- //OutputLogTextを実装したのでコメントアウト procedure OutputLogFile(const FileName: String; OutputText: String; LogLineCount: Integer; WritePos: TLogWritePosition); var StrRecList: TStringRecordList; begin StrRecList := TStringRecordList.Create; try if FileExists(FileName) then begin StrRecList.Text := LoadStringFromFile(FileName); end; if LastLineBreaksStyle(OutputText) = lbsNoLineBreaks then OutputText := OutputText + CR+LF; case WritePos of lwpLastAddWrite: begin if StrRecList.Count = 0 then begin StrRecList.Add( OutputText ); end else if LastLineBreaksStyle(StrRecList.Text) = lbsNoLineBreaks then begin StrRecList.Add( #13#10 + OutputText); end else begin StrRecList.Add( OutputText ); end; end; lwpFirstInsertWrite: begin StrRecList.Insert(0, OutputText); end; end; StrRecList.Text := StrRecList.Text; if (LogLineCount) <= StrRecList.Count then begin while (LogLineCount) < StrRecList.Count do begin case WritePos of lwpLastAddWrite: StrRecList.Delete(0); lwpFirstInsertWrite: StrRecList.Delete(StrRecList.Count-1); end; end; end; SaveStringToFile(FileName, StrRecList.Text); finally StrRecList.Free; end; end; //-----------------------------------*) procedure OutputLogMemo(const Memo: TMemo; OutputText: String; LogLineCount: Integer; WritePos: TLogWritePosition); begin Memo.Lines.BeginUpdate; try case LastLineBreakStyle(OutputText) of lbsNoLineBreaks:; lbsCRLF : SetLength(OutputText, Length(OutputText)-2); lbsCR, lbsLF: SetLength(OutputText, Length(OutputText)-1); end; case WritePos of lwpLastAddWrite: Memo.Lines.Add(OutputText); lwpFirstInsertWrite: Memo.Lines.Insert(0, OutputText); end; if (LogLineCount) <= Memo.Lines.Count then begin while (LogLineCount) < Memo.Lines.Count do begin case WritePos of lwpLastAddWrite: Memo.Lines.Delete(0); lwpFirstInsertWrite: Memo.Lines.Delete(Memo.Lines.Count-1); end; end; end; finally Memo.Lines.EndUpdate; end; end; {↓以下のようなやり方でテスト動作を確認しました} //procedure TForm1.OutputLog(LineStr: String); //const LogCount = 30; //begin // if CheckBox1.Checked then // begin // OutputLogFile(ChangeFileExt(Application.ExeName, '.log'), // LineStr, LogCount, lwpFirstUpWrite); // OutputLogMemo(Memo1, LineStr, LogCount, lwpFirstUpWrite); // end else // begin // OutputLogFile(ChangeFileExt(Application.ExeName, '.log'), // LineStr, LogCount, lwpLastDownWrite); // OutputLogMemo(Memo1, LineStr, LogCount, lwpLastDownWrite); // end; //end; // //procedure TForm1.Button1Click(Sender: TObject); //begin // OutputLog(FormatDateTime('hh:mm:ss.zzz', Now) + ' ログ'); //end; // //procedure TForm1.Button2Click(Sender: TObject); //var // LogText: String; //begin // LogText := FormatDateTime('hh:mm:ss.zzz', Now) + #13#10 + // 'ログ' + #13#10 + // #13#10; // OutputLog( LogText ); //end; // //procedure TForm1.Button3Click(Sender: TObject); //var // LogText: String; //begin // LogText := FormatDateTime('hh:mm:ss.zzz', Now) + #13#10 + // 'ログ'; // OutputLog( LogText ); //end; //------------------------------ {------------------------------- // バイト数をキロやメガの単位にあわせて出力する 機能: カンマ区切りや小数点桁数を指定して 文字列としてバイト数を出力する 引数: TByteFormat = (bfComma, bfByteToKilo, bfByteToMega, bfByteToGiga bfKiloToByte, bfKiloToMega, bfKiloToGiga bfMegaToByte, bfMegaToKilo, bfMegaToGiga); 機能: bfComma:カンマ区切り Digit: TByteFormatDigit=0..6 0なら小数点以下なし 1なら小数点第一位、2なら…省略…になる。 履歴: 2003/09/28 作成 2003/10/28 キロ、メガ、ギガからの単位変換に対応 2004/08/18 小数点桁数を指定できるようにした 四捨五入か切上げかを選べるようにもした //------------------------------} function ByteToStr(Value: Extended; Format: TByteFormat; Digit: TByteFormatDigit; Adjust: TByteFormatAdjust = bfaRoundOff): String; var DigitFormatStr, FormatStr: String; ResultValue: Extended; AdjustFunction: Function(const X: Extended; DigitNumber: Integer): Extended; begin DigitFormatStr := ''; case Digit of 0: DigitFormatStr := '0'; 1: DigitFormatStr := '0.0'; 2: DigitFormatStr := '0.00'; 3: DigitFormatStr := '0.000'; 4: DigitFormatStr := '0.0000'; 5: DigitFormatStr := '0.00000'; 6: DigitFormatStr := '0.000000'; end; FormatStr := '#,##' + DigitFormatStr; if Adjust = bfaCeil then begin AdjustFunction := CeilEx; end else begin AdjustFunction := RoundOffEx; end; case Format of bfComma: begin Result := FormatFloat(FormatStr, Value); Exit; end; bfByteToKilo: begin ResultValue := AdjustFunction( Value/1024, -1*(Digit+1)); end; bfByteToMega: begin ResultValue := AdjustFunction( Value/(1024*1024), -1*(Digit+1)); end; bfByteToGiga: begin ResultValue := AdjustFunction( Value/(1024*1024*1024), -1*(Digit+1)); end; bfKiloToByte: begin ResultValue := AdjustFunction( Value*1024, -1*(Digit+1)); end; bfKiloToMega: begin ResultValue := AdjustFunction( Value/1024, -1*(Digit+1)); end; bfKiloToGiga: begin ResultValue := AdjustFunction( Value/(1024*1024), -1*(Digit+1)); end; bfMegaToByte: begin ResultValue := AdjustFunction( Value*1024*1024, -1*(Digit+1)); end; bfMegaToKilo: begin ResultValue := AdjustFunction( Value*1024, -1*(Digit+1)); end; bfMegaToGiga: begin ResultValue := AdjustFunction( Value/1024, -1*(Digit+1)); end; bfGigaToByte: begin ResultValue := AdjustFunction( Value*1024*1024*1024, -1*(Digit+1)); end; bfGigaToKilo: begin ResultValue := AdjustFunction( Value*1024*1024, -1*(Digit+1)); end; bfGigaToMega: begin ResultValue := AdjustFunction( Value*1024, -1*(Digit+1)); end; else Result := ''; Exit; end; Result := FormatFloat(FormatStr, ResultValue); end; //------------------------------ {------------------------------- // EasyCreateProcess 機能: CreateProcessを簡単に呼び出します 備考: コマンドラインを呼び出す場合、ExeやTargetFile指定するときに スペースを含むパスの場合は["]で囲む必要があるので、 関数内部でAnsiQuotedStrを使っています notepadを呼び出す時はExeNameに[notepad.exe]と指定しよう [notepad]と指定するとTargetFile指定が正しく受け付けてくれません 参考：[Delphi-ML:21800] Re: DOS の画面を表示させない方法 履歴: 2004/02/17 AnsiQuateStrでパスを囲った 2004/05/16 overloadしてコマンドラインを直接呼ぶ機能もつけた 2005/05/03 overloadはやめてCurrentDir指定引数を追加 2006/12/23(土) EasyCreateProcessCmdはファイル名を指定しただけでは 動かない気がする。 //------------------------------} procedure EasyCreateProcess(ExeName: String; Argument: String = ''; CurrentDirectory: String = ''; Modal: Boolean = False; Show: Boolean = True); overload; var si: TStartupInfo; pi: TProcessInformation; begin FillChar(si, Sizeof(TStartupInfo), 0); si.cb := Sizeof(TStartupInfo); if not Show then with si do begin cb := SizeOf(si); lpReserved := nil; lpDesktop := nil; lpTitle := nil; dwX := 0; dwY := 0; dwXSize := 0; dwYSize := 0; dwXCountChars := 0; dwYCountChars := 0; dwFillAttribute := 0; dwFlags:= STARTF_USESHOWWINDOW; // DOS プロンプトが表示 wShowWindow := SW_HIDE; // されるのを抑止する // dwFlags := STARTF_USESHOWWINDOW; // wShowWindow := SW_SHOWMINIMIZED or SW_HIDE; end; if FileFolderExists(Argument) then begin Argument := ' ' + AnsiQuotedStr(Argument, '"'); end else if not (Argument = '') then begin Argument := ' ' + Argument; end; if (CurrentDirectory = '') or (not DirectoryExists(CurrentDirectory)) then begin CreateProcess(nil, PChar(AnsiQuotedStr(ExeName, '"') + Argument), nil, nil, True, 0, nil, nil, si, pi); end else begin CreateProcess(nil, PChar(AnsiQuotedStr(ExeName, '"') + Argument), nil, nil, True, 0, nil, PChar(CurrentDirectory), si, pi); end; if Modal then WaitForSingleObject(pi.hProcess, INFINITE) {起動したプロセスが終了するのを待つ命令 待っている間は実行が停止する} end; procedure EasyCreateProcessCmd(CommandLine: String; Modal: Boolean = False; Show: Boolean = True); var si: TStartupInfo; pi: TProcessInformation; begin FillChar(si, Sizeof(TStartupInfo), 0); si.cb := Sizeof(TStartupInfo); if not Show then with si do begin cb := SizeOf(si); lpReserved := nil; lpDesktop := nil; lpTitle := nil; dwX := 0; dwY := 0; dwXSize := 0; dwYSize := 0; dwXCountChars := 0; dwYCountChars := 0; dwFillAttribute := 0; dwFlags:= STARTF_USESHOWWINDOW; // DOS プロンプトが表示 wShowWindow := SW_HIDE; // されるのを抑止する // dwFlags := STARTF_USESHOWWINDOW; // wShowWindow := SW_SHOWMINIMIZED or SW_HIDE; end; CreateProcess(nil, PChar(CommandLine), nil, nil, True, 0, nil, nil, si, pi); if Modal then WaitForSingleObject(pi.hProcess, INFINITE) {起動したプロセスが終了するのを待つ命令 待っている間は実行が停止する} end; procedure testEasyCreateProcessCmd; begin EasyCreateProcess('notepad'); EasyCreateProcess('C:\WINDOWS\system32\notepad.exe'); EasyCreateProcessCmd('C:\Program Files\Internet Explorer\IEXPLORE.EXE'); EasyCreateProcessCmd('C:\Program Files\Windows NT\Accessories\wordpad.exe'); 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で実装しなおし //------------------------------} //function GetFilterExt(FilterIndex: Integer; Dlg: TOpenDialog): String; //var // ReplaceStr: String; //begin // with TStringList.Create do // try // ReplaceStr := Dlg.Filter; // ReplaceStr := StringReplace(ReplaceStr, ' ', '', [rfReplaceAll]); // ReplaceStr := StringReplace(ReplaceStr, ',', '', [rfReplaceAll]); // ReplaceStr := StringReplace(ReplaceStr, '|', ',', [rfReplaceAll]); // CommaText := ReplaceStr; // if (0 <= FilterIndex) and ((FilterIndex*2+1)<=Count-1) then // begin // Result := Strings[FilterIndex*2+1]; // end; // finally // Free; // end; //end; 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; 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; //------------------------------ {------------------------------- // デバッグ出力をメモ帳やEmEditorに貼り付ける 備考: uses Messagesが必要 履歴: 2003/11/16 //------------------------------} var hwndNotepadEdit: HWND; {↑ユニット変数にする事で再検索の必要がなくなる} procedure DebugPrintNotepad( S:string ); var hwndNotepad: HWND; begin if not isWindow( hwndNotepadEdit ) then begin hwndNotepad := FindWindow( 'Notepad','無題 - メモ帳' ); hwndNotepadEdit := FindWindowEx( hwndNotepad,0,'Edit',nil ); end; if not isWindow( hwndNotepadEdit ) then exit; SendMessage( hwndNotepadEdit,EM_REPLACESEL,0,LPARAM( PChar( S+#13#10 ))); end; var hwndEmEditorView: HWND; procedure DebugPrintEmEditor( S:string ); var hwndEmEditor: HWND; begin if not isWindow( hwndEmEditorView ) then begin hwndEmEditor := FindWindow( 'EmEditorMainFrame3','無題 - EmEditor' ); hwndEmEditorView := FindWindowEx( hwndEmEditor,0,'EmEditorView',nil ); end; if not isWindow( hwndEmEditorView ) then begin hwndEmEditor := FindWindow( 'EmEditorMainFrame3','無題 * - EmEditor' ); hwndEmEditorView := FindWindowEx( hwndEmEditor,0,'EmEditorView',nil ); end; if not isWindow( hwndEmEditorView ) then exit; SendMessage( hwndEmEditorView,EM_REPLACESEL,0,LPARAM( PChar( S+#13#10 ))); end; //------------------------------ {------------------------------- //Application.MessageBoxと Windows.MessageBoxを使いやすくラッピングしてます 機能: PCharで指定するところを Stringにしてるだけです 履歴: 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; //------------------------------ {------------------------------- // IntToBin Int64ToBin 機能: Integerを二進数文字列として返します 戻り値: 必要分の固定桁数文字列 0000 0000 0000 0000 0000 0000 0000 0001 0000 0000 0000 0000 0000 0000 0000 0000 0000 0000 0000 0000 0000 0000 0000 0001 備考: IntToBinとInt64ToBinの内部処理は共通化可能だけど その場合Int64で処理しなければいけないので 遅くなりそうなので完全に別にしました。 参考: [Delphi-ML:32648] Re: 2進数への変換 履歴: 2001/06/27 //------------------------------} function IntToBin(x:Integer) : String; var i : Integer; const nbyte: Integer = 4; {↑Integerは符号付き32bitなので4byte} begin Result := StringOfChar(' ', (nbyte*10-1)); {←長さ10の文字列がnbyte個} for i:=nbyte*8 downto 1 do begin if ((x And 1) = 1) then Result[i+((i-1) shr 2)] := '1' else Result[i+((i-1) shr 2)] := '0'; x := x shr 1; end; end; function Int64ToBin(x:Int64) : String; var i : Integer; const nbyte: Integer = 8; {↑Int64は符号付き64bitなので4byte} begin Result := StringOfChar(' ', (nbyte*10-1)); for i:=nbyte*8 downto 1 do begin if ((x And 1) = 1) then Result[i+((i-1) shr 2)] := '1' else Result[i+((i-1) shr 2)] := '0'; x := x shr 1; end; end; //------------------------------ {------------------------------- // BinToInt BinToInt64 機能: 二進数文字列をIntegerとして返します 引数説明: 0,1,半角スペースで構成された2進数文字列 文字列の長さはBinToIntは32バイトまで BinToInt64なら64バイトまで IntToBinの出力値のように 4文字スペース区切りされていなくてもよい 例: BinToInt('10')=BinToInt('0010')=2 BinToInt('0 10 1')=BinToInt('0101')=5 備考: BinToIntとBinToInt64の内部処理は同一だけど 型が違うので別の関数にしました。 参考: [Delphi-ML:32992] Re: 2進数文字列 ->数値(BinToInt)変換 履歴: 2001/06/27 //------------------------------} function BinToInt(s: ShortString): Integer; var I, L: Integer; BinStr: ShortString; const nbyte: Integer = 4; {↑Integerは符号付き32bitなので4byte} begin Result := 0; BinStr := ''; for I := 1 to Length(s) do case S[i] of '0', '1': BinStr := BinStr + s[i]; ' ': ; else raise EConvertError.Create(s+' は二進数ではありません'); end; L := Length(BinStr); if (L < 1) or ((8*nbyte) < L) then raise EConvertError.Create(s+' は二進数ではありません'); for I := 1 to L do if BinStr[I] = '1' then Result := Result + (1 shl (L - I)); end; function BinToInt64(s: ShortString): Int64; var I, L: Integer; BinStr: ShortString; const nbyte: Integer = 8; {↑Int64は符号付き64bitなので8byte} begin Result := 0; BinStr := ''; for I := 1 to Length(s) do case S[i] of '0', '1': BinStr := BinStr + s[i]; ' ': ; else raise EConvertError.Create(s+' は二進数ではありません'); end; L := Length(BinStr); if (L < 1) or ((8*nbyte) < L) then raise EConvertError.Create(s+' は二進数ではありません'); for I := 1 to L do if BinStr[I] = '1' then Result := Result + (1 shl (L - I)); end; //------------------------------ {------------------------------- // FontToStr2 StrToFont2 機能: フォントのプロパティと文字列を相互変換する 対象プロパティはName,Color,Size,Pitch,style 備考: 実際の文字列は例えばこのようになります "ＭＳ Ｐゴシック",$80000008,9,0,"[fsBold,fsItalic]" Delphi5で対応です。 uses GraphicsとTypinfoが追加で必要 履歴: 2001/04/02 //------------------------------} function FontToStr2(Font: TFont): string; begin with Font do begin {↓(ColorをHEXにしたのは見やすいから)} Result := '"'+Name+ '",$'+IntToHex(Color,8)+','+IntToStr(Size) +','+IntToStr(Ord(Pitch))+','; {↑Pitchは列挙型なのでOrdで整数にする} Result := Result + '"'+ GetSetProp(Font, 'Style', True) + '"'; end; end; procedure StrToFont2(Font: TFont; val: string); var f: TFont; StyleStr: String; begin f := TFont.Create; try if WordCount(',', val, dmDelimiterExactly) = 5 then begin f.Name := TrimChar( WordGet(',', val, 0, dmDelimiterExactly), '"'); f.Color := StrToInt( WordGet(',', val, 1, dmDelimiterExactly) ); f.Size := StrToInt( WordGet(',', val, 2, dmDelimiterExactly) ); f.Pitch := TFontPitch( StrToInt( WordGet(',', val, 3, dmDelimiterExactly) ) ); StyleStr := TrimChar(WordGet(',', val, 4, dmDelimiterExactly), '"'); SetSetProp(f, 'Style', StyleStr); end else raise EConvertError.Create('フォントに変換できない文字列です'); Font.Assign(f); finally f.Free; end; end; //var // w: TStringList; // f: TFont; //begin // w := TStringList.Create; //カンマ区切りにしたのでTStringListで分解 // f := TFont.Create; // try // try // w.CommaText := val; // // {↓StringListの数が5でなければ例外発生} // if (w.Count=5) then // begin // f.Name := w[0]; // f.Color := StrToInt(w[1]); // f.Size := StrToInt(w[2]); // f.Pitch := TFontPitch(StrToInt(w[3])); // {↑Pitchは列挙型なのでTFontPitchでキャスト} // SetSetProp(f, 'Style', w[4]); // end else // raise Exception.Create(''); // // Font.Assign(f); // {↑問題がなければFontのパラメータを更新} // except // raise EConvertError.Create('フォントに変換できない文字列です'); // end; // // finally // w.free; // f.Free; // end; //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; //------------------------------ {------------------------------- // 数値が範囲内にあるかどうか調べる関数 備考: 履歴: 2005/11/23 //------------------------------} function CheckRange(Min, Value, Max: Integer): Boolean; begin if (Min <= Value) and (Value <= Max) then begin Result := True; end else begin Result := False; end; end; //------------------------------ end.