terminal.pas

我自己用的Delphi函数单元 具体说明见打包文件的HELP目录下面

unit Terminal;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, StdCtrls, ImgList, ComCtrls, ToolWin, Buttons, ActnList,Shellapi,
  Clipbrd;

const
    WM_MYTRAYICONCALLBACK = WM_USER + 1000;
    UNTITLED_FILE_NAME    = 'Untitled';

type
  TDebugMsgForm = class(TForm)
    mnuMain: TMainMenu;
    mnuFile: TMenuItem;
    mnuExit: TMenuItem;
    mnuHelp: TMenuItem;
    mnuAbout: TMenuItem;
    mnuListen: TMenuItem;
    mnuOperate: TMenuItem;
    mnuTray: TMenuItem;
    mnuNew: TMenuItem;
    mnuOpen: TMenuItem;
    mnuSave: TMenuItem;
    mnuSaveAs: TMenuItem;
    mnuFileBar0: TMenuItem;
    mnuCopy: TMenuItem;
    mnuClear: TMenuItem;
    mnuOperateBar0: TMenuItem;
    mnuOperateBar1: TMenuItem;
    ToolBar: TToolBar;
    lvMessage: TListView;
    cmdNew: TToolButton;
    cmdOpen: TToolButton;
    cmdSave: TToolButton;
    Toolbar0: TToolButton;
    cmdCopy: TToolButton;
    cmdClear: TToolButton;
    cmdListen: TToolButton;
    cmdTray: TToolButton;
    Toolbar2: TToolButton;
    cmdAbout: TToolButton;
    Toolbar1: TToolButton;
    SaveDialog: TSaveDialog;
    OpenDialog: TOpenDialog;
    ActionList: TActionList;
    ActionNew: TAction;
    ActionOpen: TAction;
    ActionSave: TAction;
    ActionSaveAs: TAction;
    ActionExit: TAction;
    ActionCopy: TAction;
    ActionCut: TAction;
    ActionListen: TAction;
    ActionTray: TAction;
    ActionAbout: TAction;
    ImageList: TImageList;
    popMenu: TPopupMenu;
    popMain: TMenuItem;
    popAbout: TMenuItem;
    popbar0: TMenuItem;
    popExit: TMenuItem;
    StatusBar: TStatusBar;
    ActionPaste: TAction;
    mnuPaste: TMenuItem;
    cmdPaste: TToolButton;
    ActionSelectAll: TAction;
    mnuSelectAll: TMenuItem;
    ActionClear: TAction;
    C1: TMenuItem;
    procedure EventNotFinish(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure popMainClick(Sender: TObject);
    procedure ActionAboutExecute(Sender: TObject);
    procedure ActionExitExecute(Sender: TObject);
    procedure ActionListenExecute(Sender: TObject);
    procedure ActionTrayExecute(Sender: TObject);
    procedure ActionNewExecute(Sender: TObject);
    procedure ActionSaveAsExecute(Sender: TObject);
    procedure ActionSaveExecute(Sender: TObject);
    procedure ActionOpenExecute(Sender: TObject);
    procedure ActionCopyExecute(Sender: TObject);
    procedure ActionCutExecute(Sender: TObject);
    procedure ActionPasteExecute(Sender: TObject);
    procedure ActionSelectAllExecute(Sender: TObject);
    procedure lvMessageDblClick(Sender: TObject);
    procedure ActionClearExecute(Sender: TObject);
  private
    fiLoop     : Integer;
    fiNextNo   : Integer;
    fbModify   : Boolean;
    fbListen   : Boolean;
    foTray     : TNotifyIconData;
    fFileName  : String;
    fsCaption  : String;
    foClipboard: TClipboard;

    nTickCount : Integer;

    procedure ShowSelf(bShow:Boolean);
    procedure WMMyTrayIconCallback(var Msg:TMessage); message WM_MYTRAYICONCALLBACK;
    procedure WMSysCommand(var Message: TWMSysCommand); message WM_SysCommand;
    procedure WMCopyData(var Msg: TWMCopyData); message WM_COPYDATA;

    function  DoSaveFile: Boolean;
    function  GetNextNo: Integer;
    procedure ListViewSaveToFile(sFilePath : String; lv : TListView);
    procedure ListViewLoadFromFile(sFilePath : String; lv : TListView);
  public
    { Public declarations }
    procedure DefaultHandler(var Msg); override;
  end;

var
    DebugMsgForm: TDebugMsgForm;
    MessageId: UINT;

implementation

uses about,xTools,xStrings, constant, Detail;

{$R *.DFM}
{$R Tray.Res}

function TDebugMsgForm.GetNextNo: Integer;
var
    n1,n2 : Integer;
begin
    Result := 1 ;
    if lvMessage.Items.Count = 0 then Exit;
    try
        n1:=lvMessage.Items.Count;
        n2:=StrToInt(lvMessage.Items[lvMessage.Items.Count-1].Caption)+1;
        if n1>=n2 then Result := n1
        else Result := n2;
    except
        Result:=lvMessage.Items.Count;
    end;
end;

function TDebugMsgForm.DoSaveFile: Boolean;
var
    YesNo : Integer;
begin
    Result := True;
    if fbModify then
    begin
        YesNo:=YesNoCancelBox('当前文件未保存，是否保存？');
        if YesNo = IDYES then
        begin
            ActionSaveExecute(nil);
            if fbModify then Result := False;
        end;
        if YesNo = IDCANCEL then Result := False;
    end;
end;

procedure TDebugMsgForm.ListViewSaveToFile(sFilePath : String; lv : TListView);
var
    F: TextFile;
    S: string;
    i,hFile: Integer;
begin
    hFile := FileCreate(sFilePath);
    if hFile = -1 then
    begin
        MsgBox('调试信息保存失败。');
        Exit;
    end;
    FileClose(hFile);
    AssignFile(F, sFilePath);
    Rewrite(F);
    with lv do
        for i:=0 to Items.Count-1 do
        begin
            S:=Items[i].Caption+','+Items[i].SubItems[0]+','+Items[i].SubItems[1];
            Writeln(F, S);
        end;
    CloseFile(F);
end;

procedure TDebugMsgForm.ListViewLoadFromFile(sFilePath : String; lv : TListView);
var
    F: TextFile;
    S: string;
    oItem: TListItem;
begin
    AssignFile(F, sFilePath);
    Reset(F);
    lv.Items.Clear;
    while not Eof(F) do
    begin
        Readln(F, S);
        oItem:=lv.Items.Add;
        oItem.Caption:=CutToken(s);
        oItem.SubItems.Add(CutToken(s));
        oItem.SubItems.Add(s);
    end;
    fiNextNo := GetNextNo;
    CloseFile(F);
end;

procedure TDebugMsgForm.WMCopyData(var Msg: TWMCopyData);
var
    s: String;
    oItem: TListItem;
    n : Integer;
begin
    if not fbListen then Exit;
    s:=StrPas(Msg.CopyDataStruct^.lpData);
    with lvMessage do
    begin
        oItem:=Items.Add;
        oItem.Caption:=IntToStr(fiNextNo);

        n :=GetTickCount;
        oItem.SubItems.Add(IntToStr(n - nTickCount));
        nTickCount := n;

        oItem.SubItems.Add(TimeToStr(Now));
        oItem.SubItems.Add(s);
//      Selected:=oItem;
        ItemFocused := oItem;
        Scroll(0,65535);
    end;

    if fiNextNo > 1000 then
    begin
     lvMessage.Items.Clear();
     fiNextNo := 0;
    end;
    Inc(fiNextNo);
    fbModify := True;
    Inc(fiLoop);
    if fiLoop>3 then fiLoop:=0;
    case fiLoop of
    0:  n:=IDI_DEBUG_START;
    1:  n:=IDI_DEBUG_START1;
    2:  n:=IDI_DEBUG_START2;
    3:  n:=IDI_DEBUG_START3;
    else
        n:=IDI_DEBUG_START;
    end;
    foTray.hIcon:=LoadIcon(hInstance,MAKEINTRESOURCE(n));
    foTray.uFlags := NIF_ICON;
    Shell_NotifyIcon(NIM_MODIFY,@foTray);
end;

procedure TDebugMsgForm.EventNotFinish(Sender: TObject);
begin
    Application.MessageBox('事件处理程序...','说明',MB_ICONINFORMATION);
end;

procedure TDebugMsgForm.WMMyTrayIconCallback(var Msg:TMessage);
var
    CursorPos:TPoint;
begin
    case Msg.lParam of
        WM_LBUTTONUP:
        begin
            visible := not visible;
            ShowSelf(visible);
        end;
      //WM_LBUTTONDBLCLK: ShowSelf(True);
      //WM_LBUTTONDOWN  : ShowSelf(False);
        WM_RBUTTONDOWN:
        begin
            GetCursorPos(CursorPos);
            popMenu.Popup(CursorPos.x,CursorPos.y);
        end;
    end;
end;

procedure TDebugMsgForm.FormCreate(Sender: TObject);
begin
    foTray.cbSize:=SizeOf(TNotifyIconData);
    foTray.Wnd:=Handle;
    foTray.uID:=1;
    foTray.uFlags:=NIF_ICON or NIF_TIP or NIF_MESSAGE;
    foTray.uCallbackMessage:=WM_MYTRAYICONCALLBACK;
    //foTray.hIcon:=LoadIcon(0,IDI_WINLOGO);
    foTray.hIcon:=Application.Icon.Handle;
    foTray.szTip:='调试终端';
    Shell_NotifyIcon(NIM_ADD,@foTray);

    foClipboard:= Clipboard;
    fbListen   := True;
    fbModify   := False;
    fFileName  := UNTITLED_FILE_NAME;
    fsCaption  := Caption;
    Caption    := fsCaption+' - '+fFileName;
    fiLoop     := 0;
    StatusBar.SimpleText:='正在监听。';
    fiNextNo := GetNextNo;

    nTickCount := 0; //计数器
end;

procedure TDebugMsgForm.FormDestroy(Sender: TObject);
begin
    Shell_NotifyIcon(NIM_DELETE,@foTray);
end;

procedure TDebugMsgForm.FormShow(Sender: TObject);
begin
//   ShowWindow(GetWindow(Handle,GW_OWNER),SW_HIDE);
end;

procedure TDebugMsgForm.WMSysCommand(var Message: TWMSysCommand);
begin
  if Message.CmdType and $FFF0 = SC_CLOSE then
     ShowSelf(False)
  else
     inherited;
end;

procedure TDebugMsgForm.popMainClick(Sender: TObject);
begin
     ShowSelf(True);
end;

procedure TDebugMsgForm.DefaultHandler(var Msg);
begin
  inherited DefaultHandler(Msg);
  if (TMessage(Msg).Msg <> MessageId) then Exit;
  if TMessage(Msg).wParam = LongInt(Application.Handle) then Exit;
  ReplyMessage(5);
  ShowSelf(True);
end;

procedure TDebugMsgForm.ShowSelf(bShow:Boolean);
begin
     visible:= bShow;
     Application.ShowMainForm:=visible;
     if visible then
     begin
          SetForegroundWindow(DebugMsgForm.Handle);
     end;
end;

procedure TDebugMsgForm.ActionAboutExecute(Sender: TObject);
begin
    AboutForm.ShowModal;
end;

procedure TDebugMsgForm.ActionExitExecute(Sender: TObject);
begin
    if (fFileName = UNTITLED_FILE_NAME) or DoSaveFile then Close;
end;

procedure TDebugMsgForm.ActionListenExecute(Sender: TObject);
begin
    fbListen := not fbListen;
    if fbListen then
    begin
        StatusBar.SimpleText:='正在监听。';
        foTray.hIcon:=LoadIcon(hInstance,MAKEINTRESOURCE(IDI_DEBUG_START));
    end
    else
    begin
        StatusBar.SimpleText:='停止监听。';
        foTray.hIcon:=LoadIcon(hInstance,MAKEINTRESOURCE(IDI_DEBUG_STOP));
    end;
    foTray.uFlags := NIF_ICON;
    Shell_NotifyIcon(NIM_MODIFY,@foTray);
    ActionListen.Checked := fbListen;
end;

procedure TDebugMsgForm.ActionTrayExecute(Sender: TObject);
begin
    //Application.ShowMainForm:= not Application.ShowMainForm;
    ShowSelf(False)
end;

procedure TDebugMsgForm.ActionNewExecute(Sender: TObject);
begin
    if not DoSaveFile then Exit;
    lvMessage.Items.Clear;
    fFileName := UNTITLED_FILE_NAME;
    Caption   := fsCaption+' - '+fFileName;
    fbModify  := False;
    fiNextNo  := GetNextNo;
end;

procedure TDebugMsgForm.ActionSaveAsExecute(Sender: TObject);
begin
  SaveDialog.FileName := fFileName;
  if SaveDialog.Execute then
  begin
    if FileExists(SaveDialog.FileName) then
    begin
       if YesNoBox(SaveDialog.FileName+' 已存在，覆盖吗？') <> IDYES then Exit;
       DeleteFile(SaveDialog.FileName);
    end;
    fFileName := SaveDialog.FileName;
    ListViewSaveToFile(fFileName,lvMessage);
    Caption   := fsCaption+' - '+fFileName;
    fbModify := False;
  end;
end;

procedure TDebugMsgForm.ActionSaveExecute(Sender: TObject);
begin
  if fFileName = UNTITLED_FILE_NAME then
        ActionSaveAsExecute(Sender)
  else
  begin
        if fbModify then ListViewSaveToFile(fFileName,lvMessage);
        fbModify := False;
  end;
end;

procedure TDebugMsgForm.ActionOpenExecute(Sender: TObject);
begin
  if OpenDialog.Execute then
  begin
        if not DoSaveFile then Exit;
        fFileName:=OpenDialog.FileName;
        ListViewLoadFromFile(fFileName,lvMessage);
        Caption   := fsCaption+' - '+fFileName;
        fbModify := False;
  end;
end;

procedure TDebugMsgForm.ActionCopyExecute(Sender: TObject);
var
    s : String;
    i : Integer;
begin
    s := '';
    with lvMessage do
        for i:=0 to Items.Count-1 do
            if Items[i].Selected then
                s:=s+Items[i].Caption+','+Items[i].SubItems[0]+','+Items[i].SubItems[1]+ASC_CRLF;
     foClipboard.SetTextBuf(PChar(s));
end;

procedure TDebugMsgForm.ActionCutExecute(Sender: TObject);
var
    s1,s2 : String;
    i     : Integer;
    oItem : TListItem;
begin
    s1 := '';
    s2 := '';
    with lvMessage do
    begin
        for i:=0 to Items.Count -1 do
            if Items[i].Selected then
               s1:=s1+Items[i].Caption+','+Items[i].SubItems[0]+','+Items[i].SubItems[1]+ASC_CRLF
            else
               s2:=s2+Items[i].Caption+','+Items[i].SubItems[0]+','+Items[i].SubItems[1]+ASC_CRLF;
        Items.Clear;
        while s2 <> '' do
        begin
            oItem:=Items.Add;
            oItem.Caption:=CutToken(s2);
            oItem.SubItems.Add(CutToken(s2));
            oItem.SubItems.Add(FirstToken(s2,ASC_CRLF,True));
        end;
    end;
    foClipboard.SetTextBuf(PChar(s1));
    if fFileName <> UNTITLED_FILE_NAME then  fbModify  := True
    else fbModify  := False;
end;

procedure TDebugMsgForm.ActionPasteExecute(Sender: TObject);
var
    s     : String;
    oItem : TListItem;
begin
    s:=foClipboard.AsText;
    while s <> '' do
    begin
        oItem:=lvMessage.Items.Add;
        oItem.Caption:=CutToken(s);
        oItem.SubItems.Add(CutToken(s));
        oItem.SubItems.Add(FirstToken(s,ASC_CRLF,True));
    end;
    fiNextNo := GetNextNo;
end;

procedure TDebugMsgForm.ActionSelectAllExecute(Sender: TObject);
var
    i: Integer;
begin
    for i:=0 to lvMessage.Items.Count-1 do
        lvMessage.Items[i].Selected:=True;
end;

procedure TDebugMsgForm.lvMessageDblClick(Sender: TObject);
begin
    with DetailForm do
    begin
        ListView := lvMessage;
        ShowModal;
    end;
end;

procedure TDebugMsgForm.ActionClearExecute(Sender: TObject);
begin
    //只有命名文件添加信息时，才置修改标志有效，退出时一定提示是否保存？
    if (fFileName <> UNTITLED_FILE_NAME) and (not DoSaveFile) then Exit;
    lvMessage.Items.Clear;
    fFileName := UNTITLED_FILE_NAME;
    Caption   := fsCaption+' - '+fFileName;
    fbModify  := False;
    fiNextNo  := GetNextNo;
end;

end.