dbugintf.pas

大家是不是为不知道如何在VB学到绝地程序

unit dbugintf;

interface

uses
  Windows, SysUtils, Messages, Forms, Registry, Dialogs;

procedure SendDebugEx(Msg: string; MType: TMsgDlgType);
procedure SendDebug(Msg: string);
procedure ClearDebug;
function StartDebugWin: hWnd;

implementation

function StartDebugWin: hWnd;
var
  RegIni: TRegIniFile;
  Count: Integer;
  Filename: string;
begin
  Result := 0;
  Count := 0;
  RegIni := TRegIniFile.Create('\Software\GExperts');
  try
    Filename := RegIni.ReadString('Debug', 'FilePath', '');
  finally
    RegIni.Free;
  end;
  if FileName <> '' then
  begin
    if WinExec(PChar(Filename), SW_SHOW) > 31 then
      while (Result = 0) and (Count < 1000) do
      begin
        Application.ProcessMessages;
        Result := FindWindow('TfmDebug', nil);
        inc(Count);
      end;
  end;
end;

procedure ClearDebug;
var
  CDS: TCopyDataStruct;
  DebugWin: hWnd;
  PMsg: PChar;
begin
  DebugWin := FindWindow('TfmDebug', nil);
  if DebugWin = 0 then
    DebugWin := StartDebugWin;
  if DebugWin <> 0 then
  begin
    CDS.cbData := 7;
    PMsg := StrNew(PChar(' ' + Application.Title + ',Clear'));
    PMsg[0] := #3;
    try
      CDS.lpData := PMsg;
      SendMessage(DebugWin, WM_COPYDATA, 0, LParam(@CDS));
    finally
      StrDispose(PMsg);
    end;
  end;
end;

procedure SendDebugEx(Msg: string; MType: TMsgDlgType);
var
  CDS: TCopyDataStruct;
  DebugWin: hWnd;
  PMsg: PChar;

  procedure CopyMessage;
  var
    i: Integer;
  begin
    PMsg[0] := #1;
    PMsg[1] := Char(ord(MType) + 1); {Add 1 to avoid 0}
    for i := 1 to length(Msg) do
      PMsg[1 + i] := Msg[i];
    PMsg[2 + length(Msg)] := #0; {Terminate string}
  end;

begin
  //Msg := Application.Title + ': ' + Msg;
  DebugWin := FindWindow('TfmDebug', nil);
  if DebugWin = 0 then
    DebugWin := StartDebugWin;
  if DebugWin <> 0 then
  begin
    CDS.cbData := Length(Msg) + 3;
    PMsg := StrAlloc(Length(Msg) + 3);
    try
      CopyMessage;
      CDS.lpData := PMsg;
      SendMessage(DebugWin, WM_COPYDATA, 0, LParam(@CDS));
    finally
      StrDispose(PMsg);
    end;
  end;
end;

procedure SendDebug(Msg: string);
begin
  SendDebugEx(Application.Title + ',' + Msg, mtInformation);
end;

end.