unit myDebug; { デバッグ用出力フォーム。 1000行までの履歴を表示。 2011-06-28: 　[Ctrl]+コピーで作業ファイルに保存したテキストを関連付けられているプログラムに渡 　して起動するようにした。 　[Shift]+コピーで選択行だけでなくリスト全部のテキストのコピー。 2009-12-08: 　一時停止を追加。 　このフォームにフォーカスがある場合に他のフォームのショートカットを無効化。 } interface uses Windows, Classes, ComCtrls, Controls, ExtCtrls, Forms, Graphics, Grids, Messages, MPlayer, StdCtrls, SysUtils, ActnList, Menus, Dialogs; type TMyDebug_Form = class(TForm) pnlCmd: TPanel; chkPause: TCheckBox; btnClear: TButton; btnWriteLog: TButton; btnClose: TButton; ActionList_Key: TActionList; actKey_Up: TAction; actKey_Down: TAction; actKey_Left: TAction; actKey_Right: TAction; actKey_PgUp: TAction; actKey_PgDn: TAction; actKey_BkSp: TAction; actKey_Del: TAction; actKey_Home: TAction; actKey_End: TAction; actKey_Esc: TAction; actKey_Space: TAction; actKey_A: TAction; actKey_B: TAction; actKey_C: TAction; actKey_D: TAction; actKey_E: TAction; actKey_F: TAction; actKey_G: TAction; actKey_H: TAction; actKey_I: TAction; actKey_J: TAction; actKey_K: TAction; actKey_L: TAction; actKey_M: TAction; actKey_N: TAction; actKey_O: TAction; actKey_P: TAction; actKey_Q: TAction; actKey_R: TAction; actKey_S: TAction; actKey_T: TAction; actKey_U: TAction; actKey_V: TAction; actKey_W: TAction; actKey_X: TAction; actKey_Y: TAction; actKey_Z: TAction; PopupMenu1: TPopupMenu; mniPList_Copy: TMenuItem; celInfo: TStringGrid; edtMessage: TEdit; SaveDialog1: TSaveDialog; Button_Copy: TButton; procedure actKey_DownExecute (Sender: TObject); procedure actKey_PressExecute(Sender: TObject); procedure FormCreate (Sender: TObject); procedure FormClose (Sender: TObject; var Action: TCloseAction); procedure FormDestroy(Sender: TObject); procedure FormResize (Sender: TObject); procedure FormKeyUp (Sender: TObject; var Key: Word; Shift: TShiftState); procedure btnClearClick (Sender: TObject); procedure btnWriteLogClick (Sender: TObject); procedure btnCloseClick (Sender: TObject); procedure mniPList_CopyClick(Sender: TObject); procedure celInfoDrawCell (Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); procedure edtMessageChange (Sender: TObject); procedure Button_CopyClick(Sender: TObject); private { Private 宣言 } F_sLogFile : WideString; F_sWorkFile : WideString; F_bProcessMessages : Boolean; //Application.ProcessMessages を呼ぶか F_iMaxLine : Integer; //ログ保存行数 F_slAdd : TStrings; F_slInfoList : TStrings; function F_SaveFile(sFile, sText : WideString) : Boolean; public { Public 宣言 } procedure Clear; procedure SaveLog; property LogFile: WideString read F_sLogFile write F_sLogFile; property ProcessMessages: Boolean read F_bProcessMessages write F_bProcessMessages; property MaxLine: Integer read F_iMaxLine write F_iMaxLine; end; //メッセージモード //専用の別プログラムに出力 procedure gpcMessageModeSet(bMode: Boolean = True); procedure gpcExeMode; //この関数ですべてをまかなう procedure gpcDebug(Value: array of Variant); overload; procedure gpcDebug; overload; procedure gpcDebug(Value: Variant); overload; procedure gpcDebug(Value1, Value2: Variant); overload; procedure gpcDebugInt(iValue: array of Integer); overload; //WideString 複数行対応 procedure gpcDebugText(sMsg, sText: WideString); overload; procedure gpcDebugText(sText: WideString); overload; //TStrings procedure gpcDebug (slList: TStrings); overload; procedure gpcDebugUTF7Strings(slList: TStrings); overload; procedure gpcDebugUTF8Strings(slList: TStrings); overload; procedure gpcDebugExStrings (slList: TStrings); overload; //Dump procedure gpcDebugDump(sMsg : WideString; sStr : AnsiString); overload; procedure gpcDebugDump( sStr : AnsiString); overload; procedure gpcDebugDump(sMsg : WideString; pStr : PAnsiChar; iCount : Integer); overload; procedure gpcDebugDump( pStr : PAnsiChar; iCount : Integer); overload; //Bin procedure gpcDebugBin(iNum: Integer); overload; //ControlState procedure gpcDebug(sMsg: WideString; csState: TControlState); overload; //procedure gpcDebug(csState: TControlState); overload; //ComponentState procedure gpcDebug(sMsg: WideString; csState: TComponentState); overload; //procedure gpcDebug(csState: TComponentState); overload; //TOwnerDrawState procedure gpcDebug(sMsg: WideString; odState: TOwnerDrawState); overload; //procedure gpcDebug(odState: TOwnerDrawState); overload; //TRect function gfnsRectString(rcValue : TRect) : WideString; procedure gpcDebug(sMsg: WideString; rcValue: TRect); overload; procedure gpcDebug(rcValue: TRect); overload; procedure gpcDebug(sMsg: WideString; rcValue: TRect; sMsg2: WideString); overload; //TPoint function gfnsPointString(ptValue : TPoint) : WideString; procedure gpcDebugPoint(sMsg : WideString; ptValue : array of TPoint); overload; procedure gpcDebugPoint( ptValue : array of TPoint); overload; procedure gpcDebug(sMsg : WideString; ptValue : TPoint); overload; procedure gpcDebug( ptValue : TPoint); overload; //TGridRect procedure gpcDebug(sMsg: WideString; rcRect: TGridRect); overload; procedure gpcDebug(rcRect: TGridRect); overload; //TGridCoord procedure gpcDebug(sMsg: WideString; GridCoord: TGridCoord); overload; procedure gpcDebug(GridCoord: TGridCoord); overload; //TMessage procedure gpcDebug(rValue: TMessage); overload; procedure gpcDebug(sMsg: WideString; rValue: TMessage); overload; //TMsg //procedure gpcDebug(rValue: TMsg); overload; //procedure gpcDebug(sMsg: WideString; rValue: TMsg); overload; procedure gpcDebug(rValue: tagMSG); overload; procedure gpcDebug(sMsg: WideString; rValue: tagMSG); overload; //ウィンドウメッセージ function gfnsWM_MessageString(iMessage: Cardinal): WideString; procedure gpcDebugWM_Message(iMessage: Cardinal); //THitTests function gfnsHitTestString(iValue : LRESULT) : WideString; overload; function gfnsHitTestString(htValue : THitTests) : WideString; overload; procedure gpcDebugHitTest(sMsg : WideString; htValue : THitTests); overload; procedure gpcDebugHitTest( htValue : THitTests); overload; //クリップボードのフォーマット function gfnsDebugClipboardFormat(iFormat: Word): WideString; procedure gpcDebugClipboardFormat; //------------------------------------------------------------------------------ //procedure gpcDebugAdds(sStrs: array of WideString); overload; //procedure gpcDebugIntAdds(iNums: array of DWORD); overload; procedure gpcDebugIntAdds(sMsg: WideString; iNums: array of Int64); overload; procedure gpcDebugIntAdds(iNums: array of Int64); overload; //WideString procedure gpcDebugAdd(sMsg, sValue: WideString); overload; procedure gpcDebugAdd(sValue: WideString); overload; //Int64 procedure gpcDebugAdd(sMsg: WideString; iValue: Int64); overload; procedure gpcDebugAdd(iValue: Int64); overload; //Extended procedure gpcDebugAdd(sMsg: WideString; fValue: Extended); overload; procedure gpcDebugAdd(fValue: Extended); overload; //Boolean procedure gpcDebugAdd(sMsg: WideString; bValue: Boolean); overload; procedure gpcDebugAdd(bValue: Boolean); overload; //Pointer procedure gpcDebugAdd(sMsg: WideString; pAddr: Pointer); overload; procedure gpcDebugAdd(pAddr: Pointer); overload; //TFileTime procedure gpcDebugAdd(sMsg: WideString; rValue: TFileTime); overload; procedure gpcDebugAdd(rValue: TFileTime); overload; //TShiftState procedure gpcDebugAdd(sMsg: WideString; ssState: TShiftState); overload; procedure gpcDebugAdd(ssState: TShiftState); overload; //TCustomDrawState procedure gpcDebugAdd(sMsg: WideString; cdsState: TCustomDrawState); overload; procedure gpcDebugAdd(cdsState: TCustomDrawState); overload; //TCustomDrawStage procedure gpcDebugAdd(sMsg: WideString; cdStage: TCustomDrawStage); overload; procedure gpcDebugAdd(cdStage: TCustomDrawStage); overload; //TSize procedure gpcDebugAdd(sMsg: WideString; szValue: TSize); overload; procedure gpcDebugAdd(szValue: TSize); overload; //TScrollCode procedure gpcDebugAdd(sMsg: WideString; scCode: TScrollCode); overload; procedure gpcDebugAdd(scCode: TScrollCode); overload; //TGridDrawState procedure gpcDebugAdd(sMsg: WideString; gdCode: TGridDrawState); overload; procedure gpcDebugAdd(gdCode: TGridDrawState); overload; //TColor //TColorは別にしないと、Integerを引数に取るgpcDebugAdd実行するとスタックオーバーフローするのでアウト procedure gpcDebugAddColor(clColor: TColor); overload; procedure gpcDebugAddColor(sMsg: WideString; clColor: TColor); overload; //整数16進表示 procedure gpcDebugAddIntToHex(iValue: Int64); overload; procedure gpcDebugAddIntToHex(sMsg: WideString; iValue: Int64); overload; //ダンプ procedure gpcDebugAddPCharToDump(pStr: PAnsiChar; iCount: Integer); overload; procedure gpcDebugAddPCharToDump(sMsg: WideString; pStr: PAnsiChar; iCount: Integer); overload; //PowerBroadcast procedure gpcDebugAddPowerBroadcast(Msg: TMessage); overload; procedure gpcDebugAddPowerBroadcast(sMsg: WideString; Msg: TMessage); overload; //TMediaPlayer //TMPModes procedure gpcDebugAdd(mpMode: TMPModes); overload; procedure gpcDebugAdd(sMsg: WideString; mpMode: TMPModes); overload; //TMPNotifyValues procedure gpcDebugAdd(nvValue: TMPNotifyValues); overload; procedure gpcDebugAdd(sMsg: WideString; nvValue: TMPNotifyValues); overload; //.lnkの情報 procedure gpcDebugAddLinkInfo(sLink: WideString); //------------------------------------------------------------------------------ //メッセージ出力 //WideString procedure gpcDebugShowMessage(sStr: WideString); overload; procedure gpcDebugShowMessage(sMsg, sStr: WideString); overload; //Int64 procedure gpcDebugShowMessage(sStr: WideString; iValue: Int64); overload; procedure gpcDebugShowMessage(iValue: Int64); overload; //Boolean procedure gpcDebugShowMessage(sMsg: WideString; bBool: Boolean); overload; procedure gpcDebugShowMessage(bBool: Boolean); overload; //ダンプ procedure gpcDebugShowMessagePCharToDump(pStr: PAnsiChar; iCount: Integer); overload; procedure gpcDebugShowMessagePCharToDump(sMsg: WideString; pStr: PAnsiChar; iCount: Integer); overload; //解放 procedure gpcDebugFormFree; //クリア procedure gpcDebugFormClear; //一時停止 procedure gpcDebugPause(bPause : Boolean = True); //保存行数 procedure gpcMaxLineSet(iMax: Integer); //Application.ProcessMessagesを呼ぶか procedure gpcProcessMessages(bBool: Boolean); //ファイル保存 procedure gpcLogFileSet(sFileName: WideString); procedure gpcLogFileInit; procedure gpcLogSave; procedure gpcShow; //ベンチマーク procedure gpcBenchmarkStart; procedure gpcBenchmarkEnd; overload; procedure gpcBenchmarkEnd(sMsg: WideString); overload; //------------------------------------------------------------------------------ var MyDebug_Form: TMyDebug_Form; implementation uses ActiveX, Clipbrd, ComObj, ShlObj, ShellAPI, TlHelp32, Variants; {$R *.dfm} //============================================================================== const lciMARGIN = 2; var //ベンチマーク用 liStart, liEnd: DWORD; G_bMsgMode: Boolean = False; //------------------------------------------------------------------------------ //UTF-16LE⇔UTF-7 function gfnsWideToUtf7(sSrc: WideString): AnsiString; //WideStringをUTF-7にエンコードして返す var li_Len: Integer; lp_Buff: PAnsiChar; begin //WC_COMPOSITECHECKはNG li_Len := WideCharToMultiByte(CP_UTF7, 0, PWideChar(sSrc), -1, nil, 0, nil, nil); lp_Buff := AllocMem(li_Len + 1); try WideCharToMultiByte(CP_UTF7, 0, PWideChar(sSrc), -1, lp_Buff, li_Len, nil, nil); Result := AnsiString(lp_Buff); finally FreeMem(lp_Buff); end; end; function gfnsUtf7ToWide(sSrc: AnsiString): WideString; //UTF-7でエンコードされている文字列をWideStringにして返す var li_Len: Integer; lp_Buff: PWideChar; begin li_Len := MultiByteToWideChar(CP_UTF7, 0, PAnsiChar(sSrc), -1, nil, 0); lp_Buff := AllocMem((li_Len + 1) * 2); try MultiByteToWideChar(CP_UTF7, 0, PAnsiChar(sSrc), -1, lp_Buff, li_Len); Result := WideString(lp_Buff); finally FreeMem(lp_Buff); end; end; //UTF-16LE⇔UTF-8 function gfnsWideToUTF8(sSrc: WideString): UTF8String; {2008-06-06: WideStringをUTF-8にエンコードして返す。 UTF8Encodeの方が速い。が、UTF8Encodeはサロゲートペアに対応していない。 } var li_Len: Integer; lp_Buff: PAnsiChar; begin li_Len := WideCharToMultiByte(CP_UTF8, 0, PWideChar(sSrc), -1, nil, 0, nil, nil); lp_Buff := AllocMem(li_Len + 1); try WideCharToMultiByte(CP_UTF8, 0, PWideChar(sSrc), -1, lp_Buff, li_Len +1, nil, nil); Result := UTF8String(lp_Buff); finally FreeMem(lp_Buff); end; end; function gfnsUTF8ToWide(sSrc: UTF8String): WideString; {2008-06-06: UTF-8でエンコードされている文字列をWideStringにして返す。 UTF8Decodeの方が速い。が、UTF8Decodeはサロゲートペアに対応していない。 } var li_Len: Integer; lp_Buff: PWideChar; begin li_Len := MultiByteToWideChar(CP_UTF8, 0, PAnsiChar(sSrc), -1, nil, 0); lp_Buff := AllocMem((li_Len + 1) * 2); try MultiByteToWideChar(CP_UTF8, 0, PAnsiChar(sSrc), -1, lp_Buff, li_Len); Result := WideString(lp_Buff); finally FreeMem(lp_Buff); end; end; function lfniNumLimit(iNum: Integer; iMin, iMax: Integer): Integer; //数値の範囲制限 begin if (iMin = iMax) then begin Result := iMin; end else begin if (iNum < iMin) then begin Result := iMin; end else if (iNum > iMax) then begin Result := iMax; end else begin Result := iNum; end; end; end; function gfnsFileExtGet(sFile: WideString): WideString; {2007-08-05,2008-12-27: Unicode対応ExtractFileExt。 '.'は返る 2008-12-27:'.'のないファイル名のみの場合sFileすべてを返してしまう間違いを修正。 } var i: Integer; begin Result := ''; for i := Length(sFile) downto 1 do begin if (sFile[i] = '\') or (sFile[i] = '/') or (sFile[i] = ':') then begin //拡張子なし Break; end else if (sFile[i] = '.') then begin; //拡張子あり Result := Copy(sFile, i, MaxInt); Break; end; end; end; function gfniProcessIDGet(hHandle: HWND): DWORD; begin GetWindowThreadProcessId(hHandle, @Result); end; var lhPIDToWindowHandle: HWND; function gfnhPIDToWindow(iProcessID: DWORD): HWND; {2010-07-29: PIDからトップレベルウィンドウのウィンドウハンドルを返す。 } function l_fnbEnumWindowProc(hHandle: HWND; iParam: LPARAM): BOOL; stdcall; //戻り値はBooleanではなくBOOLである必要あり begin if (gfniProcessIDGet(hHandle) = DWORD(iParam)) then begin lhPIDToWindowHandle := hHandle; Result := False; end else begin Result := True; end; end; begin lhPIDToWindowHandle := 0; EnumWindows(@l_fnbEnumWindowProc, iProcessID); Result := lhPIDToWindowHandle; end; function gfnhProcessToWindow(hProcess : THandle) : HWND; {2010-04-03: プロセスのハンドルからプロセスのトップレベルウィンドウのハンドルを取得して返す。 トップレベルウィンドウが複数ある場合は一番手前にあるウィンドウのハンドルが返る。 実行ファイルのウィンドウハンドルを取得する場合は実行後WaitForInputIdleで初期化処 理を終了するまで待ってからでないと取得に失敗する。 } var lh_Handle : THandle; lh_SelfPID : DWORD; l_Info : TProcessEntry32; begin Result := 0; FillChar(l_Info, SizeOf(l_Info), 0); l_Info.dwSize := Sizeof(l_Info); lh_Handle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, hProcess); try if (Process32First(lh_Handle, l_Info)) then begin lh_SelfPID := gfniProcessIDGet(Application.Handle); repeat //myDebug.gpcDebug([WideString(l_Info.szExeFile), l_Info.th32ParentProcessID, gfniProcessIDGet(Self.Handle)]); if (l_Info.th32ParentProcessID = lh_SelfPID) then begin Result := gfnhPIDToWindow(l_Info.th32ProcessID); end; until not(Process32Next(lh_Handle, l_Info)); end; finally CloseHandle(lh_Handle); end; end; procedure gpcExecute(sFile: WideString); {2007-10-04,2011-06-23: sFileを実行する } var l_InfoW : TShellExecuteInfoW; lh_Process : THandle; lh_Window : HWND; begin FillChar(l_InfoW, SizeOf(l_InfoW), 0); l_InfoW.cbSize := SizeOf(l_InfoW); l_InfoW.fMask := SEE_MASK_UNICODE or SEE_MASK_NOCLOSEPROCESS or SEE_MASK_CONNECTNETDRV //ネットワーク上のファイルの UNC（Universal Naming Convention）パス名であることを表します。 // or SEE_MASK_FLAG_DDEWAIT //DDE 対話が開始される場合には、それが終了するまで再開されません。 ; if (sFile <> '') then begin l_InfoW.lpFile := PWideChar(sFile); end; l_InfoW.nShow := SW_SHOWNORMAL; if (ShellExecuteExW(@l_InfoW)) then begin lh_Process := l_InfoW.hProcess; end else begin lh_Process := 0; end; // ShellExecuteW(Application.Handle, nil, PWideChar(sFile), nil, nil, SW_SHOWNORMAL); if (lh_Process <> 0) then begin try WaitForInputIdle(lh_Process, 3000); lh_Window := gfnhProcessToWindow(lh_Process); if (IsWindow(lh_Window)) then begin SetForegroundWindow(lh_Window); end; finally CloseHandle(lh_Process); end; end; end; //myWindow.pas function gfnbKeyState(iKey: Integer): Boolean; var li_Check: SHORT; begin //左右ボタンを入れ替えている場合に対処 if (GetSystemMetrics(SM_SWAPBUTTON) <> 0) then begin if (iKey = VK_LBUTTON) then begin iKey := VK_RBUTTON; end else if (iKey = VK_RBUTTON) then begin //2009-02-04:VK_RUBTTONとしたままだったのを修正。 iKey := VK_LBUTTON; end; end; li_Check := GetAsyncKeyState(iKey); //Result := BOOL(Hi(li_Check)) and (BOOL(Lo(li_Check))); Result := BOOL(Hi(li_Check)); end; //myString.pas function gfnsWideToAnsi(sSrc: WideString): AnsiString; {2008-06-03,12-28,2009-02-12: 合成文字をきちんとあつかってAnsiStringに変換。 例)「か゛」→「が」みたいな感じで。 2009-02-12:合成文字のみの場合にきちんと変換されていなかった不具合の修正。 2008-12-28:gfnsWideToStr→gfnsWideToAnsi } const lcs_DEF = ''; var li_Len: Integer; lp_Buff: PAnsiChar; begin //WC_COMPOSITECHECKが肝 li_Len := WideCharToMultiByte(CP_ACP, WC_COMPOSITECHECK{ or WC_SEPCHARS}, PWideChar(sSrc), -1, nil, 0, nil, nil); Inc(li_Len); lp_Buff := AllocMem(li_Len); try WideCharToMultiByte(CP_ACP, WC_COMPOSITECHECK{ or WC_SEPCHARS}, PWideChar(sSrc), -1, lp_Buff, li_Len, nil, nil); Result := AnsiString(lp_Buff); finally FreeMem(lp_Buff); end; end; //myClipbrd.pas procedure gpcStrToClipboard(sText: WideString); {2007-08-05:08-07 クリップボードへ文字列をセットする Unicode文字列としてセットすると同時に（Unicodeでない）プレーンテキストとしてもセットする 2007-08-07:EmptyClipboard をやってなかった。そのせいなのかどうのなか、たまにエラーになってた } var li_WLen, li_Len: Integer; ls_Text: AnsiString; lh_Mem: THandle; lp_Data: Pointer; begin li_WLen := (Length(sText) + 1) * 2; ls_Text := gfnsWideToAnsi(sText); li_Len := Length(ls_Text) + 1; if (sText <> '') then begin if (OpenClipboard(Application.Handle)) then begin try EmptyClipboard; //CF_UNICODETEXT lh_Mem := GlobalAlloc(GHND or GMEM_SHARE, li_WLen); lp_Data := GlobalLock(lh_Mem); lstrcpyW(lp_Data, PWideChar(sText)); GlobalUnlock(lh_Mem); SetClipboardData(CF_UNICODETEXT, lh_Mem); //CF_TEXT lh_Mem := GlobalAlloc(GHND or GMEM_SHARE, li_Len); lp_Data := GlobalLock(lh_Mem); lstrcpyA(lp_Data, PAnsiChar(ls_Text)); GlobalUnlock(lh_Mem); SetClipboardData(CF_TEXT, lh_Mem); finally CloseClipboard; end; end; end; end; function gfniGridLastPageTopRow(Grid: TDrawGrid): Integer; {2008-01-16: 最後の行が表示領域の一番下にくるようなTopRowを返す } var li_Page: Integer; begin with Grid do begin li_Page := Trunc(ClientHeight / (DefaultRowHeight + GridLineWidth)) - FixedRows; if (RowCount = 0) then begin Result := -1; end else if (RowCount <= li_Page) then begin Result := 0; end else begin Result := RowCount - li_Page; end; end; end; //============================================================================== procedure gpcDebugAdds(sStrs: array of WideString); //すべてのメッセージ出力処理を最終的にこの手続きで行う var i{, li_Del}: Integer; ls_Text : WideString; lh_Handle : HWND; lb_Create : Boolean; begin if (Application.Terminated) and not(G_bMsgMode) then begin Exit; end; for i := 0 to High(sStrs) do begin if (i = 0) then begin ls_Text := sStrs[i]; end else begin ls_Text := ls_Text + ' ' + sStrs[i]; end; end; if (G_bMsgMode) then begin lh_Handle := FindWindowEx(FindWindow('TTOOL_Debug', nil), 0, 'TEdit', nil); if (lh_Handle <> 0) then begin SendMessageA(lh_Handle, WM_SETTEXT, 0, LPARAM(PAnsiChar(gfnsWideToUtf7(ls_Text)))); // PostMessage(lh_Handle, WM_SETTEXT, 0, LPARAM(PAnsiChar(gfnsWideToUtf7(ls_Text)))); end; //ここでルーチン終了 Exit; end; if not(Assigned(MyDebug_Form)) then begin MyDebug_Form := TMyDebug_Form.Create(Application); end else begin lb_Create := True; for i := 0 to Screen.FormCount-1 do begin if (Screen.Forms[i] is TMyDebug_Form) then begin lb_Create := False; Break; end; end; if (lb_Create) then begin MyDebug_Form := TMyDebug_Form.Create(Application); end; end; SendMessageA(MyDebug_Form.edtMessage.Handle, WM_SETTEXT, 0, LPARAM(PAnsiChar(gfnsWideToUtf7(ls_Text)))); MyDebug_Form.Visible := True; //2009-03-01:ProcessMessagesを呼ぶと動作が変わる場合もあるのでOn/Offできるように変更 { with MyDebug_Form do begin if not(chkPause.Checked) then begin //Unicode文字があっても大丈夫なようにAnsiStringに変換してリストに保持 //DrawItemイベントで表示する時に戻す F_slAdd.Clear; F_slAdd.Text := gfnsWideToUtf7(ls_Text); F_slInfoList.AddStrings(F_slAdd); if (F_slInfoList.Count > F_iMaxLine) then begin li_Del := F_slInfoList.Count - F_iMaxLine; for i := 0 to li_Del do begin F_slInfoList.Delete(0); end; end else begin celInfo.RowCount := F_slInfoList.Count; //最後の出力が画面の外に出てしまわないようにTopIndexを調整 celInfo.TopRow := gfniGridLastPageTopRow(celInfo); end; celInfo.Repaint; end; Visible := True; //2009-03-01:ProcessMessagesを呼ぶと動作が変わる場合もあるのでOn/Offできるように変更 if (F_bProcessMessages) then begin Application.ProcessMessages; end; end; } end; procedure gpcDebug(Value: array of Variant); overload; var ls_Arg: array of WideString; i: Integer; begin SetLength(ls_Arg, High(Value) +1); for i := 0 to High(Value) do begin ls_Arg[i] := WideString(VarAsType(Value[i], varOleStr)); end; gpcDebugAdds(ls_Arg); end; procedure gpcDebug(Value: Variant); begin gpcDebugAdd(WideString(VarAsType(Value, varOleStr)), ''); end; procedure gpcDebug(Value1, Value2: Variant); begin gpcDebugAdd(WideString(VarAsType(Value1, varOleStr)), WideString(VarAsType(Value2, varOleStr))); end; procedure gpcDebugInt(iValue: array of Integer); var ls_Str: String; i : Integer; begin ls_Str := ''; for i := 0 to High(iValue) do begin ls_Str := Format('%s %d', [ls_Str, iValue[i]]); end; gpcDebugAdd(ls_Str); end; //改行 procedure gpcDebug; begin gpcDebugAdd(''); end; //WideString 複数行対応 procedure gpcDebugText(sMsg, sText: WideString); begin gpcDebug(sMsg); gpcDebugText(sText); end; procedure gpcDebugText(sText: WideString); const lcs_CR = WideString(#$D); lcs_LF = WideString(#$A); var i, li_Len: Integer; ls_Line: WideString; begin li_Len := Length(sText); i := 1; ls_Line := ''; while (i <= Length(sText)) do begin if (sText[i] = lcs_CR) or (sText[i] = lcs_LF) then begin gpcDebug(ls_Line); ls_Line := ''; if (i < li_Len) then begin Inc(i); if ((sText[i] = lcs_CR) and (sText[i +1] = lcs_LF)) or ((sText[i] = lcs_LF) and (sText[i +1] = lcs_CR)) then begin Inc(i); end; end; end; ls_Line := ls_Line + sText[i]; end; end; //TRect function gfnsRectString(rcValue : TRect) : WideString; begin Result := WideFormat('(%d,%d,%d,%d)', [rcValue.Left, rcValue.Top, rcValue.Right, rcValue.Bottom]); end; procedure gpcDebug(sMsg: WideString; rcValue: TRect); begin gpcDebug(sMsg, gfnsRectString(rcValue)); end; procedure gpcDebug(rcValue: TRect); begin gpcDebug('', rcValue); end; procedure gpcDebug(sMsg: WideString; rcValue: TRect; sMsg2: WideString); begin with rcValue do begin gpcDebug([sMsg, gfnsRectString(rcValue), sMsg2]); end; end; //TGridRect procedure gpcDebug(sMsg: WideString; rcRect: TGridRect); overload; begin gpcDebug(sMsg, Rect(rcRect.Left, rcRect.Top, rcRect.Right, rcRect.Bottom)); end; procedure gpcDebug(rcRect: TGridRect); overload; begin gpcDebug('', rcRect); end; //TPoint function gfnsPointString(ptValue : TPoint) : WideString; begin Result := WideFormat('(%d,%d)', [ptValue.X, ptValue.Y]); end; procedure gpcDebugPoint(sMsg: WideString; ptValue: array of TPoint); var i : Integer; ls_Value : WideString; begin ls_Value := ''; for i := 0 to High(ptValue) do begin ls_Value := WideFormat('%s %s', [ls_Value, gfnsPointString(ptValue[i])]); end; gpcDebug(sMsg, ls_Value); end; procedure gpcDebugPoint(ptValue : array of TPoint); begin gpcDebugPoint('', ptValue); end; procedure gpcDebug(sMsg: WideString; ptValue: TPoint); begin gpcDebug(sMsg, gfnsPointString(ptValue)); end; procedure gpcDebug(ptValue: TPoint); begin gpcDebug('', ptValue); end; //TGridCoord procedure gpcDebug(sMsg: WideString; GridCoord: TGridCoord); overload; begin gpcDebug(sMsg, Point(GridCoord.X, GridCoord.Y)); end; procedure gpcDebug(GridCoord: TGridCoord); overload; begin gpcDebug('', GridCoord); end; //TStrings procedure gpcDebug(slList: TStrings); var i: Integer; begin for i := 0 to slList.Count - 1 do begin gpcDebug([i, slList[i]]); end; end; //UTF7 procedure gpcDebugUTF7Strings(slList: TStrings); overload; var i: Integer; begin for i := 0 to slList.Count - 1 do begin gpcDebug([i, gfnsUtf7ToWide(slList[i])]); end; end; procedure gpcDebugUTF8Strings(slList: TStrings); var i: Integer; begin for i := 0 to slList.Count - 1 do begin gpcDebug([i, gfnsUtf8ToWide(slList[i])]); end; end; //TMyWStrings const l_csPREFIX_CHAR = '$'; procedure gpcDebugExStrings(slList: TStrings); function lfns_AnsiToWideEx(sSrc: AnsiString): WideString; //独自変換させたWideStringを元に戻す var li_Pos, li_Len: Integer; ls_WStr, ls_WCnv: WideString; begin Result := ''; if (sSrc <> '') then begin ls_WStr := WideString(sSrc); li_Pos := Pos(l_csPREFIX_CHAR, ls_WStr); if (li_Pos = 0) then begin //2008-02-12:プリフィクス文字($)がなければ変換する必要はない Result := ls_WStr; end else begin li_Len := Length(ls_WStr); repeat //'$'までの文字列を足しこむ Result := Result + Copy(ls_WStr, 1, li_Pos -1); try //'$'に続く(はずの)4文字の数値をUnicode文字に変換 ls_WCnv := WideString(WideChar(StrToInt(Copy(ls_WStr, li_Pos, 5)))); Result := Result + ls_WCnv; ls_WStr := Copy(ls_WStr, li_Pos +4 +1, li_Len); //4文字の数値の次からコピー開始 except //イレギュラー Result := Result + WideString(l_csPREFIX_CHAR); //イレギュラー時はそのままにする ls_WStr := Copy(ls_WStr, li_Pos + 1, li_Len); //'$'の次からコピー開始 end; //次の'$'までの位置を取得 li_Pos := Pos(l_csPREFIX_CHAR, ls_WStr); Application.ProcessMessages; until (li_Pos = 0); //untilは条件がTrueで終了 Result := Result + ls_WStr; end; end; end; var i: Integer; begin for i := 0 to slList.Count - 1 do begin gpcDebug([i, lfns_AnsiToWideEx(slList[i])]); end; end; //Dump procedure gpcDebugDump(sMsg: WideString; sStr: AnsiString); {,2011-05-16: 2011-05-16:1365文字以上になるとアクセス違反の例外が起きるので1024文字までに制限 } const lci_MAX = 1024; var i : Integer; li_Count : Integer; ls_Str : WideString; begin li_Count := Length(sStr); if (li_Count > lci_MAX) then begin li_Count := lci_MAX; end; ls_Str := ''; for i := 1 to li_Count do begin ls_Str := WideFormat('%s %.2x', [ls_Str, Ord(sStr[i])]); end; gpcDebug(sMsg, ls_Str); end; procedure gpcDebugDump(sStr: AnsiString); begin gpcDebugDump('', sStr); end; procedure gpcDebugDump(sMsg : WideString; pStr: PAnsiChar; iCount: Integer); var i: Integer; ls_Str: WideString; begin ls_Str := ''; for i := 0 to iCount -1 do begin ls_Str := WideFormat('%s %.2x', [ls_Str, Ord(pStr[i])]); end; gpcDebug(sMsg, ls_Str); end; procedure gpcDebugDump(pStr: PAnsiChar; iCount: Integer); begin gpcDebugDump('', pStr, iCount); end; //Bin procedure gpcDebugBin(iNum: Integer); overload; { const lcs_HTOB: array[0..1, 0..15] of String = ( ('0', '0000'), ('1', '0001'), ('2', '0010'), ('3', '0011'), ('4', '0100'), ('5', '0101'), ('6', '0110'), ('7', '0111'), ('8', '1000'), ('9', '1001'), ('A, '1010'), ('B', '1011'), ('C', '1100'), ('D', '1101'), ('E', '1110'), ('F', '1111') ); } var i: Integer; ls_Hex, ls_Str, ls_Bin: WideString; begin ls_Str := ''; ls_Hex := WideFormat('%x', [iNum]); for i := 1 to Length(ls_Hex) do begin case ls_Hex[i] of '0': ls_Bin := '0000'; '1': ls_Bin := '0001'; '2': ls_Bin := '0010'; '3': ls_Bin := '0011'; '4': ls_Bin := '0100'; '5': ls_Bin := '0101'; '6': ls_Bin := '0110'; '7': ls_Bin := '0111'; '8': ls_Bin := '1000'; '9': ls_Bin := '1001'; 'A': ls_Bin := '1010'; 'B': ls_Bin := '1011'; 'C': ls_Bin := '1100'; 'D': ls_Bin := '1101'; 'E': ls_Bin := '1110'; 'F': ls_Bin := '1111'; else ls_Bin := ''; end; ls_Str := ls_Str + ls_BIN; end; gpcDebug(ls_Str); end; //------------------------------------------------------------------------------ procedure gpcDebugIntAdds(iNums: array of Int64); begin gpcDebugIntAdds('', iNums); end; procedure gpcDebugIntAdds(sMsg: WideString; iNums: array of Int64); var i: Integer; ls_Text: WideString; begin for i := 0 to High(iNums) do begin if (i = 0) then begin ls_Text := IntToStr(iNums[i]); end else begin ls_Text := ls_Text + ' ' + IntToStr(iNums[i]); end; end; gpcDebugAdd(sMsg, ls_Text); end; //WideString procedure gpcDebugAdd(sMsg, sValue: WideString); begin gpcDebugAdds([sMsg, sValue]); end; procedure gpcDebugAdd(sValue: WideString); begin gpcDebugAdd('', sValue); end; //整数 procedure gpcDebugAdd(iValue: Int64); begin gpcDebugAdd('', iValue); end; procedure gpcDebugAdd(sMsg: WideString; iValue: Int64); begin gpcDebugAdd(sMsg, IntToStr(iValue)); end; //浮動小数点 procedure gpcDebugAdd(fValue: Extended); begin gpcDebugAdd('', fValue); end; procedure gpcDebugAdd(sMsg: WideString; fValue: Extended); begin gpcDebugAdd(sMsg, WideFormat('%f', [fValue])); end; //真偽 procedure gpcDebugAdd(bValue: Boolean); begin gpcDebugAdd('', bValue); end; procedure gpcDebugAdd(sMsg: WideString; bValue: Boolean); var ls_Bool: String; begin if (bValue) then begin ls_Bool := 'True'; end else begin ls_Bool := 'False'; end; gpcDebugAdd(sMsg, ls_Bool); end; //Pointer procedure gpcDebugAdd(pAddr: Pointer); overload; begin gpcDebugAdd('', pAddr); end; procedure gpcDebugAdd(sMsg: WideString; pAddr: Pointer); overload; begin if (pAddr = nil) then begin gpcDebugAdd(sMsg, 'nil'); end else begin gpcDebugAdd(sMsg, Format('%p', [pAddr])); end; end; //TFileTime procedure gpcDebugAdd(rValue: TFileTime); begin gpcDebugAdd('', rValue); end; procedure gpcDebugAdd(sMsg: WideString; rValue: TFileTime); { dwLowDateTime: DWORD; dwHighDateTime: DWORD; } begin with rValue do begin gpcDebugAdd(sMsg, WideFormat('dwLowDateTime(%d) dwHighDateTime(%d)', [dwLowDateTime, dwHighDateTime])); end; end; //TShiftState procedure gpcDebugAdd(ssState: TShiftState); begin gpcDebugAdd('', ssState); end; procedure gpcDebugAdd(sMsg: WideString; ssState: TShiftState); var ls_State: WideString; begin ls_State := ''; if (ssShift in ssState) then ls_State := ls_State + 'ssShift '; if (ssAlt in ssState) then ls_State := ls_State + 'ssAlt '; if (ssCtrl in ssState) then ls_State := ls_State + 'ssCtrl '; if (ssLeft in ssState) then ls_State := ls_State + 'ssLeft '; if (ssRight in ssState) then ls_State := ls_State + 'ssRight '; if (ssMiddle in ssState) then ls_State := ls_State + 'ssMiddle '; if (ssDouble in ssState) then ls_State := ls_State + 'ssDouble '; gpcDebugAdd(sMsg, WideFormat('[%s]', [TrimRight(ls_State)])); end; //TCustomDrawState procedure gpcDebugAdd(cdsState: TCustomDrawState); overload; begin gpcDebugAdd('', cdsState); end; procedure gpcDebugAdd(sMsg: WideString; cdsState: TCustomDrawState); overload; var ls_State: WideString; begin ls_State := ''; if (cdsSelected in cdsState) then ls_State := ls_State + 'cdsSelected '; if (cdsGrayed in cdsState) then ls_State := ls_State + 'cdsGrayed '; if (cdsDisabled in cdsState) then ls_State := ls_State + 'cdsDisabled '; if (cdsChecked in cdsState) then ls_State := ls_State + 'cdsChecked '; if (cdsFocused in cdsState) then ls_State := ls_State + 'cdsFocused '; if (cdsDefault in cdsState) then ls_State := ls_State + 'cdsDefault '; if (cdsHot in cdsState) then ls_State := ls_State + 'cdsHot '; if (cdsMarked in cdsState) then ls_State := ls_State + 'cdsMarked '; if (cdsIndeterminate in cdsState) then ls_State := ls_State + 'cdsIndeterminate '; gpcDebugAdd(sMsg, WideFormat('[%s]', [TrimRight(ls_State)])); end; //TCustomDrawStage procedure gpcDebugAdd(cdStage: TCustomDrawStage); overload; begin gpcDebugAdd('', cdStage); end; procedure gpcDebugAdd(sMsg: WideString; cdStage: TCustomDrawStage); overload; var ls_Stage: WideString; begin if (cdStage = cdPrePaint) then begin ls_Stage := 'cdPrePaint 描画の前'; end else if (cdStage = cdPostPaint) then begin ls_Stage := 'cdPostPaint 描画の後'; end else if (cdStage = cdPreErase) then begin ls_Stage := 'cdPreErase 消去の前'; end else if (cdStage = cdPostErase) then begin ls_Stage := 'cdPostErase 消去の後'; end else begin ls_Stage := 'その他'; end; gpcDebugAdd(sMsg, ls_Stage); end; //THitTest; function gfnsHitTestString(iValue : LRESULT) : WideString; begin case iValue of HTBORDER : Result := '18 HTBORDER 可変枠を持たない境界線上にある'; HTBOTTOM : Result := '15 HTBOTTOM 可変枠の下辺境界線上にある'; HTBOTTOMLEFT : Result := '16 HTBOTTOMLEFT 同、左下隅にある'; HTBOTTOMRIGHT : Result := '17 HTBOTTOMRIGHT 同、右下隅にある'; HTCAPTION : Result := ' 2 HTCAPTION キャプションバー上にある'; HTCLIENT : Result := ' 1 HTCLIENT クライアント領域内にある'; HTERROR : Result := '-2 HTERROR デスクトップ上にあり、警告音を鳴らす'; HTHSCROLL : Result := ' 6 HTHSCROOL 水平スクロールバーないある'; HTLEFT : Result := '10 HTLEFT 可変枠の左辺境界線上にある'; HTMENU : Result := ' 5 HTMENU メニューバー内にある'; HTMINBUTTON : Result := ' 8 HTMINBUTTON アイコン化ボタン上にある'; HTMAXBUTTON : Result := ' 9 HTMAXBUTTON 最大化ボタン上にある'; Windows.HTNOWHERE : Result := ' 0 HTNOWHERE デスクトップ上にある'; HTRIGHT : Result := '11 HTRIGHT 可変枠の右辺境界線上にある'; HTSIZE : Result := ' 4 HTSIZE サイズボックス内にある'; HTSYSMENU : Result := ' 3 HTSYSMENU システムメニュー内にある'; HTTOP : Result := '12 HTTOP 可変枠の上辺境界線上にある'; HTTOPLEFT : Result := '13 HTTOPLEFT 可変枠の左上隅にある'; HTTOPRIGHT : Result := '14 HTTOPRIGHT 可変枠の右上隅にある'; HTTRANSPARENT : Result := '-1 HTTRANSPARENT 同じスレッドの別のウィンドウの下にある'; HTVSCROLL : Result := ' 7 HTVSCROLL 垂直スクロールバー内にある'; end; end; function gfnsHitTestString(htValue : THitTests) : WideString; var ls_State: WideString; begin ls_State := ''; if (ComCtrls.htAbove in htValue) then ls_State := ls_State + 'htAbove '; if (ComCtrls.htBelow in htValue) then ls_State := ls_State + 'htBelow '; //Windows.pasにもhtNowhereがあるのでComCtrls.pasを優先させる if (ComCtrls.htNowhere in htValue) then ls_State := ls_State + 'htNowhere '; if (ComCtrls.htOnItem in htValue) then ls_State := ls_State + 'htOnItem '; if (ComCtrls.htOnButton in htValue) then ls_State := ls_State + 'htOnButton '; if (ComCtrls.htOnIcon in htValue) then ls_State := ls_State + 'htOnIcon '; if (ComCtrls.htOnIndent in htValue) then ls_State := ls_State + 'htOnIndent '; if (ComCtrls.htOnLabel in htValue) then ls_State := ls_State + 'htOnLabel '; if (ComCtrls.htOnRight in htValue) then ls_State := ls_State + 'htOnRight '; if (ComCtrls.htOnStateIcon in htValue) then ls_State := ls_State + 'htOnStateIcon '; if (ComCtrls.htToLeft in htValue) then ls_State := ls_State + 'htToLeft '; if (ComCtrls.htToRight in htValue) then ls_State := ls_State + 'htToRight '; Result := TrimRight(ls_State); end; procedure gpcDebugHitTest(sMsg: WideString; htValue: THitTests); begin gpcDebug(sMsg, gfnsHitTestString(htValue)); end; procedure gpcDebugHitTest(htValue: THitTests); begin gpcDebugHitTest('', htValue); end; //クリップボードのフォーマット function gfnsDebugClipboardFormat(iFormat: Word): WideString; begin case iFormat of CF_TEXT : Result := 'CF_TEXT'; // 1; CF_BITMAP : Result := 'CF_BITMAP'; // 2; CF_METAFILEPICT : Result := 'CF_METAFILEPICT'; // 3; CF_SYLK : Result := 'CF_SYLK'; // 4; CF_DIF : Result := 'CF_DIF'; // 5; CF_TIFF : Result := 'CF_TIFF'; // 6; CF_OEMTEXT : Result := 'CF_OEMTEXT'; // 7; CF_DIB : Result := 'CF_DIB'; // 8; CF_PALETTE : Result := 'CF_PALETTE'; // 9; CF_PENDATA : Result := 'CF_PENDATA'; // 10; CF_RIFF : Result := 'CF_RIFF'; // 11; CF_WAVE : Result := 'CF_WAVE'; // 12; CF_UNICODETEXT : Result := 'CF_UNICODETEXT'; // 13; CF_ENHMETAFILE : Result := 'CF_ENHMETAFILE'; // 14; CF_HDROP : Result := 'CF_HDROP'; // 15; CF_LOCALE : Result := 'CF_LOCALE'; // $10; CF_MAX : Result := 'CF_MAX'; // 17; CF_OWNERDISPLAY : Result := 'CF_OWNERDISPLAY'; // 128; CF_DSPTEXT : Result := 'CF_DSPTEXT'; // 129; CF_DSPBITMAP : Result := 'CF_DSPBITMAP'; // 130; CF_DSPMETAFILEPICT : Result := 'CF_DSPMETAFILEPICT'; // 131; CF_DSPENHMETAFILE : Result := 'CF_DSPENHMETAFILE'; // 142; else Result := 'その他'; end; end; procedure gpcDebugClipboardFormat; var i : Integer; li_Format : Word; begin for i := 0 to Clipboard.FormatCount -1 do begin li_Format := Clipboard.Formats[i]; gpcDebug([ i, li_Format, gfnsDebugClipboardFormat(li_Format) ]); end; end; //TMPModes procedure gpcDebugAdd(mpMode: TMPModes); overload; begin gpcDebugAdd('', mpMode); end; procedure gpcDebugAdd(sMsg: WideString; mpMode: TMPModes); overload; var ls_Str: WideString; begin case mpMode of mpNotReady: ls_Str := 'mpNotReady'; mpStopped: ls_Str := 'mpStopped'; mpPlaying: ls_Str := 'mpPlaying'; mpRecording: ls_Str := 'mpRecording'; mpSeeking: ls_Str := 'mpSeeking'; mpPaused: ls_Str := 'mpPaused'; mpOpen: ls_Str := 'mpOpen'; end; gpcDebugAdd(sMsg, ls_Str); end; //TMPNotifyValues procedure gpcDebugAdd(nvValue: TMPNotifyValues); overload; begin gpcDebugAdd('', nvValue); end; procedure gpcDebugAdd(sMsg: WideString; nvValue: TMPNotifyValues); overload; var ls_Str: WideString; begin case nvValue of nvSuccessful: ls_Str := 'nvSuccessful'; nvSuperseded: ls_Str := 'nvSuperseded'; nvAborted: ls_Str := 'nvAborted'; nvFailure: ls_Str := 'nvFailure'; end; gpcDebugAdd(sMsg, ls_Str); end; //TMessage procedure gpcDebug(rValue: TMessage); begin gpcDebug('', rValue); end; procedure gpcDebug(sMsg: WideString; rValue: TMessage); { Msg: Cardinal; case Integer of 0: ( WParam: Longint; LParam: Longint; Result: Longint); 1: ( WParamLo: Word; WParamHi: Word; LParamLo: Word; LParamHi: Word; ResultLo: Word; ResultHi: Word); end; } begin with rValue do begin gpcDebug(sMsg, WideFormat('Msg($%x) WParam($%x) LParam($%x)', [Msg, WParam, LParam])); end; end; //tagMSG procedure gpcDebug(rValue: tagMSG); begin gpcDebug('', rValue); end; procedure gpcDebug(sMsg: WideString; rValue: tagMSG); { hwnd: HWND; message: UINT; wParam: WPARAM; lParam: LPARAM; time: DWORD; pt: TPoint; } begin with rValue do begin gpcDebug(sMsg, WideFormat('hwnd($%x) message($%x) wParam($%x) lParam($%x) time(%d) pt(%d,%d) - %s', [hwnd, message, wParam, lParam, time, pt.X, pt.Y, gfnsWM_MessageString(message)])); end; end; function gfnsWM_MessageString(iMessage : Cardinal) : WideString; begin case iMessage of $0000: Result := 'WM_NULL'; $0001: Result := 'WM_CREATE'; $0002: Result := 'WM_DESTROY'; $0003: Result := 'WM_MOVE'; $0005: Result := 'WM_SIZE'; $0006: Result := 'WM_ACTIVATE'; $0007: Result := 'WM_SETFOCUS'; $0008: Result := 'WM_KILLFOCUS'; $000A: Result := 'WM_ENABLE'; $000B: Result := 'WM_SETREDRAW'; $000C: Result := 'WM_SETTEXT'; $000D: Result := 'WM_GETTEXT'; $000E: Result := 'WM_GETTEXTLENGTH'; $000F: Result := 'WM_PAINT'; $0010: Result := 'WM_CLOSE'; $0011: Result := 'WM_QUERYENDSESSION'; $0012: Result := 'WM_QUIT'; $0013: Result := 'WM_QUERYOPEN'; $0014: Result := 'WM_ERASEBKGND'; $0015: Result := 'WM_SYSCOLORCHANGE'; $0016: Result := 'WM_ENDSESSION'; $0017: Result := 'WM_SYSTEMERROR'; $0018: Result := 'WM_SHOWWINDOW'; $0019: Result := 'WM_CTLCOLOR'; $001A: Result := 'WM_WININICHANGE or WM_SETTINGCHANGE'; $001B: Result := 'WM_DEVMODECHANGE'; $001C: Result := 'WM_ACTIVATEAPP'; $001D: Result := 'WM_FONTCHANGE'; $001E: Result := 'WM_TIMECHANGE'; $001F: Result := 'WM_CANCELMODE'; $0020: Result := 'WM_SETCURSOR'; $0021: Result := 'WM_MOUSEACTIVATE'; $0022: Result := 'WM_CHILDACTIVATE'; $0023: Result := 'WM_QUEUESYNC'; $0024: Result := 'WM_GETMINMAXINFO'; $0026: Result := 'WM_PAINTICON'; $0027: Result := 'WM_ICONERASEBKGND'; $0028: Result := 'WM_NEXTDLGCTL'; $002A: Result := 'WM_SPOOLERSTATUS'; $002B: Result := 'WM_DRAWITEM'; $002C: Result := 'WM_MEASUREITEM'; $002D: Result := 'WM_DELETEITEM'; $002E: Result := 'WM_VKEYTOITEM'; $002F: Result := 'WM_CHARTOITEM'; $0030: Result := 'WM_SETFONT'; $0031: Result := 'WM_GETFONT'; $0032: Result := 'WM_SETHOTKEY'; $0033: Result := 'WM_GETHOTKEY'; $0037: Result := 'WM_QUERYDRAGICON'; $0039: Result := 'WM_COMPAREITEM'; $003D: Result := 'WM_GETOBJECT'; $0041: Result := 'WM_COMPACTING'; $0044: Result := 'WM_COMMNOTIFY'; $0046: Result := 'WM_WINDOWPOSCHANGING'; $0047: Result := 'WM_WINDOWPOSCHANGED'; $0048: Result := 'WM_POWER'; $004A: Result := 'WM_COPYDATA'; $004B: Result := 'WM_CANCELJOURNAL'; $004E: Result := 'WM_NOTIFY'; $0050: Result := 'WM_INPUTLANGCHANGEREQUEST'; $0051: Result := 'WM_INPUTLANGCHANGE'; $0052: Result := 'WM_TCARD'; $0053: Result := 'WM_HELP'; $0054: Result := 'WM_USERCHANGED'; $0055: Result := 'WM_NOTIFYFORMAT'; $007B: Result := 'WM_CONTEXTMENU'; $007C: Result := 'WM_STYLECHANGING'; $007D: Result := 'WM_STYLECHANGED'; $007E: Result := 'WM_DISPLAYCHANGE'; $007F: Result := 'WM_GETICON'; $0080: Result := 'WM_SETICON'; $0081: Result := 'WM_NCCREATE'; $0082: Result := 'WM_NCDESTROY'; $0083: Result := 'WM_NCCALCSIZE'; $0084: Result := 'WM_NCHITTEST'; $0085: Result := 'WM_NCPAINT'; $0086: Result := 'WM_NCACTIVATE'; $0087: Result := 'WM_GETDLGCODE'; $00A0: Result := 'WM_NCMOUSEMOVE'; $00A1: Result := 'WM_NCLBUTTONDOWN'; $00A2: Result := 'WM_NCLBUTTONUP'; $00A3: Result := 'WM_NCLBUTTONDBLCLK'; $00A4: Result := 'WM_NCRBUTTONDOWN'; $00A5: Result := 'WM_NCRBUTTONUP'; $00A6: Result := 'WM_NCRBUTTONDBLCLK'; $00A7: Result := 'WM_NCMBUTTONDOWN'; $00A8: Result := 'WM_NCMBUTTONUP'; $00A9: Result := 'WM_NCMBUTTONDBLCLK'; $0100: Result := 'WM_KEYFIRST or WM_KEYDOWN'; $0101: Result := 'WM_KEYUP'; $0102: Result := 'WM_CHAR'; $0103: Result := 'WM_DEADCHAR'; $0104: Result := 'WM_SYSKEYDOWN'; $0105: Result := 'WM_SYSKEYUP'; $0106: Result := 'WM_SYSCHAR'; $0107: Result := 'WM_SYSDEADCHAR'; $0108: Result := 'WM_KEYLAST'; $0110: Result := 'WM_INITDIALOG'; $0111: Result := 'WM_COMMAND'; $0112: Result := 'WM_SYSCOMMAND'; $0113: Result := 'WM_TIMER'; $0114: Result := 'WM_HSCROLL'; $0115: Result := 'WM_VSCROLL'; $0116: Result := 'WM_INITMENU'; $0117: Result := 'WM_INITMENUPOPUP'; $0118: Result := 'WM_SYSTIMER'; $011F: Result := 'WM_MENUSELECT'; $0120: Result := 'WM_MENUCHAR'; $0121: Result := 'WM_ENTERIDLE'; $0122: Result := 'WM_MENURBUTTONUP'; $0123: Result := 'WM_MENUDRAG'; $0124: Result := 'WM_MENUGETOBJECT'; $0125: Result := 'WM_UNINITMENUPOPUP'; $0126: Result := 'WM_MENUCOMMAND'; $0127: Result := 'WM_CHANGEUISTATE'; $0128: Result := 'WM_UPDATEUISTATE'; $0129: Result := 'WM_QUERYUISTATE'; $0132: Result := 'WM_CTLCOLORMSGBOX'; $0133: Result := 'WM_CTLCOLOREDIT'; $0134: Result := 'WM_CTLCOLORLISTBOX'; $0135: Result := 'WM_CTLCOLORBTN'; $0136: Result := 'WM_CTLCOLORDLG'; $0137: Result := 'WM_CTLCOLORSCROLLBAR='; $0138: Result := 'WM_CTLCOLORSTATIC'; $0200: Result := 'WM_MOUSEFIRST or WM_MOUSEMOVE'; $0201: Result := 'WM_LBUTTONDOWN'; $0202: Result := 'WM_LBUTTONUP'; $0203: Result := 'WM_LBUTTONDBLCLK'; $0204: Result := 'WM_RBUTTONDOWN'; $0205: Result := 'WM_RBUTTONUP'; $0206: Result := 'WM_RBUTTONDBLCLK'; $0207: Result := 'WM_MBUTTONDOWN'; $0208: Result := 'WM_MBUTTONUP'; $0209: Result := 'WM_MBUTTONDBLCLK'; $020A: Result := 'WM_MOUSEWHEEL or WM_MOUSELAST'; $0210: Result := 'WM_PARENTNOTIFY'; $0211: Result := 'WM_ENTERMENULOOP'; $0212: Result := 'WM_EXITMENULOOP'; $0213: Result := 'WM_NEXTMENU'; 532: Result := 'WM_SIZING'; 533: Result := 'WM_CAPTURECHANGED'; 534: Result := 'WM_MOVING'; 536: Result := 'WM_POWERBROADCAST'; 537: Result := 'WM_DEVICECHANGE'; $010D: Result := 'WM_IME_STARTCOMPOSITION'; $010E: Result := 'WM_IME_ENDCOMPOSITION'; $010F: Result := 'WM_IME_COMPOSITION or WM_IME_KEYLAST'; $0281: Result := 'WM_IME_SETCONTEXT'; $0282: Result := 'WM_IME_NOTIFY'; $0283: Result := 'WM_IME_CONTROL'; $0284: Result := 'WM_IME_COMPOSITIONFULL'; $0285: Result := 'WM_IME_SELECT'; $0286: Result := 'WM_IME_CHAR'; $0288: Result := 'WM_IME_REQUEST'; $0290: Result := 'WM_IME_KEYDOWN'; $0291: Result := 'WM_IME_KEYUP'; $0220: Result := 'WM_MDICREATE'; $0221: Result := 'WM_MDIDESTROY'; $0222: Result := 'WM_MDIACTIVATE'; $0223: Result := 'WM_MDIRESTORE'; $0224: Result := 'WM_MDINEXT'; $0225: Result := 'WM_MDIMAXIMIZE'; $0226: Result := 'WM_MDITILE'; $0227: Result := 'WM_MDICASCADE'; $0228: Result := 'WM_MDIICONARRANGE'; $0229: Result := 'WM_MDIGETACTIVE'; $0230: Result := 'WM_MDISETMENU'; $0231: Result := 'WM_ENTERSIZEMOVE'; $0232: Result := 'WM_EXITSIZEMOVE'; $0233: Result := 'WM_DROPFILES'; $0234: Result := 'WM_MDIREFRESHMENU'; $02A1: Result := 'WM_MOUSEHOVER'; $02A3: Result := 'WM_MOUSELEAVE'; $0300: Result := 'WM_CUT'; $0301: Result := 'WM_COPY'; $0302: Result := 'WM_PASTE'; $0303: Result := 'WM_CLEAR'; $0304: Result := 'WM_UNDO'; $0305: Result := 'WM_RENDERFORMAT'; $0306: Result := 'WM_RENDERALLFORMATS'; $0307: Result := 'WM_DESTROYCLIPBOARD'; $0308: Result := 'WM_DRAWCLIPBOARD'; $0309: Result := 'WM_PAINTCLIPBOARD'; $030A: Result := 'WM_VSCROLLCLIPBOARD'; $030B: Result := 'WM_SIZECLIPBOARD'; $030C: Result := 'WM_ASKCBFORMATNAME'; $030D: Result := 'WM_CHANGECBCHAIN'; $030E: Result := 'WM_HSCROLLCLIPBOARD'; $030F: Result := 'WM_QUERYNEWPALETTE'; $0310: Result := 'WM_PALETTEISCHANGING='; $0311: Result := 'WM_PALETTECHANGED'; $0312: Result := 'WM_HOTKEY'; 791: Result := 'WM_PRINT'; 792: Result := 'WM_PRINTCLIENT'; 856: Result := 'WM_HANDHELDFIRST'; 863: Result := 'WM_HANDHELDLAST'; $0380: Result := 'WM_PENWINFIRST'; $038F: Result := 'WM_PENWINLAST'; $0390: Result := 'WM_COALESCE_FIRST'; $039F: Result := 'WM_COALESCE_LAST'; $03E0: Result := 'WM_DDE_FIRST or WM_DDE_INITIATE'; WM_DDE_FIRST + 1: Result := 'WM_DDE_TERMINATE'; WM_DDE_FIRST + 2: Result := 'WM_DDE_ADVISE'; WM_DDE_FIRST + 3: Result := 'WM_DDE_UNADVISE'; WM_DDE_FIRST + 4: Result := 'WM_DDE_ACK'; WM_DDE_FIRST + 5: Result := 'WM_DDE_DATA'; WM_DDE_FIRST + 6: Result := 'WM_DDE_REQUEST'; WM_DDE_FIRST + 7: Result := 'WM_DDE_POKE'; WM_DDE_FIRST + 8: Result := 'WM_DDE_EXECUTE or WM_DDE_LAST'; $8000: Result := 'WM_APP'; else Result := 'UnKnown'; end; end; procedure gpcDebugWM_Message(iMessage: Cardinal); begin gpcDebugAdd(WideFormat('%5d %4x %s', [iMessage, iMessage, gfnsWM_MessageString(iMessage)])); end; //TSize procedure gpcDebugAdd(szValue: TSize); begin gpcDebugAdd('', szValue); end; procedure gpcDebugAdd(sMsg: WideString; szValue: TSize); begin with szValue do begin gpcDebugAdd(sMsg, WideFormat('%d %d', [cx, cy])); end; end; //ControlState procedure gpcDebug(sMsg: WideString; csState: TControlState); var ls_State: WideString; begin ls_State := ''; if (csLButtonDown in csState) then ls_State := ls_State + 'csLButtonDown '; if (csClicked in csState) then ls_State := ls_State + 'csClicked '; if (csPalette in csState) then ls_State := ls_State + 'csPalette '; if (csReadingState in csState) then ls_State := ls_State + 'csReadingState '; if (csAlignmentNeeded in csState) then ls_State := ls_State + 'csAlignmentNeeded '; if (csFocusing in csState) then ls_State := ls_State + 'csFocusing '; if (csCreating in csState) then ls_State := ls_State + 'csCreating '; if (csPaintCopy in csState) then ls_State := ls_State + 'csPaintCopy '; if (csCustomPaint in csState) then ls_State := ls_State + 'csCustomPaint '; if (csDestroyingHandle in csState) then ls_State := ls_State + 'csDestroyingHandle '; if (csDocking in csState) then ls_State := ls_State + 'csDocking '; gpcDebug(sMsg, WideFormat('[%s]', [TrimRight(ls_State)])); end; { procedure gpcDebug(csState: TControlState); begin gpcDebug('', csState); end; } //ComponentState procedure gpcDebug(sMsg: WideString; csState: TComponentState); var ls_State: WideString; begin ls_State := ''; if (csAncestor in csState) then ls_State := ls_State + 'csAncestor '; if (csDesigning in csState) then ls_State := ls_State + 'csDesigning '; if (csDestroying in csState) then ls_State := ls_State + 'csDestroying '; if (csFixups in csState) then ls_State := ls_State + 'csFixups '; if (csFreeNotification in csState) then ls_State := ls_State + 'csFreeNotification '; if (csInline in csState) then ls_State := ls_State + 'csInline '; if (csLoading in csState) then ls_State := ls_State + 'csLoading '; if (csReading in csState) then ls_State := ls_State + 'csReading '; if (csUpdating in csState) then ls_State := ls_State + 'csUpdating '; if (csWriting in csState) then ls_State := ls_State + 'csWriting '; if (csDesignInstance in csState) then ls_State := ls_State + 'csDesignInstance '; gpcDebug(sMsg, WideFormat('[%s]', [TrimRight(ls_State)])); end; { procedure gpcDebug(csState: TComponentState); begin gpcDebug('', csState); end; } //TOwnerDrawState procedure gpcDebug(sMsg: WideString; odState: TOwnerDrawState); var ls_State: WideString; begin ls_State := ''; if (odSelected in odState) then ls_State := ls_State + 'odSelected '; if (odGrayed in odState) then ls_State := ls_State + 'odGrayed '; if (odDisabled in odState) then ls_State := ls_State + 'odDisabled '; if (odChecked in odState) then ls_State := ls_State + 'odChecked '; if (odFocused in odState) then ls_State := ls_State + 'odFocused '; if (odDefault in odState) then ls_State := ls_State + 'odDefault '; if (odHotLight in odState) then ls_State := ls_State + 'odHotLight '; if (odInactive in odState) then ls_State := ls_State + 'odInactive '; if (odNoFocusRect in odState) then ls_State := ls_State + 'odNoFocusRect '; if (odReserved1 in odState) then ls_State := ls_State + 'odReserved1 '; if (odReserved2 in odState) then ls_State := ls_State + 'odReserved2 '; if (odComboBoxEdit in odState) then ls_State := ls_State + 'odComboBoxEdit '; gpcDebug(sMsg, WideFormat('[%s]', [TrimRight(ls_State)])); end; { procedure gpcDebug(odState: TOwnerDrawState); begin gpcDebug('', odState); end; } //TScrollCode procedure gpcDebugAdd(scCode: TScrollCode); begin gpcDebugAdd('', scCode); end; procedure gpcDebugAdd(sMsg: WideString; scCode: TScrollCode); var ls_Code: WideString; begin case scCode of scLineUp: ls_Code := 'scLineUp'; scLineDown: ls_Code := 'scLineDown'; scPageUp: ls_Code := 'scPageUp'; scPageDown: ls_Code := 'scPageDown'; scPosition: ls_Code := 'scPosition'; scTrack: ls_Code := 'scTrack'; scTop: ls_Code := 'scTop'; scBottom: ls_Code := 'scBottom'; scEndScroll: ls_Code := 'scEndScroll' end; gpcDebugAdd(sMsg, ls_Code); end; //TGridDrawState procedure gpcDebugAdd(sMsg: WideString; gdCode: TGridDrawState); overload; var ls_Code: WideString; begin ls_Code := ''; if (gdSelected in gdCode) then ls_Code := ls_Code + ' gdSelected'; if (gdFocused in gdCode) then ls_Code := ls_Code + ' gdFocused'; if (gdFixed in gdCode) then ls_Code := ls_Code + ' gdFixed'; gpcDebugAdd(sMsg, ls_Code); end; procedure gpcDebugAdd(gdCode: TGridDrawState); overload; begin gpcDebugAdd('', gdCode); end; //16進整数 procedure gpcDebugAddIntToHex(iValue: Int64); begin gpcDebugAddIntToHex('', iValue); end; procedure gpcDebugAddIntToHex(sMsg: WideString; iValue: Int64); begin gpcDebugAdd(sMsg, WideFormat('%x', [iValue])); end; procedure gpcDebugAddPCharToDump(pStr: PAnsiChar; iCount: Integer); begin gpcDebugAddPCharToDump('', pStr, iCount); end; procedure gpcDebugAddPCharToDump(sMsg: WideString; pStr: PAnsiChar; iCount: Integer); var i: Integer; ls_Str: AnsiString; begin ls_Str := ''; for i := 0 to iCount -1 do begin ls_Str := WideFormat('%s %2x', [ls_Str, Ord(pStr[i])]); end; gpcDebugAdd(sMsg, ls_Str); end; //TColor procedure gpcDebugAddColor(clColor: TColor); begin gpcDebugAddColor('', clColor); end; procedure gpcDebugAddColor(sMsg: WideString; clColor: TColor); var ls_Ident: String; begin if (ColorToIdent(clColor, ls_Ident)) then begin gpcDebugAdd(sMsg, ls_Ident); end else begin gpcDebugAdd(sMsg, Integer(clColor)); end; end; //PowerBroadcast procedure gpcDebugAddPowerBroadcast(Msg: TMessage); begin gpcDebugAddPowerBroadcast('', Msg); end; procedure gpcDebugAddPowerBroadcast(sMsg: WideString; Msg: TMessage); var ls_Msg: WideString; begin case Msg.WParam of $0: ls_Msg := 'PBT_APMQUERYSUSPEND 待機要求をする'; $1: ls_Msg := 'PBT_APMQUERYSTANDBY'; $2: ls_Msg := 'PBT_APMQUERYSUSPENDFAILED 待機要求が拒否された'; $3: ls_Msg := 'PBT_APMQUERYSTANDBYFAILED'; $4: ls_Msg := 'PBT_APMSUSPEND システムが待機状態になろうとしている'; $5: ls_Msg := 'PBT_APMSTANDBY'; $6: ls_Msg := 'PBT_APMRESUMECRITICAL 致命的な待機状態からシステムが復帰しようとしている'; $7: ls_Msg := 'PBT_APMRESUMESUSPEND 待機状態から復帰しようとしている'; $8: ls_Msg := 'PBT_APMRESUMESTANDBY'; $9: ls_Msg := 'PBT_APMBATTERLOW バッテリ電力が低下した'; $A: ls_Msg := 'PBT_APMPOWERSTATUSCHANGE パワー状態が変化した'; $B: ls_Msg := 'PBT_APMOEMEVENT OEM定義のイベントが発生した'; $12: ls_Msg := 'PBT_APMRESUMEAUTOMATIC システムが自動的に復帰しようとしている'; else ls_Msg := 'その他' end; gpcDebugAdd(WideFormat('%d %4s', [Msg.WParam, ls_Msg])); end; //.lnk //ShlObj.pasのコードが間違っているのでここで修正。 type IShellLinkW = interface(IUnknown) [SID_IShellLinkW] {*} function GetPath(pszFile: PWideChar; cchMaxPath: Integer; var pfd: TWin32FindDataW; fFlags: DWORD): HResult; stdcall; function GetIDList(var ppidl: PItemIDList): HResult; stdcall; function SetIDList(pidl: PItemIDList): HResult; stdcall; function GetDescription(pszName: PWideChar; cchMaxName: Integer): HResult; stdcall; function SetDescription(pszName: PWideChar): HResult; stdcall; function GetWorkingDirectory(pszDir: PWideChar; cchMaxPath: Integer): HResult; stdcall; function SetWorkingDirectory(pszDir: PWideChar): HResult; stdcall; function GetArguments(pszArgs: PWideChar; cchMaxPath: Integer): HResult; stdcall; function SetArguments(pszArgs: PWideChar): HResult; stdcall; function GetHotkey(var pwHotkey: Word): HResult; stdcall; function SetHotkey(wHotkey: Word): HResult; stdcall; function GetShowCmd(out piShowCmd: Integer): HResult; stdcall; function SetShowCmd(iShowCmd: Integer): HResult; stdcall; function GetIconLocation(pszIconPath: PWideChar; cchIconPath: Integer; out piIcon: Integer): HResult; stdcall; function SetIconLocation(pszIconPath: PWideChar; iIcon: Integer): HResult; stdcall; function SetRelativePath(pszPathRel: PWideChar; dwReserved: DWORD): HResult; stdcall; function Resolve(Wnd: HWND; fFlags: DWORD): HResult; stdcall; function SetPath(pszFile: PWideChar): HResult; stdcall; end; procedure gpcDebugAddLinkInfo(sLink: WideString); var lI_ShellLink: IShellLinkW; lI_PersistFile: IPersistFile; l_Win32FindData: TWin32FindDataW; lp_Buff: PWideChar; li_Len: Integer; li_HotKey: WORD; li_Icon: Integer; begin gpcDebugAdd(sLink, ''); if (WideLowerCase(gfnsFileExtGet(sLink)) = '.lnk') then begin //ショートカットファイルだった lI_ShellLink := (CreateComObject(CLSID_ShellLink) as IShellLinkW); lI_PersistFile := (lI_ShellLink as IPersistFile); if (Succeeded(lI_PerSistFile.Load(PWideChar(sLink), STGM_READ))) then begin lI_ShellLink.Resolve(0, SLR_ANY_MATCH); li_Len := (MAX_PATH + 1) * 2; lp_Buff := AllocMem(li_Len); try //ショートカットファイルの参照先を取得 lI_ShellLink.GetPath(lp_Buff, MAX_PATH, l_Win32FindData, SLGP_UNCPRIORITY); gpcDebugAdd(' GetPath', WideString(lp_Buff)); lI_ShellLink.GetDescription(lp_Buff, MAX_PATH); gpcDebugAdd(' GetDescription', WideString(lp_Buff)); lI_ShellLink.GetWorkingDirectory(lp_Buff, MAX_PATH); gpcDebugAdd(' GetWorkingDirectory', WideString(lp_Buff)); lI_ShellLink.GetArguments(lp_Buff, MAX_PATH); gpcDebugAdd(' GetArguments', WideString(lp_Buff)); lI_ShellLink.GetHotKey(li_HotKey); gpcDebugAdds([' GetHotKey', IntToStr(li_HotKey), ShortCutToText(li_HotKey)]); lI_ShellLink.GetIconLocation(lp_Buff, li_Len, li_Icon); gpcDebugAdds([' GetIconLocation', WideString(lp_Buff), IntToStr(li_Icon)]); finally FreeMem(lp_Buff); end; end; end; end; //------------------------------------------------------------------------------ //メッセージ出力 procedure gpcDebugShowMessage(sMsg, sStr: WideString); begin MessageBoxW(Application.Handle, PWideChar(sMsg + ' ' + sStr), '再開', MB_SETFOREGROUND or MB_OK); end; procedure gpcDebugShowMessage(sStr: WideString); begin gpcDebugShowMessage('', sStr); end; //Int64 procedure gpcDebugShowMessage(sStr: WideString; iValue: Int64); overload; begin gpcDebugShowMessage(sStr + ' ' + IntToStr(iValue)); end; procedure gpcDebugShowMessage(iValue: Int64); overload; begin gpcDebugShowMessage('', iValue); end; //Boolean procedure gpcDebugShowMessage(sMsg: WideString; bBool: Boolean); var ls_Bool: WideString; begin if (bBool) then begin ls_Bool := 'True'; end else begin ls_Bool := 'False'; end; gpcDebugShowMessage(sMsg + ' ' + ls_Bool); end; procedure gpcDebugShowMessage(bBool: Boolean); begin gpcDebugShowMessage('', bBool); end; //ダンプ procedure gpcDebugShowMessagePCharToDump(sMsg: WideString; pStr: PAnsiChar; iCount: Integer); var i: Integer; ls_Str: AnsiString; begin ls_Str := ''; for i := 0 to iCount -1 do begin ls_Str := WideFormat('%s %2x', [ls_Str, Ord(pStr[i])]); end; gpcDebugShowMessage(sMsg, ls_Str); end; procedure gpcDebugShowMessagePCharToDump(pStr: PAnsiChar; iCount: Integer); begin gpcDebugShowMessagePCharToDump('', pStr, iCount); end; procedure gpcDebugFormCreate; var i : Integer; begin if not(Assigned(MyDebug_Form)) then begin MyDebug_Form := TMyDebug_Form.Create(Application); end else begin for i := 0 to Screen.FormCount -1 do begin if (Screen.Forms[i] is TMyDebug_Form) then begin Exit; end; end; MyDebug_Form := TMyDebug_Form.Create(Application); end; end; //解放 procedure gpcDebugFormFree; var i : Integer; begin if (Assigned(MyDebug_Form)) then begin for i := 0 to Screen.FormCount -1 do begin if (Screen.Forms[i] is TMyDebug_Form) then begin TMyDebug_Form(Screen.Forms[i]).Free; end; end; MyDebug_Form := nil; end; end; procedure gpcDebugFormClear; begin if (Assigned(MyDebug_Form)) then begin myDebug_Form.Clear; end; end; //一時停止 procedure gpcDebugPause(bPause : Boolean = True); begin gpcDebugFormCreate; MyDebug_Form.chkPause.Checked := bPause; end; //保存行数 procedure gpcMaxLineSet(iMax: Integer); begin gpcDebugFormCreate; MyDebug_Form.MaxLine := iMax; end; //Application.ProcessMessagesを呼ぶか procedure gpcProcessMessages(bBool: Boolean); begin gpcDebugFormCreate; MyDebug_Form.ProcessMessages := bBool; end; //メッセージモード //専用の別プログラムに出力 procedure gpcMessageModeSet(bMode: Boolean = True); begin G_bMsgMode := bMode; end; procedure gpcExeMode; begin gpcMessageModeSet(True); end; //ログ保存 procedure gpcLogFileSet(sFileName: WideString); {2008-02-11: 表示内容を保存するファイルを設定 空文字で保存しない } begin gpcDebugFormCreate; MyDebug_Form.LogFile := sFileName; end; procedure gpcLogFileInit; begin end; procedure gpcLogSave; {2008-02-11,12-20: ログをUTF-8でファイルへ保存 2008-12-20:Unicode対応。保存はUTF-8。 } begin gpcDebugFormCreate; MyDebug_Form.SaveLog; end; procedure gpcShow; {2008-02-11: 表示 } begin gpcDebugFormCreate; MyDebug_Form.Show; end; //------------------------------------------------------------------------------ {ベンチマーク gpcBenchmarkStart; for i := 0 to GetCount -1 do begin //処理 end; gpcBenchmarkEnd; //かかった処理時間を表示 } procedure gpcBenchmarkStart; begin liStart := GetTickCount; end; procedure gpcBenchmarkEnd; begin liEnd := GetTickCount; gpcDebug(liEnd - liStart); end; procedure gpcBenchmarkEnd(sMsg: WideString); begin liEnd := GetTickCount; gpcDebug(sMsg, liEnd - liStart); end; //------------------------------------------------------------------------------ procedure TMyDebug_Form.FormCreate(Sender: TObject); var lpp_WParam : PPWideChar; li_ParamCount : Integer; ls_File : WideString; begin F_slAdd := TStringList.Create; F_slInfoList := TStringList.Create; Constraints.MinHeight := Height; Constraints.MinWidth := Width; celInfo.Align := alClient; celInfo.Canvas.Font.Assign(celInfo.Font); lpp_WParam := CommandLineToArgvW(GetCommandLineW, li_ParamCount); //実行ファイル名+'.debug.log' ls_File := WideString(lpp_WParam^); LocalFree(Cardinal(lpp_WParam)); F_sLogFile := ls_File + '.debug.log'; F_sWorkFile := ls_File + '.debug.txt'; F_bProcessMessages := True; F_iMaxLine := 1000; // Show; end; procedure TMyDebug_Form.FormClose(Sender: TObject; var Action: TCloseAction); begin Clear; if (Application.Terminated) then begin Action := caFree; end else begin Action := caHide; end; end; procedure TMyDebug_Form.FormDestroy(Sender: TObject); begin F_slAdd.Free; F_slInfoList.Free; // MyDebug_Form := nil; end; procedure TMyDebug_Form.FormResize(Sender: TObject); begin celInfo.ColWidths[0] := ClientWidth; end; procedure TMyDebug_Form.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); begin case Key of Ord('C') :begin if (ssCtrl in Shift) then begin mniPList_CopyClick(nil); end; end; end; end; procedure TMyDebug_Form.Clear; begin F_slInfoList.Clear; celInfo.RowCount := 1; celInfo.Repaint; end; function TMyDebug_Form.F_SaveFile(sFile, sText : WideString) : Boolean; {2011-06-28: } var li_ErrMode : UINT; lh_Handle : THandle; li_Size : DWORD; ls_Data : AnsiString; begin Result := False; li_ErrMode := SetErrorMode(SEM_FAILCRITICALERRORS); try ls_Data := gfnsWideToUtf8(sText); lh_Handle := CreateFileW( PWideChar(sFile), //ファイル名 GENERIC_WRITE, //アクセスモード 0, //共有モード nil, //セキュリティ CREATE_ALWAYS, //作成方法 FILE_ATTRIBUTE_NORMAL, //ファイル属性 0 //テンプレート ); try WriteFile(lh_Handle, #$EF#$BB#$BF, 3, li_Size, nil); WriteFile(lh_Handle, PAnsiChar(ls_Data)^, Length(ls_Data), li_Size, nil); Result := True; finally CloseHandle(lh_Handle); end; except end; SetErrorMode(li_ErrMode); end; procedure TMyDebug_Form.SaveLog; {2008-12-20: ログをUTF-8でファイルへ保存 } begin F_SaveFile(F_sLogFile, gfnsUtf7ToWide(MyDebug_Form.F_slInfoList.Text)); end; //クリア procedure TMyDebug_Form.btnClearClick(Sender: TObject); begin Clear; end; //ログ書き出し procedure TMyDebug_Form.btnWriteLogClick(Sender: TObject); begin // gpcLogSave; if (SaveDialog1.Execute) then begin F_sLogFile := SaveDialog1.FileName; SaveLog; end; end; procedure TMyDebug_Form.Button_CopyClick(Sender: TObject); //コピー begin gpcStrToClipboard(gfnsUtf7ToWide(MyDebug_Form.F_slInfoList.Text)); end; //閉じる procedure TMyDebug_Form.btnCloseClick(Sender: TObject); begin Close; end; procedure TMyDebug_Form.edtMessageChange(Sender: TObject); begin if (chkPause.Checked) then begin Exit; end; //edtMessage.TextはUTF-7に変換された文字列 F_slInfoList.Add(edtMessage.Text); if (F_slInfoList.Count > F_iMaxLine) then begin F_slInfoList.Delete(0); end else begin celInfo.RowCount := F_slInfoList.Count; celInfo.TopRow := gfniGridLastPageTopRow(celInfo); end; celInfo.Repaint; end; //WideString対応の描画 procedure TMyDebug_Form.celInfoDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); var lrc_Rect: TRect; begin lrc_Rect := Rect; with celInfo.Canvas do begin if (gdSelected in State) then begin Brush.Color := clHighlight; Font.Color := clHighlightText; end else begin Brush.Color := celInfo.Color; Font.Color := celInfo.Font.Color; // Font.Assign(celInfo.Font); end; FillRect(lrc_Rect); if (F_slInfoList.Count > ARow) then begin Inc(lrc_Rect.Left, lciMARGIN); DrawTextW(Handle, PWideChar(gfnsUtf7ToWide(F_slInfoList[ARow])), -1, lrc_Rect, DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE); end; end; end; procedure TMyDebug_Form.mniPList_CopyClick(Sender: TObject); var ls_Text : WideString; begin //行コピー if (celInfo.Row >= 0) then begin if (gfnbKeyState(VK_SHIFT)) then begin ls_Text := gfnsUtf7ToWide(F_slInfoList.Text); end else begin ls_Text := gfnsUtf7ToWide(F_slInfoList[celInfo.Row]); end; gpcStrToClipboard(ls_Text); if (gfnbKeyState(VK_CONTROL)) then begin if (F_SaveFile(F_sWorkFile, ls_Text)) then begin gpcExecute(F_sWorkFile); end; end; end; end; procedure TMyDebug_Form.actKey_DownExecute(Sender: TObject); var li_Key: WORD; l_Shift: TShiftState; begin // if (lstPlayList.Focused) and (Sender is TAction) then begin if (Screen.ActiveForm = Self) and (Sender is TAction) then begin ShortCutToKey(TAction(Sender).ShortCut, li_Key, l_Shift); Screen.ActiveControl.Perform(WM_KEYDOWN, WPARAM(li_Key), 0); // Screen.ActiveControl.Perform(WM_KEYUP, WPARAM(li_Key), 0); end; end; procedure TMyDebug_Form.actKey_PressExecute(Sender: TObject); var li_Key: WORD; l_Shift: TShiftState; // lh_Handle: HWND; begin if (Screen.ActiveForm = Self) and (Sender is TAction) then begin ShortCutToKey(TAction(Sender).ShortCut, li_Key, l_Shift); { //将来エディットボックスなどを貼り付けた場合に必要 if (Screen.ActiveForm = Self) and (Sender is TAction) then begin ShortCutToKey(TAction(Sender).ShortCut, li_Key, l_Shift); if (Screen.ActiveControl is TMyCustomEdit) then begin if (Screen.ActiveControl is TMyEdit) then begin lh_Handle := TMyEdit(Screen.ActiveControl).Edit.Handle; end else if (Screen.ActiveControl is TMyMemo) then begin lh_Handle := TMyMemo(Screen.ActiveControl).Memo.Handle; end else begin lh_Handle := 0; end; if (lh_Handle <> 0) then begin if (gfnbKeyState(VK_SHIFT)) or (li_Key = $20) then begin //大文字もしくはスペース SendMessage(lh_Handle, WM_CHAR, WPARAM(Char(li_Key)), 0); //小文字 end else begin SendMessage(lh_Handle, WM_CHAR, WPARAM(Char(li_Key - (Ord('A') - Ord('a')))), 0); end; end; end else begin Screen.ActiveControl.Perform(WM_KEYDOWN, WPARAM(li_Key), 0); end; end; } Screen.ActiveControl.Perform(WM_KEYDOWN, WPARAM(li_Key), 0); end; end; end.