unit myDebug;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, ExtCtrls, Menus;
type
TMyDebug_Form =
class(TForm)
Panel1: TPanel;
btnClear: TButton;
btnClose: TButton;
lstDisp: TListBox;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
procedure FormDestroy(Sender: TObject);
procedure btnClearClick(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 宣言 }
public
{ Public 宣言 }
end;
procedure gpcDebugAdd(
const sValue:
WideString);
overload;
procedure gpcDebugAdd(
const iValue: Integer);
overload;
procedure gpcDebugAdd(
const bValue: Boolean);
overload;
procedure gpcDebugAdd(
const rcValue: TRect);
overload;
procedure gpcDebugAdd(
const ptValue: TPoint);
overload;
procedure gpcDebugAdd(
const sMsg, sValue:
WideString);
overload;
procedure gpcDebugAdd(
const sMsg:
WideString;
const iValue: Integer);
overload;
procedure gpcDebugAdd(
const sMsg:
WideString;
const bValue: Boolean);
overload;
procedure gpcDebugAdd(
const sMsg:
WideString;
const rcValue: TRect);
overload;
procedure gpcDebugAdd(
const sMsg:
WideString;
const ptValue: TPoint);
overload;
var
MyDebug_Form: TMyDebug_Form;
implementation
{$R *.dfm}
//==============================================================================
//WideString⇔String可逆変換関数
const
l_csDEFAULT_CHAR = #1;
l_csPREFIX_CHAR = '$';
{ウムラウトなどのUnicode文字を$+16進に変換して返す}
function gfnsWideToStrEx(
const sWSrc:
WideString):
String;
var
i, li_Pos, li_Len: Integer;
lb_Bool: LongBool;
ls_PStr: PChar;
begin
Result := '';
if (sWSrc <> '')
then begin
li_Len := WideCharToMultiByte(CP_ACP, WC_COMPOSITECHECK
or $400, PWideChar(sWSrc), -1,
nil, 0, l_csDEFAULT_CHAR, @lb_Bool);
ls_PStr := AllocMem(li_Len);
try
li_Len := WideCharToMultiByte(CP_ACP, WC_COMPOSITECHECK
or $400, PWideChar(sWSrc), -1, ls_PStr, li_Len, l_csDEFAULT_CHAR, @lb_Bool);
if (li_Len > 0)
then begin
Dec(li_Len);
i := 0;
//ls_PStr のインデックス
li_Pos := 1;
//sWSrc のインデックス
repeat
if (ls_PStr[i] = l_csPREFIX_CHAR)
then begin
//'%'→'%%'
Result := Result + l_csPREFIX_CHAR + l_csPREFIX_CHAR;
end else if (ls_PStr[i] = l_csDEFAULT_CHAR)
then begin
//'$1'→'%xxxx' xxxx は元の文字の4桁の16進値
Result := Result + l_csPREFIX_CHAR + Format('%0.4x', [Ord(sWSrc[li_Pos])]);
end else begin
Result := Result + ls_PStr[i];
end;
if (IsDBCSLeadByte(Byte(ls_PStr[i])))
then begin
//2バイト文字の先頭バイトなのでもう1バイト足す
Result := Result + ls_PStr[i +1];
Inc(i, 2);
end else begin
Inc(i);
end;
Inc(li_Pos);
until (i >= li_Len);
//untilは条件がTrueで終了
end;
finally
FreeMem(ls_PStr);
end;
end;
end;
{gfnsWideToStrExの逆}
function gfnsStrToWideEx(
const sSrc:
String):
WideString;
var
i: Integer;
li_Len: Integer;
ls_WStr:
WideString;
begin
Result := '';
if (sSrc <> '')
then begin
ls_WStr :=
WideString(sSrc);
li_Len := Length(ls_WStr);
i := 1;
repeat
if (ls_WStr[i] = l_csPREFIX_CHAR)
then begin
//%だった
if (i = li_Len)
then begin
//本来ここにはこない
Result := Result + l_csPREFIX_CHAR;
Break;
end else if (ls_WStr[i +1] = l_csPREFIX_CHAR)
then begin
//%%→%
Result := Result + l_csPREFIX_CHAR;
Inc(i, 2);
end else begin
//%xxxx→対応するUnicode文字
Result := Result + WideChar(StrtoInt('$' + Copy(ls_WStr, i +1, 4)));
Inc(i, 5);
end;
end else begin
Result := Result + ls_WStr[i];
Inc(i);
end;
until (i > li_Len);
end;
end;
{数値の範囲制限}
function gfniNumLimit(
const iNum: Integer; iMin, iMax: Integer): Integer;
var
li_Tmp: Integer;
begin
if (iMin = iMax)
then begin
Result := iMin;
end else begin
//iMinとiMaxの値を間違えて指定したときへの対処
//これがあるので引数にconstをつけない
if (iMin > iMax)
then begin
li_Tmp := iMin;
iMin := iMax;
iMax := li_Tmp;
end;
if (iNum < iMin)
then begin
Result := iMin;
end else if (iNum > iMax)
then begin
Result := iMax;
end else begin
Result := iNum;
end;
end;
end;
//==============================================================================
procedure gpcDebugAdd(
const sValue:
WideString);
begin
gpcDebugAdd('', sValue);
end;
procedure gpcDebugAdd(
const sMsg, sValue:
WideString);
const
lci_MAXDISP = 100;
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
MyDebug_Form.lstDisp.Items.BeginUpdate;
//Unicode文字があっても大丈夫なようにStringに変換してリストに保持
//DrawItemイベントで表示する時に戻す
lstDisp.Items.Add(Format('%s %s', [
gfnsWideToStrEx(sMsg),
gfnsWideToStrEx(sValue)]));
//最後の出力が画面の外に出てしまわないようにTopIndexを調整
lstDisp.TopIndex :=
gfniNumLimit((lstDisp.Count -1) - lstDisp.ClientHeight
div lstDisp.ItemHeight +1, 0, lstDisp.Count -1);
//lci_MAXDISPを超えたら1行古い情報を削除
if (lstDisp.Count > lci_MAXDISP)
then begin
lstDisp.Items.Delete(0);
end;
MyDebug_Form.lstDisp.Items.EndUpdate;
Visible := True;
end;
end;
procedure gpcDebugAdd(
const iValue: Integer);
begin
gpcDebugAdd('', iValue);
end;
procedure gpcDebugAdd(
const sMsg:
WideString;
const iValue: Integer);
begin
gpcDebugAdd(sMsg, Format('%d', [iValue]));
end;
procedure gpcDebugAdd(
const bValue: Boolean);
begin
gpcDebugAdd('', bValue);
end;
procedure gpcDebugAdd(
const sMsg:
WideString;
const 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;
procedure gpcDebugAdd(
const rcValue: TRect);
begin
gpcDebugAdd('', rcValue);
end;
procedure gpcDebugAdd(
const sMsg:
WideString;
const rcValue: TRect);
begin
with rcValue
do begin
gpcDebugAdd(sMsg, Format('%d %d %d %d', [Left, Top, Right, Bottom]));
end;
end;
procedure gpcDebugAdd(
const ptValue: TPoint);
begin
gpcDebugAdd('', ptValue);
end;
procedure gpcDebugAdd(
const sMsg:
WideString;
const ptValue: TPoint);
begin
with ptValue
do begin
gpcDebugAdd(sMsg, Format('%d %d', [X, Y]));
end;
end;
//------------------------------------------------------------------------------
procedure TMyDebug_Form.FormCreate(Sender: TObject);
begin
lstDisp.Align := alClient;
lstDisp.ItemHeight := Trunc(Abs(lstDisp.Font.Height) * 1.4);
Show;
end;
procedure TMyDebug_Form.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action := caFree;
end;
procedure TMyDebug_Form.FormDestroy(Sender: TObject);
begin
MyDebug_Form :=
nil;
end;
//クリア
procedure TMyDebug_Form.btnClearClick(Sender: TObject);
begin
lstDisp.Items.Clear;
end;
//閉じる
procedure TMyDebug_Form.btnCloseClick(Sender: TObject);
begin
Close;
end;
//Unicode対応の描画
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;
//リストに保持する時にgfnsWideToStrExで変換しているのでそれを元に戻してDrawTextWで出力
DrawTextW(Handle, PWideChar(
gfnsStrToWideEx(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.