trayiconform.pas

使Windows能够像RedHat Linux那样拥有四个桌面。 1.2版添加功能：隐藏任务栏图标。(参考了Delphi盒子网站上的代码)

unit TrayIconForm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,CommCtrl, ExtCtrls, Buttons, ComCtrls, ImgList,ShellAPI;

type
  TTrayForm = class(TForm)
    Memo1: TMemo;
    ListView1: TListView;
    Button4: TButton;
    Button5: TButton;
    ImageList1: TImageList;
    procedure Button4Click(Sender: TObject);
    procedure ListView1Change(Sender: TObject; Item: TListItem;
      Change: TItemChange);
    procedure ListView1Enter(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
    function GetSysTrayIconRect(Text: string): TRect;
    function GetSysTrayWnd: HWND;
    procedure GetAllTipText;
  public
    { Public declarations }
  end;

var
  TrayForm: TTrayForm;
  IconId:Integer;
  mHandle:THandle;
  xxx,ListChange:Boolean;
implementation
{$R *.dfm}


function GetToolBarButtonRect(hWnd: HWND; Title: string): TRect;
{
  返回指定工具栏对应的按钮指定文本的矩形区域
  hWnd:工具栏句柄，Title：需要返回矩形区域的按钮文字
  返回值：指定按钮的边界矩形，屏幕坐标
}
var
  C, i: integer;
  Info: _TBBUTTON;
  Item: tagTCITEM;
  Buff: PChar;
  S: array[0..1024] of char;
  tmpS: string;
  PID: THandle;
  PRC: THandle;
  R: Cardinal;
begin
  IconId:=-1;
  FillChar(Result, SizeOf(Result), 0);
  if hWnd = 0 then Exit;
  GetWindowThreadProcessId(hWnd, @PID);
  PRC := OpenProcess(PROCESS_VM_OPERATION or PROCESS_VM_READ or PROCESS_VM_WRITE, False, PID);
  Buff := VirtualAllocEx(PRC, nil, 4096, MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE);

  if Format('%d.%d', [Win32MajorVersion, Win32MinorVersion]) >= '5.1' then {// Is Windows XP or Higher}
  begin
    C := SendMessage(hWnd, TB_BUTTONCOUNT, 0, 0);
    for i := 0 to C - 1 do
    begin
      FillChar(Info, SizeOf(Info), 0);
      WriteProcessMemory(PRC, Buff, @Info, SizeOf(Info), R);

      SendMessage(hWnd, TB_GETBUTTON, i, integer(Buff));
      ReadProcessMemory(PRC, Buff, @Info, SizeOf(Info), R);

      SendMessage(hWnd, TB_GETBUTTONTEXT, Info.idCommand, integer(integer(@Buff[0]) + SizeOf(Info)));
      ReadProcessMemory(PRC, Pointer(integer(@Buff[0]) + SizeOf(Info)), @S[0], SizeOf(S), R);

      tmpS := S;
      if tmpS = Title then //and not Boolean(SendMessage(hWnd, TB_ISBUTTONHIDDEN, Info.idCommand, 0)) then
      begin
        xxx:=True;
        IconId:=(C-1)-i;
        SendMessage(hWnd, TB_GETRECT, Info.idCommand, integer(integer(@Buff[0]) + SizeOf(Info)));
        ReadProcessMemory(PRC, Pointer(integer(@Buff[0]) + SizeOf(Info)), @Result, SizeOf(Result), R);

        Windows.ClientToScreen(hWnd, Result.TopLeft);
        Windows.ClientToScreen(hWnd, Result.BottomRight);
        mHandle:=hWnd;

        Break;
      end;
    end;
  end
  else
  begin
    C := SendMessage(hWnd, TCM_GETITEMCOUNT, 0, 0);
    for i := 0 to C - 1 do
    begin
      with Item do
      begin
        mask := TCIF_TEXT;
        dwState := 0;
        dwStateMask := 0;
        cchTextMax := 2048;
        pszText := PChar(integer(Buff) + SizeOf(Item) * 4);
        iImage := 0;
        lParam := 0;
      end;
      WriteProcessMemory(PRC, Buff, @Item, SizeOf(Item), R);
      SendMessage(hWnd, TCM_GETITEM, i, Integer(Buff));

      ReadProcessMemory(PRC, Buff, @Item, SizeOf(Item), R);
      ReadProcessMemory(PRC, PChar(integer(Buff) + SizeOf(Item) * 4), @S[0], SizeOf(S), R);

      if SameText(S, Title) then
      begin
        xxx:=True;
        IconId:=(C-1)-i;
        SendMessage(hWnd, TCM_GETITEMRECT, i, integer(Buff));
        ReadProcessMemory(PRC, Buff, @Result, SizeOf(Result), R);

        Windows.ClientToScreen(hWnd, Result.TopLeft);
        Windows.ClientToScreen(hWnd, Result.BottomRight);
        Break;
      end;
    end;
  end;

  VirtualFreeEx(PRC, Buff, 0, MEM_RELEASE);
  CloseHandle(PRC);
end;

{*
  得到所有托盘文字信息处理之~~~
*}
procedure TTrayForm.GetAllTipText;
var
  C, i: integer;
  Info: _TBBUTTON;
  Item: tagTCITEM;
  Buff: PChar;
  S: array[0..1024] of char;
  tmpS: string;
  PID: THandle;
  PRC: THandle;
  R: Cardinal;
  hWnd:THandle;
  //x: Integer;
  hImageList, aIconHandle: THandle;
  aImage: TBitmap;
  imWidth, imHeight: integer;
  aImageInfo: TImageInfo;
begin
  hWnd:=GetSysTrayWnd;
  if hWnd = 0 then Exit;
  GetWindowThreadProcessId(hWnd, @PID);
  PRC := OpenProcess(PROCESS_VM_OPERATION or PROCESS_VM_READ or PROCESS_VM_WRITE, False, PID);
  Buff := VirtualAllocEx(PRC, nil, 4096, MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE);  

  if Format('%d.%d', [Win32MajorVersion, Win32MinorVersion]) >= '5.1' then {// Is Windows XP or Higher}
  begin
    C := SendMessage(hWnd, TB_BUTTONCOUNT, 0, 0);
    for i := 0 to C - 1 do
    begin
      FillChar(Info, SizeOf(Info), 0);
      WriteProcessMemory(PRC, Buff, @Info, SizeOf(Info), R);

      SendMessage(hWnd, TB_GETBUTTON, i, integer(Buff));
      ReadProcessMemory(PRC, Buff, @Info, SizeOf(Info), R);
      //x:=SendMessage(hWnd, TB_GETIMAGELIST, i, integer(Buff));// IMAGELIST

      SendMessage(hWnd, TB_GETBUTTONTEXT, Info.idCommand, integer(integer(@Buff[0]) + SizeOf(Info)));
      ReadProcessMemory(PRC, Pointer(integer(@Buff[0]) + SizeOf(Info)), @S[0], SizeOf(S), R);
      tmpS := S;
      while Pos(#$d+#$a, tmpS)>0 do
        Delete(tmpS, Pos(#$d+#$a, tmpS), 2);
      if tmpS<>'' then
      if Memo1.Lines.IndexOf(tmpS)<0 then
      begin
        Memo1.Lines.Add(tmpS);
        with ListView1.Items.Add do
        begin
          Caption := tmpS;
          SubItems.Add(IntToStr(Info.idCommand));
          Checked := SendMessage(hWnd, TB_ISBUTTONHIDDEN, Info.idCommand, integer(integer(@Buff[0]) + SizeOf(Info)))=0;
        end;
      end;
    end;
  end
  else
  begin
    C := SendMessage(hWnd, TCM_GETITEMCOUNT, 0, 0);
    for i := 0 to C - 1 do
    begin
      with Item do
      begin
        mask := TCIF_TEXT;
        dwState := 0;
        dwStateMask := 0;
        cchTextMax := 2048;
        pszText := PChar(integer(Buff) + SizeOf(Item) * 4);
        iImage := 0;
        lParam := 0;
      end;
      WriteProcessMemory(PRC, Buff, @Item, SizeOf(Item), R);
      SendMessage(hWnd, TCM_GETITEM, i, Integer(Buff));

      ReadProcessMemory(PRC, Buff, @Item, SizeOf(Item), R);
      ReadProcessMemory(PRC, PChar(integer(Buff) + SizeOf(Item) * 4), @S[0], SizeOf(S), R);
      Memo1.Lines.Add(StrPas(s));
    end;
  end;

  VirtualFreeEx(PRC, Buff, 0, MEM_RELEASE);
  CloseHandle(PRC);  
end;


function TTrayForm.GetSysTrayWnd: HWND;
{
  返回系统托盘的句柄，适合于WinXP以上版本
}
begin
  Result := FindWindow('Shell_TrayWnd', nil);
  Result := FindWindowEx(Result, 0, 'TrayNotifyWnd', nil);
  Result := FindWindowEx(Result, 0, 'SysPager', nil);
  Result := FindWindowEx(Result, 0, 'ToolbarWindow32', nil);
end;


function TTrayForm.GetSysTrayIconRect(Text: string): TRect;
{
  返回系统托盘中指定文字的图标的矩形区域。
  例如返回音量控制图标的矩形区域：
  GetSysTrayIconRect('音量');
}
begin
  Result := GetToolBarButtonRect(GetSysTrayWnd,Text);
end;

procedure TTrayForm.Button4Click(Sender: TObject);
var
  i,j:Integer;
begin
  //得到全部文字提示后，删除重复的，空的
//  Memo1.Clear;
//  ListView1.Clear;
  GetAllTipText;
{  for i:=0 to memo1.Lines.Count-1 do
  for j:=memo1.Lines.Count-1 downto i+1 do
  if (Memo1.Lines[i]=Memo1.Lines[j]) or (Memo1.Lines[j]='') then
      Memo1.Lines.Delete(j);
  //加入listview1
  for i:=0 to Memo1.Lines.Count-1 do
    with ListView1.Items.Add do
    begin
      Caption:=Memo1.Lines[i];
      SubItems.Add('999');
    end;
  //加入索引值
  for i:=0 to ListView1.Items.Count-1 do
  begin
    GetSysTrayIconRect(ListView1.Items[i].Caption);
    ListView1.Items[i].SubItems[0]:=IntToStr(IconId);
  end;   }
end;

procedure TTrayForm.ListView1Change(Sender: TObject; Item: TListItem;
  Change: TItemChange);
begin
  if ListChange then
    begin
      if not Item.Checked then
      begin                           
      SendMessage(GetSysTrayWnd,TB_HIDEBUTTON,StrToInt(Item.SubItems[0]),1);
      button5click(sender);
      end
      else
      begin
      SendMessage(GetSysTrayWnd,TB_HIDEBUTTON,StrToInt(Item.SubItems[0]),0);
      button5click(sender);
      end;
    end;
end;

procedure TTrayForm.ListView1Enter(Sender: TObject);
begin
  ListChange:=True;
end;

procedure TTrayForm.Button5Click(Sender: TObject);
var
   AID: _NOTIFYICONDATA;
begin
 AID.cbSize := SizeOf(AID);
 AID.Wnd := Handle;
 AID.uID := 0;
 AID.uFlags := NIF_ICON;
 AID.uCallbackMessage := 0;
 AID.hIcon := Icon.Handle;
 AID.szTip := '';
 Shell_NotifyIcon(NIM_ADD, @AID);
 AID.cbSize := SizeOf(AID);
 AID.Wnd := Handle;
 AID.uID := 0;
 Shell_NotifyIcon(NIM_DELETE, @AID);
end;

procedure TTrayForm.FormShow(Sender: TObject);
begin
  Button4.Click;
end;

end.