unit myDebug; { デバッグ用出力フォーム。 1000行までの履歴を表示。 gpcDebugAdds 文字列の複数出力 gpcDebugAdd(Msg, Value) メッセージと値を出力 gpcDebugAdd(Value) 値だけを出力 gpcDebugAdd 空行を出力 gpcDebugAddIntToHex 整数を16で出力 gpcDebugAddPCharToDump 文字列をダンプ出力 gpcDebugAddColor TColorのカラー名を出力 gpcDebugAddWM_Message WM_メッセージを出力 gpcPause ダイアログを出してポーズ gpcLogSave ログファイル保存 gpcBenchmarkStart ベンチマークの開始 gpcBenchmarkEnd gpcBenchmarkStartとの間の処理時間を出力 } {$DEFINE WINDOWSMEDIAPLAYER} //{$DEFINE MSWEBDVD} interface uses Windows, Classes, ComCtrls, Controls, ExtCtrls, Forms, Graphics, Messages, MPlayer, StdCtrls, SysUtils; type TMyDebug_Form = class(TForm) lstDisp: TListBox; pnlCmd: TPanel; btnClear: TButton; btnWriteLog: TButton; btnClose: TButton; procedure FormCreate (Sender: TObject); procedure FormClose (Sender: TObject; var Action: TCloseAction); procedure FormDestroy(Sender: TObject); procedure btnClearClick (Sender: TObject); procedure btnWriteLogClick(Sender: TObject); procedure btnCloseClick (Sender: TObject); procedure lstDispDrawItem (Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); procedure lstDispMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private { Private 宣言 } F_sLogFile: WideString; F_bTopDown: Boolean; //上から下へ記録 F_bProcessMessages: Boolean; //Application.ProcessMessages を呼ぶか F_iMaxLine: Integer; //ログ保存行数 public { Public 宣言 } procedure Clear; procedure SaveLog; property FileName: WideString read F_sLogFile write F_sLogFile; property TopDown: Boolean read F_bTopDown write F_bTopDown; property ProcessMessages: Boolean read F_bProcessMessages write F_bProcessMessages; property MaxLine: Integer read F_iMaxLine write F_iMaxLine; end; //この関数ですべてをまかなう procedure gpcDebugAdds(sStr: array of WideString); overload; //WideString procedure gpcDebugAdd(sValue: WideString); overload; procedure gpcDebugAdd(sMsg, sValue: WideString); overload; //Int64 procedure gpcDebugAdd(iValue: Int64); overload; procedure gpcDebugAdd(sMsg: WideString; iValue: Int64); overload; //Extended procedure gpcDebugAdd(fValue: Extended); overload; procedure gpcDebugAdd(sMsg: WideString; fValue: Extended); overload; //Boolean procedure gpcDebugAdd(bValue: Boolean); overload; procedure gpcDebugAdd(sMsg: WideString; bValue: Boolean); overload; //TRect procedure gpcDebugAdd(rcValue: TRect); overload; procedure gpcDebugAdd(sMsg: WideString; rcValue: TRect); overload; //TPoint procedure gpcDebugAdd(ptValue: TPoint); overload; procedure gpcDebugAdd(sMsg: WideString; ptValue: TPoint); overload; //TString procedure gpcDebugAdd(slList: TStrings); overload; procedure gpcDebugAddUTF7Strings(slList: TStrings); overload; procedure gpcDebugAddMyWStrings(slList: TStrings); overload; //TFileTime procedure gpcDebugAdd(rValue: TFileTime); overload; procedure gpcDebugAdd(sMsg: WideString; rValue: TFileTime); overload; //TShiftState procedure gpcDebugAdd(ssState: TShiftState); overload; procedure gpcDebugAdd(sMsg: WideString; ssState: TShiftState); overload; //TCustomDrawState procedure gpcDebugAdd(cdsState: TCustomDrawState); overload; procedure gpcDebugAdd(sMsg: WideString; cdsState: TCustomDrawState); overload; //THitTests procedure gpcDebugAdd(htValue: THitTests); overload; procedure gpcDebugAdd(sMsg: WideString; htValue: THitTests); overload; //TOwnerDrawState procedure gpcDebugAdd(odState: TOwnerDrawState); overload; procedure gpcDebugAdd(sMsg: WideString; odState: TOwnerDrawState); overload; //TSize procedure gpcDebugAdd(szValue: TSize); overload; procedure gpcDebugAdd(sMsg: WideString; szValue: TSize); overload; //ControlState procedure gpcDebugAdd(csState: TControlState); overload; procedure gpcDebugAdd(sMsg: WideString; csState: TControlState); overload; //ComponentState procedure gpcDebugAdd(csState: TComponentState); overload; procedure gpcDebugAdd(sMsg: WideString; csState: TComponentState); overload; //TScrollCode procedure gpcDebugAdd(scCode: TScrollCode); overload; procedure gpcDebugAdd(sMsg: WideString; scCode: TScrollCode); 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; //TMessage procedure gpcDebugAdd(rValue: TMessage); overload; procedure gpcDebugAdd(sMsg: WideString; rValue: TMessage); overload; //tagMSG procedure gpcDebugAdd(rValue: tagMSG); overload; procedure gpcDebugAdd(sMsg: WideString; rValue: tagMSG); overload; //ウィンドウメッセージ function gfnsWM_MessageToStr(iMessage: Cardinal): WideString; procedure gpcDebugAddWM_Message(iMessage: Cardinal); //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; {$IFDEF WINDOWSMEDIAPLAYER} //TWindowsMediaPlayer function gfnsWMPPlayStateGet(iState: Integer): WideString; function gfnsWMPOpenStateGet(iState: Integer): WideString; procedure gpcDebugAddPlayState(iState: Integer); procedure gpcDebugAddOpenState(iState: Integer); procedure gpcDebugAddIWMPMedia(pdispMedia: IDispatch); {$ENDIF} {$IFDEF MSWEBDVD} //TMSWebDVD function gfnsMSWebDVDMenuEnabledChangeGet(iMenu: Integer): WideString; procedure gpcDebugAddMSWebDVDMenuEnabledChange(sMsg: WideString; iMenu: Integer); overload; procedure gpcDebugAddMSWebDVDMenuEnabledChange(iMenu: Integer); overload; function gfnsMSWebDVDDVDNotifyGet(iCode: Integer): WideString; procedure gpcDebugAddMSWebDVDDVDNotify(sMsg: WideString; iCode: Integer); overload; procedure gpcDebugAddMSWebDVDDVDNotify(iCode: Integer); overload; {$ENDIF} //------------------------------------------------------------------------------ //空行出力 procedure gpcDebugAdd; overload; //クリア procedure gpcDebugClear; //ポーズ procedure gpcPause(sStr: WideString); overload; procedure gpcPause; overload; //保存行数 procedure gpcMaxLineSet(iMax: Integer); //記録の仕方（下に付け足すか上に積み重ねるか） procedure gpcTopDownSet(bBool: Boolean); //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 {$IFDEF WINDOWSMEDIAPLAYER} WMPLib_TLB, {$ENDIF} {$IFDEF MSWEBDVD} MSWEBDVDLib_TLB, {$ENDIF} ShellAPI; {$R *.dfm} //============================================================================== var //ベンチマーク用 liStart, liEnd: DWORD; //------------------------------------------------------------------------------ //UTF-16LE⇔UTF-7 function lfnsWideToAnsi(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 lfnsAnsiToWide(sSrc: AnsiString): WideString; //UTF-7でエンコードされている文字列をWideStringにして返す var li_Len: Integer; lp_Buff: PWideChar; begin li_Len := MultiByteToWideChar(CP_UTF7, 0, PChar(sSrc), -1, nil, 0); lp_Buff := AllocMem((li_Len + 1) * 2); try MultiByteToWideChar(CP_UTF7, 0, PChar(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; //============================================================================== //WideString procedure gpcDebugAdd(sMsg, sValue: WideString); begin gpcDebugAdds([sMsg, sValue]); end; procedure gpcDebugAdd(sValue: WideString); begin gpcDebugAdd('', sValue); end; //文字列 procedure gpcDebugAdds(sStr: array of WideString); //すべてのメッセージ出力処理を最終的にこの手続きで行う var i: Integer; ls_Text: WideString; begin if not(Assigned(MyDebug_Form)) then begin MyDebug_Form := TMyDebug_Form.Create(Application); end; MyDebug_Form.lstDisp.Visible := True; with MyDebug_Form do begin lstDisp.Items.BeginUpdate; try for i := 0 to High(sStr) do begin if (i = 0) then begin ls_Text := sStr[i]; end else begin ls_Text := ls_Text + ' ' + sStr[i]; end; end; //Unicode文字があっても大丈夫なようにStringに変換してリストに保持 //DrawItemイベントで表示する時に戻す if (F_bTopDown) then begin //下に記録 lstDisp.Items.Add(lfnsWideToAnsi(ls_Text)); //lci_MAXDISPを超えたら古い行を削除 if (F_iMaxLine > 0) and (lstDisp.Count > F_iMaxLine) then begin lstDisp.Items.Delete(0); end; //最後の出力が画面の外に出てしまわないようにTopIndexを調整 lstDisp.TopIndex := lfniNumLimit((lstDisp.Count -1) - lstDisp.ClientHeight div lstDisp.ItemHeight +1, 0, lstDisp.Count -1); end else begin //上に記録 lstDisp.Items.Insert(0, lfnsWideToAnsi(ls_Text)); //lci_MAXDISPを超えたら古い行を削除 if (F_iMaxLine > 0) and (lstDisp.Count > F_iMaxLine) then begin lstDisp.Items.Delete(lstDisp.Items.Count -1); end; end; finally MyDebug_Form.lstDisp.Items.EndUpdate; end; Visible := True; //2009-03-01:ProcessMessagesを呼ぶと動作が変わる場合もあるのでOn/Offできるように変更 if (F_bProcessMessages) then begin Beep; Application.ProcessMessages; end; end; 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; //TRect procedure gpcDebugAdd(rcValue: TRect); begin gpcDebugAdd('', rcValue); end; procedure gpcDebugAdd(sMsg: WideString; rcValue: TRect); begin with rcValue do begin gpcDebugAdd(sMsg, WideFormat('(%d,%d,%d,%d)', [Left, Top, Right, Bottom])); end; end; //TPoint procedure gpcDebugAdd(ptValue: TPoint); begin gpcDebugAdd('', ptValue); end; procedure gpcDebugAdd(sMsg: WideString; ptValue: TPoint); begin with ptValue do begin gpcDebugAdd(sMsg, WideFormat('(%d,%d)', [X, Y])); 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; //THitTest; procedure gpcDebugAdd(htValue: THitTests); overload; begin gpcDebugAdd('', htValue); end; procedure gpcDebugAdd(sMsg: WideString; htValue: THitTests); overload; 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 '; gpcDebugAdd(sMsg, WideFormat('[%s]', [TrimRight(ls_State)])); end; //TOwnerDrawState procedure gpcDebugAdd(odState: TOwnerDrawState); overload; begin gpcDebugAdd('', odState); end; procedure gpcDebugAdd(sMsg: WideString; odState: TOwnerDrawState); overload; 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 (odNoAccel in odState) then ls_State := ls_State + 'odNoAccel '; 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 '; gpcDebugAdd(sMsg, WideFormat('[%s]', [TrimRight(ls_State)])); 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 gpcDebugAdd(rValue: TMessage); begin gpcDebugAdd('', rValue); end; procedure gpcDebugAdd(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 gpcDebugAdd(sMsg, WideFormat('Msg($%x) WParam($%x) LParam($%x)', [Msg, WParam, LParam])); end; end; //tagMSG procedure gpcDebugAdd(rValue: tagMSG); begin gpcDebugAdd('', rValue); end; procedure gpcDebugAdd(sMsg: WideString; rValue: tagMSG); { hwnd: HWND; message: UINT; wParam: WPARAM; lParam: LPARAM; time: DWORD; pt: TPoint; } begin with rValue do begin gpcDebugAdd(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_MessageToStr(message)])); end; end; //TStrings procedure gpcDebugAdd(slList: TStrings); var i: Integer; begin for i := 0 to slList.Count - 1 do begin gpcDebugAdd(lfnsAnsiToWide(slList[i])); end; end; //UTF7 procedure gpcDebugAddUTF7Strings(slList: TStrings); overload; function lfns_Utf7ToWide(sSrc: AnsiString): WideString; //UTF-7でエンコードされている文字列をWideStringにして返す var li_Len: Integer; lp_Buff: PWideChar; begin li_Len := MultiByteToWideChar(CP_UTF7, 0, PChar(sSrc), -1, nil, 0); lp_Buff := AllocMem((li_Len + 1) * 2); try MultiByteToWideChar(CP_UTF7, 0, PChar(sSrc), -1, lp_Buff, li_Len); Result := WideString(lp_Buff); finally FreeMem(lp_Buff); end; end; var i: Integer; begin for i := 0 to slList.Count - 1 do begin gpcDebugAdd(lfns_Utf7ToWide(slList[i])); end; end; //TMyWStrings const l_csPREFIX_CHAR = '%'; procedure gpcDebugAddMyWStrings(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 + 1, 4)))); 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 gpcDebugAdd(lfns_AnsiToWideEx(slList[i])); end; 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 gpcDebugAdd(csState: TControlState); begin gpcDebugAdd('', csState); end; procedure gpcDebugAdd(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 '; gpcDebugAdd(sMsg, WideFormat('[%s]', [TrimRight(ls_State)])); end; //ComponentState procedure gpcDebugAdd(csState: TComponentState); begin gpcDebugAdd('', csState); end; procedure gpcDebugAdd(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 '; gpcDebugAdd(sMsg, WideFormat('[%s]', [TrimRight(ls_State)])); 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; //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; function gfnsWM_MessageToStr(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'; $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 := ''; end; end; procedure gpcDebugAddWM_Message(iMessage: Cardinal); begin gpcDebugAdd(WideFormat('%5d %4x %s', [iMessage, iMessage, gfnsWM_MessageToStr(iMessage)])); end; {$IFDEF WINDOWSMEDIAPLAYER} //TWindowsMediaPlayer function gfnsWMPPlayStateGet(iState: Integer): WideString; begin case iState of wmppsUndefined: Result := 'Undefined'; wmppsStopped: Result := 'Stopped'; wmppsPaused: Result := 'Paused'; wmppsPlaying: Result := 'Playing'; wmppsScanForward: Result := 'ScanForward'; wmppsScanReverse: Result := 'ScanReverse'; wmppsBuffering: Result := 'Buffering'; wmppsWaiting: Result := 'Waiting'; wmppsMediaEnded: Result := 'MediaEnded'; wmppsTransitioning: Result := 'Transitioning'; wmppsReady: Result := 'Ready'; wmppsReconnecting: Result := 'Reconnecting'; wmppsLast: Result := 'Last'; end; end; procedure gpcDebugAddPlayState(iState: Integer); begin gpcDebugAdd(WideFormat('PlayState %s', [gfnsWMPPlayStateGet(iState)]), iState); end; function gfnsWMPOpenStateGet(iState: Integer): WideString; begin case iState of wmposUndefined: Result := 'Undefined'; wmposPlaylistChanging: Result := 'PlaylistChanging'; wmposPlaylistLocating: Result := 'PlaylistLocating'; wmposPlaylistConnecting: Result := 'PlaylistConnecting'; wmposPlaylistLoading: Result := 'PlaylistLoading'; wmposPlaylistOpening: Result := 'PlaylistOpening'; wmposPlaylistOpenNoMedia: Result := 'PlaylistOpenNoMedia'; wmposPlaylistChanged: Result := 'PlaylistChanged'; wmposMediaChanging: Result := 'MediaChanging'; wmposMediaLocating: Result := 'MediaLocating'; wmposMediaConnecting: Result := 'MediaConnecting'; wmposMediaLoading: Result := 'MediaLoading'; wmposMediaOpening: Result := 'MediaOpening'; wmposMediaOpen: Result := 'MediaOpen'; wmposBeginCodecAcquisition: Result := 'BeginCodecAcquisition'; wmposEndCodecAcquisition: Result := 'EndCodecAcquisition'; wmposBeginLicenseAcquisition: Result := 'BeginLicenseAcquisition'; wmposEndLicenseAcquisition: Result := 'EndLicenseAcquisition'; wmposBeginIndividualization: Result := 'BeginIndividualization'; wmposEndIndividualization: Result := 'EndIndividualization'; wmposMediaWaiting: Result := 'MediaWaiting'; wmposOpeningUnknownURL: Result := 'OpeningUnknownURL'; end; end; procedure gpcDebugAddOpenState(iState: Integer); begin gpcDebugAdd(WideFormat('OpenState %s', [gfnsWMPOpenStateGet(iState)]), iState); end; procedure gpcDebugAddIWMPMedia(pdispMedia: IDispatch); var i: Integer; begin with IWMPMedia(pdispMedia) do begin gpcDebugAdd('isIdentical', isIdentical[IWMPMedia(pdispMedia)]); gpcDebugAdd('sourceURL', sourceURL); gpcDebugAdd('name', name); gpcDebugAdd('imageSourceWidth', imageSourceWidth); gpcDebugAdd('imageSourceHeight', imageSourceHeight); gpcDebugAdd('markerCount', markerCount); // gpcDebugAdd('getMarkerTime', getMarkerTime); // gpcDebugAdd('getMarkerName', getMarkerName); gpcDebugAdd('duration', duration); gpcDebugAdd('durationString', durationString); gpcDebugAdd('attributeCount', attributeCount); for i := 0 to attributeCount -1 do begin gpcDebugAdd(getAttributeName(i), getItemInfo(getAttributeName(i))); end; end; end; {$ENDIF} {$IFDEF MSWEBDVD} //TMSWebDVD function gfnsMSWebDVDMenuEnabledChangeGet(iMenu: Integer): WideString; begin case iMenu of dvdMenu_Title: Result := 'Title'; dvdMenu_Root: Result := 'Root'; dvdMenu_Subpicture: Result := 'Subpicture'; dvdMenu_Audio: Result := 'Audio'; dvdMenu_Angle: Result := 'Angle'; dvdMenu_Chapter: Result := 'Chapter'; else Result := 'その他'; end; end; procedure gpcDebugAddMSWebDVDMenuEnabledChange(sMsg: WideString; iMenu: Integer); begin gpcDebugAdd(sMsg, gfnsMSWebDVDMenuEnabledChangeGet(iMenu)); end; procedure gpcDebugAddMSWebDVDMenuEnabledChange(iMenu: Integer); begin gpcDebugAddMSWebDVDMenuEnabledChange('', iMenu); end; function gfnsMSWebDVDDVDNotifyGet(iCode: Integer): WideString; begin //DVDイベントコード //257〜283の値になる。 case iCode of 256: Result := 'EC_DVDBASE'; (256 + 1): Result := 'EC_DVD_DOMAIN_CHANGE'; (256 + 2): Result := 'EC_DVD_TITLE_CHANGE'; (256 + 3): Result := 'EC_DVD_CHAPTER_START'; (256 + 4): Result := 'EC_DVD_AUDIO_STREAM_CHANGE'; (256 + 5): Result := 'EC_DVD_SUBPICTURE_STREAM_CHANGE'; (256 + 6): Result := 'EC_DVD_ANGLE_CHANGE'; (256 + 7): Result := 'EC_DVD_BUTTON_CHANGE'; (256 + 8): Result := 'EC_DVD_VALID_UOPS_CHANGE'; (256 + 9): Result := 'EC_DVD_STILL_ON'; (256 + 10): Result := 'EC_DVD_STILL_OFF'; (256 + 11): Result := 'EC_DVD_CURRENT_TIME'; // MSWebDVD では使わない。 (256 + 12): Result := 'EC_DVD_ERROR'; (256 + 13): Result := 'EC_DVD_WARNING'; (256 + 14): Result := 'EC_DVD_CHAPTER_AUTOSTOP'; (256 + 15): Result := 'EC_DVD_NO_FP_PGC'; (256 + 16): Result := 'EC_DVD_PLAYBACK_RATE_CHANGE'; (256 + 17): Result := 'EC_DVD_PARENTAL_LEVEL_CHANGE'; (256 + 18): Result := 'EC_DVD_PLAYBACK_STOPPED'; (256 + 19): Result := 'EC_DVD_ANGLES_AVAILABLE'; (256 + 20): Result := 'EC_DVD_PLAYPERIOD_AUTOSTOP'; (256 + 21): Result := 'EC_DVD_BUTTON_AUTO_ACTIVATED'; (256 + 22): Result := 'EC_DVD_CMD_START'; // MSWebDVD では使わない。 (256 + 23): Result := 'EC_DVD_CMD_END'; // MSWebDVD では使わない。 (256 + 24): Result := 'EC_DVD_DISC_EJECTED'; (256 + 25): Result := 'EC_DVD_DISC_INSERTED'; (256 + 26): Result := 'EC_DVD_CURRENT_HMSF_TIME'; (256 + 27): Result := 'EC_DVD_KARAOKE_MODE'; else Result := IntToStr(iCode); end; end; procedure gpcDebugAddMSWebDVDDVDNotify(sMsg: WideString; iCode: Integer); begin gpcDebugAdd(sMsg, gfnsMSWebDVDDVDNotifyGet(iCode)); end; procedure gpcDebugAddMSWebDVDDVDNotify(iCode: Integer); begin gpcDebugAddMSWebDVDDVDNotify('', iCode); end; {$ENDIF} //------------------------------------------------------------------------------ procedure gpcDebugClear; begin if (Assigned(MyDebug_Form)) then begin myDebug_Form.Clear; end; end; //一時停止 procedure gpcPause(sStr: WideString); begin MessageBoxW(Application.Handle, PWideChar(sStr), '再開', MB_SETFOREGROUND or MB_OK); end; procedure gpcPause; begin gpcPause(''); end; //改行 procedure gpcDebugAdd; begin gpcDebugAdd(''); end; //保存行数 procedure gpcMaxLineSet(iMax: Integer); begin if not(Assigned(MyDebug_Form)) then begin MyDebug_Form := TMyDebug_Form.Create(Application); end; MyDebug_Form.MaxLine := iMax; end; //記録の仕方 procedure gpcTopDownSet(bBool: Boolean); begin if not(Assigned(MyDebug_Form)) then begin MyDebug_Form := TMyDebug_Form.Create(Application); end; MyDebug_Form.TopDown := bBool; end; //Application.ProcessMessagesを呼ぶか procedure gpcProcessMessages(bBool: Boolean); begin if not(Assigned(MyDebug_Form)) then begin MyDebug_Form := TMyDebug_Form.Create(Application); end; MyDebug_Form.ProcessMessages := bBool; end; //ログ保存 procedure gpcLogFileSet(sFileName: WideString); {2008-02-11: 表示内容を保存するファイルを設定 空文字で保存しない } begin if not(Assigned(MyDebug_Form)) then begin MyDebug_Form := TMyDebug_Form.Create(Application); end; MyDebug_Form.FileName := sFileName; end; procedure gpcLogFileInit; begin end; procedure gpcLogSave; {2008-02-11,12-20: ログをUTF-8でファイルへ保存 2008-12-20:Unicode対応。保存はUTF-8。 } begin MyDebug_Form.SaveLog; end; procedure gpcShow; {2008-02-11: 表示 } begin if not(Assigned(MyDebug_Form)) then begin MyDebug_Form := TMyDebug_Form.Create(Application); end; 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; gpcDebugAdd(liEnd - liStart); end; procedure gpcBenchmarkEnd(sMsg: WideString); begin liEnd := GetTickCount; gpcDebugAdd(sMsg, liEnd - liStart); end; //------------------------------------------------------------------------------ procedure TMyDebug_Form.FormCreate(Sender: TObject); var lpp_WParam: PPWideChar; li_ParamCount: Integer; begin lstDisp.Align := alClient; lstDisp.ItemHeight := Trunc(Abs(lstDisp.Font.Height) * 1.4); lpp_WParam := CommandLineToArgvW(GetCommandLineW, li_ParamCount); //実行ファイル名+'.debug.log' F_sLogFile := WideString(lpp_WParam^) + '.debug.log'; LocalFree(Cardinal(lpp_WParam)); F_bTopDown := True; F_bProcessMessages := True; F_iMaxLine := 1000; // Show; end; procedure TMyDebug_Form.FormClose(Sender: TObject; var Action: TCloseAction); begin Clear; Action := caHide; end; procedure TMyDebug_Form.FormDestroy(Sender: TObject); begin // MyDebug_Form := nil; end; procedure TMyDebug_Form.Clear; begin lstDisp.Items.Clear; end; procedure TMyDebug_Form.SaveLog; {2008-12-20: ログをUTF-8でファイルへ保存 } var li_Size: DWORD; ls_Str: AnsiString; lh_Handle: THandle; begin //UTF-8 ls_Str := Utf8Encode(lfnsAnsiToWide(MyDebug_Form.lstDisp.Items.Text)); lh_Handle := CreateFileW(PWideChar(F_sLogFile), //ファイル名 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_Str)^, Length(ls_Str), li_Size, nil); finally CloseHandle(lh_Handle); end; end; //クリア procedure TMyDebug_Form.btnClearClick(Sender: TObject); begin Clear; end; //ログ書き出し procedure TMyDebug_Form.btnWriteLogClick(Sender: TObject); begin gpcLogSave; end; //閉じる procedure TMyDebug_Form.btnCloseClick(Sender: TObject); begin Hide; end; //WideString対応の描画 procedure TMyDebug_Form.lstDispDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); const lci_MARGIN = 2; var lrc_Rect: TRect; begin with lstDisp.Canvas do begin lrc_Rect := Rect; FillRect(lrc_Rect); with Rect do begin lrc_Rect.Left := Left + lci_MARGIN; lrc_Rect.Right := Right - lci_MARGIN; end; DrawTextW(Handle, PWideChar(lfnsAnsiToWide(lstDisp.Items[Index])), -1, lrc_Rect, DT_NOPREFIX or DT_VCENTER or DT_EXTERNALLEADING or DT_SINGLELINE); Pen.Color := clBtnFace; MoveTo(Rect.Left, Rect.Bottom -1); LineTo(Rect.Right, Rect.Bottom -1); end; end; procedure TMyDebug_Form.lstDispMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (Button = mbLeft) then begin // http://delfusa.main.jp/delfusafloor/archive/VA009712_take/delphi/kabedel.htm ReleaseCapture; SendMessage(Handle, WM_SYSCOMMAND, SC_SIZE or 9, 0); end; end; end.