unit _myDebug; {$DEFINE MSG_MODE} { デバッグ用出力フォーム。 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, System.Actions; type TMyDebug_Form = class(TForm) Panel_Cmd: TPanel; CheckBox_Pause: TCheckBox; Button_Clear: TButton; Button_Close: 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; MenuItem_PList_Copy: TMenuItem; StringGrid_Info: TStringGrid; Edit_Message: TEdit; 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 Button_ClearClick (Sender: TObject); procedure Button_CloseClick (Sender: TObject); procedure StringGrid_InfoDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); procedure Edit_MessageChange(Sender: TObject); procedure MenuItem_PList_CopyClick(Sender: TObject); private { Private 宣言 } FbProcessMessages : Boolean; //Application.ProcessMessages を呼ぶか FiMaxLine : Integer; //ログ保存行数 FInfoList : TStrings; public { Public 宣言 } procedure Clear; property ProcessMessages: Boolean read FbProcessMessages write FbProcessMessages; property MaxLine: Integer read FiMaxLine write FiMaxLine; end; {$IFDEF MSG_MODE} //メッセージモード //専用の別プログラムに出力 procedure gpcMessageModeSet(bMode: Boolean = True); procedure gpcExeMode; {$ENDIF} procedure gpcDebug(Value: array of Variant); overload; procedure gpcDebug; overload; procedure gpcDebug(Value: Variant); overload; procedure gpcDebug(Value1, Value2: Variant); overload; //String 複数行対応 procedure gpcDebugText(sMsg, sText: String); overload; procedure gpcDebugText(sText: String); overload; //TStrings procedure gpcDebug (AList: TStrings); overload; procedure gpcDebugUTF7Strings(AList: TStrings); overload; procedure gpcDebugUTF8Strings(AList: TStrings); overload; //Dump procedure gpcDebugDump(sMsg : String; sStr : AnsiString); overload; procedure gpcDebugDump( sStr : AnsiString); overload; procedure gpcDebugDump(sMsg : String; pStr : PAnsiChar; iCount : Integer); overload; procedure gpcDebugDump( pStr : PAnsiChar; iCount : Integer); overload; //Bin procedure gpcDebugBin(iNum: Integer); overload; //ControlState procedure gpcDebug(sMsg: String; csState: TControlState); overload; //procedure gpcDebug(csState: TControlState); overload; //ComponentState procedure gpcDebug(sMsg: String; csState: TComponentState); overload; //procedure gpcDebug(csState: TComponentState); overload; //TOwnerDrawState procedure gpcDebug(sMsg: String; odState: TOwnerDrawState); overload; //procedure gpcDebug(odState: TOwnerDrawState); overload; //TRect function gfnsRectString(rcValue : TRect) : String; procedure gpcDebug(sMsg: String; rcValue: TRect); overload; procedure gpcDebug(rcValue: TRect); overload; procedure gpcDebug(sMsg: String; rcValue: TRect; sMsg2: String); overload; //TPoint function gfnsPointString(ptValue : TPoint) : String; procedure gpcDebugPoint(sMsg : String; ptValue : array of TPoint); overload; procedure gpcDebugPoint( ptValue : array of TPoint); overload; procedure gpcDebug(sMsg : String; ptValue : TPoint); overload; procedure gpcDebug( ptValue : TPoint); overload; //TGridRect procedure gpcDebug(sMsg: String; rcRect: TGridRect); overload; procedure gpcDebug(rcRect: TGridRect); overload; //TGridCoord procedure gpcDebug(sMsg: String; GridCoord: TGridCoord); overload; procedure gpcDebug(GridCoord: TGridCoord); overload; //TMessage procedure gpcDebug(rValue: TMessage); overload; procedure gpcDebug(sMsg: String; rValue: TMessage); overload; //TMsg //procedure gpcDebug(rValue: TMsg); overload; //procedure gpcDebug(sMsg: String; rValue: TMsg); overload; procedure gpcDebug(rValue: tagMSG); overload; procedure gpcDebug(sMsg: String; rValue: tagMSG); overload; //ウィンドウメッセージ function gfnsWM_MessageString(iMessage: Cardinal): String; procedure gpcDebugWM_Message(iMessage: Cardinal); //THitTests function gfnsHitTestString(iValue : LRESULT) : String; overload; function gfnsHitTestString(htValue : THitTests) : String; overload; procedure gpcDebugHitTest(sMsg : String; htValue : THitTests); overload; procedure gpcDebugHitTest( htValue : THitTests); overload; //クリップボードのフォーマット function gfnsDebugClipboardFormat(iFormat: Word): String; procedure gpcDebugClipboardFormat; //ActionListのGroupIndexを羅列 procedure gpcDebugActionListGroupIndex(AActionList: TActionList); //------------------------------------------------------------------------------ //procedure gpcDebugAdds(sStrs: array of String); overload; //procedure gpcDebugIntAdds(iNums: array of DWORD); overload; procedure gpcDebugIntAdds(sMsg: String; iNums: array of Int64); overload; procedure gpcDebugIntAdds(iNums: array of Int64); overload; //String procedure gpcDebugAdd(sMsg, sValue: String); overload; procedure gpcDebugAdd(sValue: String); overload; //Int64 procedure gpcDebugAdd(sMsg: String; iValue: Int64); overload; procedure gpcDebugAdd(iValue: Int64); overload; //Extended procedure gpcDebugAdd(sMsg: String; fValue: Extended); overload; procedure gpcDebugAdd(fValue: Extended); overload; //Boolean procedure gpcDebugAdd(sMsg: String; bValue: Boolean); overload; procedure gpcDebugAdd(bValue: Boolean); overload; //Pointer procedure gpcDebugAdd(sMsg: String; pAddr: Pointer); overload; procedure gpcDebugAdd(pAddr: Pointer); overload; //TFileTime procedure gpcDebugAdd(sMsg: String; rValue: TFileTime); overload; procedure gpcDebugAdd(rValue: TFileTime); overload; //TShiftState procedure gpcDebugAdd(sMsg: String; ssState: TShiftState); overload; procedure gpcDebugAdd(ssState: TShiftState); overload; //TCustomDrawState procedure gpcDebugAdd(sMsg: String; cdsState: TCustomDrawState); overload; procedure gpcDebugAdd(cdsState: TCustomDrawState); overload; //TCustomDrawStage procedure gpcDebugAdd(sMsg: String; cdStage: TCustomDrawStage); overload; procedure gpcDebugAdd(cdStage: TCustomDrawStage); overload; //TSize procedure gpcDebugAdd(sMsg: String; szValue: TSize); overload; procedure gpcDebugAdd(szValue: TSize); overload; //TScrollCode procedure gpcDebugAdd(sMsg: String; scCode: TScrollCode); overload; procedure gpcDebugAdd(scCode: TScrollCode); overload; //TGridDrawState procedure gpcDebugAdd(sMsg: String; gdCode: TGridDrawState); overload; procedure gpcDebugAdd(gdCode: TGridDrawState); overload; //TColor //TColorは別にしないと、Integerを引数に取るgpcDebugAdd実行するとスタックオーバーフローするのでアウト procedure gpcDebugAddColor(clColor: TColor); overload; procedure gpcDebugAddColor(sMsg: String; clColor: TColor); overload; //整数16進表示 procedure gpcDebugAddIntToHex(iValue: Int64); overload; procedure gpcDebugAddIntToHex(sMsg: String; iValue: Int64); overload; //ダンプ procedure gpcDebugAddPCharToDump(pStr: PAnsiChar; iCount: Integer); overload; procedure gpcDebugAddPCharToDump(sMsg: String; pStr: PAnsiChar; iCount: Integer); overload; //PowerBroadcast procedure gpcDebugAddPowerBroadcast(Msg: TMessage); overload; procedure gpcDebugAddPowerBroadcast(sMsg: String; Msg: TMessage); overload; //TMediaPlayer //TMPModes procedure gpcDebugAdd(mpMode: TMPModes); overload; procedure gpcDebugAdd(sMsg: String; mpMode: TMPModes); overload; //TMPNotifyValues procedure gpcDebugAdd(nvValue: TMPNotifyValues); overload; procedure gpcDebugAdd(sMsg: String; nvValue: TMPNotifyValues); overload; //.lnkの情報 procedure gpcDebugAddLinkInfo(sLink: String); //------------------------------------------------------------------------------ //メッセージ出力 //String procedure gpcDebugShowMessage(sStr: String); overload; procedure gpcDebugShowMessage(sMsg, sStr: String); overload; //Int64 procedure gpcDebugShowMessage(sStr: String; iValue: Int64); overload; procedure gpcDebugShowMessage(iValue: Int64); overload; //Boolean procedure gpcDebugShowMessage(sMsg: String; bBool: Boolean); overload; procedure gpcDebugShowMessage(bBool: Boolean); overload; //ダンプ procedure gpcDebugShowMessagePCharToDump(pStr: PAnsiChar; iCount: Integer); overload; procedure gpcDebugShowMessagePCharToDump(sMsg: String; 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 gpcShow; //ベンチマーク procedure gpcBenchmarkStart; procedure gpcBenchmarkEnd; overload; procedure gpcBenchmarkEnd(sMsg: String); overload; //------------------------------------------------------------------------------ var MyDebug_Form: TMyDebug_Form; implementation uses ActiveX, Clipbrd, ComObj, ShlObj, ShellAPI, TlHelp32, Variants, System.Types; {$R *.dfm} //============================================================================== const lciMARGIN = 2; var //ベンチマーク用 liStart, liEnd: DWORD; {$IFDEF MSG_MODE} G_bMsgMode: Boolean = False; {$ENDIF} //------------------------------------------------------------------------------ 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: String): String; {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 _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(@_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([String(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: String); {2007-10-04,2011-06-23: sFileを実行する } var l_Info : TShellExecuteInfo; lh_Process : THandle; lh_Window : HWND; begin FillChar(l_Info, SizeOf(l_Info), 0); l_Info.cbSize := SizeOf(l_Info); l_Info.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_Info.lpFile := PChar(sFile); end; l_Info.nShow := SW_SHOWNORMAL; if (ShellExecuteEx(@l_Info)) then begin lh_Process := l_Info.hProcess; end else begin lh_Process := 0; end; 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: String): 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: String); {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 String); //すべてのメッセージ出力処理を最終的にこの手続きで行う {$IFDEF MSG_MODE} function _WideToUtf7(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; {$ENDIF} var i{, li_Del}: Integer; ls_Text : String; lh_Handle : HWND; lb_DoCreate : Boolean; begin if (Application.Terminated) {$IFDEF MSG_MODE} and not(G_bMsgMode) {$ENDIF} 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; {$IFDEF MSG_MODE} 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(_WideToUTF7(ls_Text)))); end; //ここでルーチン終了 Exit; end; {$ENDIF} if not(Assigned(MyDebug_Form)) then begin MyDebug_Form := TMyDebug_Form.Create(Application); end else begin lb_DoCreate := True; for i := 0 to Screen.FormCount-1 do begin if (Screen.Forms[i] is TMyDebug_Form) then begin lb_DoCreate := False; Break; end; end; if (lb_DoCreate) then begin MyDebug_Form := TMyDebug_Form.Create(Application); end; end; SendMessage(MyDebug_Form.Edit_Message.Handle, WM_SETTEXT, 0, LPARAM(PChar(ls_Text))); // MyDebug_Form.Visible := True; SetWindowPos(MyDebug_Form.Handle, HWND_TOP, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_SHOWWINDOW); end; procedure gpcDebug(Value: array of Variant); overload; var ls_Arg : array of String; i : Integer; begin SetLength(ls_Arg, High(Value) +1); for i := 0 to High(Value) do begin ls_Arg[i] := String(VarAsType(Value[i], varOleStr)); end; gpcDebugAdds(ls_Arg); end; procedure gpcDebug(Value: Variant); begin gpcDebugAdd(String(VarAsType(Value, varOleStr)), ''); end; procedure gpcDebug(Value1, Value2: Variant); begin gpcDebugAdd(String(VarAsType(Value1, varOleStr)), String(VarAsType(Value2, varOleStr))); end; //改行 procedure gpcDebug; begin gpcDebugAdd(''); end; //String 複数行対応 procedure gpcDebugText(sMsg, sText: String); begin gpcDebug(sMsg); gpcDebugText(sText); end; procedure gpcDebugText(sText: String); const lcs_CR = #$D; lcs_LF = #$A; var i : Integer; li_Len : Integer; ls_Line : String; 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) : String; begin Result := Format('(%d,%d,%d,%d)', [rcValue.Left, rcValue.Top, rcValue.Right, rcValue.Bottom]); end; procedure gpcDebug(sMsg: String; rcValue: TRect); begin gpcDebug(sMsg, gfnsRectString(rcValue)); end; procedure gpcDebug(rcValue: TRect); begin gpcDebug('', rcValue); end; procedure gpcDebug(sMsg: String; rcValue: TRect; sMsg2: String); begin with rcValue do begin gpcDebug([sMsg, gfnsRectString(rcValue), sMsg2]); end; end; //TGridRect procedure gpcDebug(sMsg: String; 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) : String; begin Result := Format('(%d,%d)', [ptValue.X, ptValue.Y]); end; procedure gpcDebugPoint(sMsg: String; ptValue: array of TPoint); var i : Integer; ls_Value : String; begin ls_Value := ''; for i := 0 to High(ptValue) do begin ls_Value := Format('%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: String; ptValue: TPoint); begin gpcDebug(sMsg, gfnsPointString(ptValue)); end; procedure gpcDebug(ptValue: TPoint); begin gpcDebug('', ptValue); end; //TGridCoord procedure gpcDebug(sMsg: String; GridCoord: TGridCoord); begin gpcDebug(sMsg, Point(GridCoord.X, GridCoord.Y)); end; procedure gpcDebug(GridCoord: TGridCoord); begin gpcDebug('', GridCoord); end; //TStrings procedure gpcDebug(AList: TStrings); var i: Integer; begin for i := 0 to AList.Count - 1 do begin gpcDebug([i, AList[i]]); end; end; //UTF7 procedure gpcDebugUTF7Strings(AList: TStrings); function _Utf7ToWide(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; var i: Integer; begin for i := 0 to AList.Count - 1 do begin gpcDebug([i, _Utf7ToWide(AnsiString(AList[i]))]); end; end; procedure gpcDebugUTF8Strings(AList: TStrings); function _UTF8ToWide(sSrc: AnsiString): 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; var i: Integer; begin for i := 0 to AList.Count - 1 do begin gpcDebug([i, _Utf8ToWide(AnsiString(AList[i]))]); end; end; //Dump procedure gpcDebugDump(sMsg: String; sStr: AnsiString); {,2011-05-16: 2011-05-16:1365文字以上位になるとアクセス違反の例外が起きていたので1024文字までに制限。 } const lci_MAX = 1024; var i : Integer; li_Count : Integer; ls_Str : String; 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 := Format('%s %.2x', [ls_Str, Ord(sStr[i])]); end; gpcDebug(sMsg, ls_Str); end; procedure gpcDebugDump(sStr: AnsiString); begin gpcDebugDump('', sStr); end; procedure gpcDebugDump(sMsg : String; pStr: PAnsiChar; iCount: Integer); var i : Integer; ls_Str : String; begin ls_Str := ''; for i := 0 to iCount -1 do begin ls_Str := Format('%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: String; begin ls_Str := ''; ls_Hex := Format('%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: String; iNums: array of Int64); var i: Integer; ls_Text: String; 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; //String procedure gpcDebugAdd(sMsg, sValue: String); begin gpcDebugAdds([sMsg, sValue]); end; procedure gpcDebugAdd(sValue: String); begin gpcDebugAdd('', sValue); end; //整数 procedure gpcDebugAdd(iValue: Int64); begin gpcDebugAdd('', iValue); end; procedure gpcDebugAdd(sMsg: String; iValue: Int64); begin gpcDebugAdd(sMsg, IntToStr(iValue)); end; //浮動小数点 procedure gpcDebugAdd(fValue: Extended); begin gpcDebugAdd('', fValue); end; procedure gpcDebugAdd(sMsg: String; fValue: Extended); begin gpcDebugAdd(sMsg, WideFormat('%f', [fValue])); end; //真偽 procedure gpcDebugAdd(bValue: Boolean); begin gpcDebugAdd('', bValue); end; procedure gpcDebugAdd(sMsg: String; 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: String; 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: String; 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: String; ssState: TShiftState); var ls_State: String; 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: String; cdsState: TCustomDrawState); overload; var ls_State: String; 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: String; cdStage: TCustomDrawStage); overload; var ls_Stage: String; 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) : String; 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) : String; var ls_State: String; 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: String; htValue: THitTests); begin gpcDebug(sMsg, gfnsHitTestString(htValue)); end; procedure gpcDebugHitTest(htValue: THitTests); begin gpcDebugHitTest('', htValue); end; //クリップボードのフォーマット function gfnsDebugClipboardFormat(iFormat: Word): String; 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; //ActionListのGroupIndexを羅列 procedure gpcDebugActionListGroupIndex(AActionList: TActionList); var i : Integer; l_Action : TAction; lb_Group : Boolean; begin //AIU if (AActionList = nil) then begin Exit; end; lb_Group := False; for i := 0 to AActionList.ActionCount -1 do begin l_Action := TAction(AActionList.Actions[i]); if (l_Action.GroupIndex <> 0) then begin lb_Group := True; gpcDebug([l_Action.Name, l_Action.GroupIndex, l_Action.Checked]); end; end; if not(lb_Group) then begin gpcDebug('GroupIndexはすべて0'); end; end; //TMPModes procedure gpcDebugAdd(mpMode: TMPModes); overload; begin gpcDebugAdd('', mpMode); end; procedure gpcDebugAdd(sMsg: String; mpMode: TMPModes); overload; var ls_Str: String; 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: String; nvValue: TMPNotifyValues); overload; var ls_Str: String; 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: String; 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: String; 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) : String; 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: String; szValue: TSize); begin with szValue do begin gpcDebugAdd(sMsg, WideFormat('%d %d', [cx, cy])); end; end; //ControlState procedure gpcDebug(sMsg: String; csState: TControlState); var ls_State: String; 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: String; csState: TComponentState); var ls_State: String; 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: String; odState: TOwnerDrawState); var ls_State: String; 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: String; scCode: TScrollCode); var ls_Code: String; 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: String; gdCode: TGridDrawState); overload; var ls_Code: String; 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: String; iValue: Int64); begin gpcDebugAdd(sMsg, WideFormat('%x', [iValue])); end; procedure gpcDebugAddPCharToDump(pStr: PAnsiChar; iCount: Integer); begin gpcDebugAddPCharToDump('', pStr, iCount); end; procedure gpcDebugAddPCharToDump(sMsg: String; pStr: PAnsiChar; iCount: Integer); var i: Integer; ls_Str: String; 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: String; 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: String; Msg: TMessage); var ls_Msg: String; 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: String); 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', String(lp_Buff)); lI_ShellLink.GetDescription(lp_Buff, MAX_PATH); gpcDebugAdd(' GetDescription', String(lp_Buff)); lI_ShellLink.GetWorkingDirectory(lp_Buff, MAX_PATH); gpcDebugAdd(' GetWorkingDirectory', String(lp_Buff)); lI_ShellLink.GetArguments(lp_Buff, MAX_PATH); gpcDebugAdd(' GetArguments', String(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', String(lp_Buff), IntToStr(li_Icon)]); finally FreeMem(lp_Buff); end; end; end; end; //------------------------------------------------------------------------------ //メッセージ出力 procedure gpcDebugShowMessage(sMsg, sStr: String); begin MessageBoxW(Application.Handle, PWideChar(sMsg + ' ' + sStr), '再開', MB_SETFOREGROUND or MB_OK); end; procedure gpcDebugShowMessage(sStr: String); begin gpcDebugShowMessage('', sStr); end; //Int64 procedure gpcDebugShowMessage(sStr: String; iValue: Int64); overload; begin gpcDebugShowMessage(sStr + ' ' + IntToStr(iValue)); end; procedure gpcDebugShowMessage(iValue: Int64); overload; begin gpcDebugShowMessage('', iValue); end; //Boolean procedure gpcDebugShowMessage(sMsg: String; bBool: Boolean); var ls_Bool: String; 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: String; pStr: PAnsiChar; iCount: Integer); var i : Integer; ls_Str : String; begin ls_Str := ''; for i := 0 to iCount -1 do begin ls_Str := Format('%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.CheckBox_Pause.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; {$IFDEF MSG_MODE} //メッセージモード //専用の別プログラムに出力 procedure gpcMessageModeSet(bMode: Boolean = True); begin G_bMsgMode := bMode; end; procedure gpcExeMode; begin gpcMessageModeSet(True); end; {$ENDIF} 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: String); begin liEnd := GetTickCount; gpcDebug(sMsg, liEnd - liStart); end; //------------------------------------------------------------------------------ procedure TMyDebug_Form.FormCreate(Sender: TObject); begin FInfoList := TStringList.Create; Constraints.MinHeight := Height; Constraints.MinWidth := Width; StringGrid_Info.Align := alClient; StringGrid_Info.Canvas.Font.Assign(StringGrid_Info.Font); FbProcessMessages := True; FiMaxLine := 2000; 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 FInfoList.Free; end; procedure TMyDebug_Form.FormResize(Sender: TObject); begin StringGrid_Info.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 MenuItem_PList_CopyClick(nil); end; end; end; end; procedure TMyDebug_Form.Clear; begin FInfoList.Clear; StringGrid_Info.RowCount := 1; StringGrid_Info.Repaint; end; //クリア procedure TMyDebug_Form.Button_ClearClick(Sender: TObject); begin Clear; end; //閉じる procedure TMyDebug_Form.Button_CloseClick(Sender: TObject); begin Close; end; procedure TMyDebug_Form.Edit_MessageChange(Sender: TObject); begin if (CheckBox_Pause.Checked) then begin Exit; end; FInfoList.Add(Edit_Message.Text); if (FInfoList.Count > FiMaxLine) then begin FInfoList.Delete(0); end else begin StringGrid_Info.RowCount := FInfoList.Count; StringGrid_Info.TopRow := gfniGridLastPageTopRow(StringGrid_Info); end; StringGrid_Info.Repaint; end; procedure TMyDebug_Form.StringGrid_InfoDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); var lrc_Rect: TRect; begin lrc_Rect := Rect; with StringGrid_Info.Canvas do begin if (gdSelected in State) then begin Brush.Color := clHighlight; Font.Color := clHighlightText; end else begin Brush.Color := StringGrid_Info.Color; Font.Color := StringGrid_Info.Font.Color; // Font.Assign(StringGrid_Info.Font); end; FillRect(lrc_Rect); if (FInfoList.Count > ARow) then begin Inc(lrc_Rect.Left, lciMARGIN); DrawText(Handle, PChar(FInfoList[ARow]), -1, lrc_Rect, DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE); end; end; end; procedure TMyDebug_Form.MenuItem_PList_CopyClick(Sender: TObject); var ls_Text : String; begin //行コピー if (StringGrid_Info.Row >= 0) then begin if (gfnbKeyState(VK_SHIFT)) then begin ls_Text := FInfoList.Text; end else begin ls_Text := FInfoList[StringGrid_Info.Row]; end; gpcStrToClipboard(ls_Text); end; end; procedure TMyDebug_Form.actKey_DownExecute(Sender: TObject); var li_Key : WORD; l_Shift : TShiftState; 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); 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.