How to create a tray application that shows and hides the Desktop

Problem/Question/Abstract:

How to create a tray application that shows and hides the Desktop

Answer:

Here is code for a small tray app that shows and hides the desktop. It has hint activation.

unit DeskIcons;

interface

uses
  Graphics; {Definition of TColor}

procedure SetDesktopIconColor(Forground, Background: TColor; Trans: Boolean);
procedure SetDefaultIconColors;

implementation

uses
  Windows, CommCtrl; {Definition of HWND and ListView_XXXXX}

procedure SetDesktopIconColor(Forground, Background: TColor; Trans: Boolean);
{This procedure set's the desktop icon text color to a given color with the option to add a
transparent background.}
var
  Window: HWND;
begin
  {Find the right window with 3 calls}
  Window := FindWindow('Progman', 'Program Manager');
  {FindWindowEx is used to find a child window}
  Window := FindWindowEx(Window, HWND(nil), 'SHELLDLL_DefView', '');
  {SysListView32 is the desktop icon list view}
  Window := FindWindowEx(Window, HWND(nil), 'SysListView32', '');
  {Use the macro to set the background color to clear}
  if Trans then
    ListView_SetTextBkColor(Window, $FFFFFFFF) {back color}
  else
    ListView_SetTextBkColor(Window, Background); {back color}
  ListView_SetTextColor(Window, Forground); {foreground color}
  {now send a redraw to the icons to redraw the new color}
  ListView_RedrawItems(Window, 0, ListView_GetItemCount(Window) - 1);
  UpdateWindow(Window); {force the redraw to take effect immediately}
end;

procedure SetDefaultIconColors;
{This set's the colors to be whatever is currently stored by windows}
var
  Kind: Integer;
  Color: TColor;
begin
  Kind := COLOR_DESKTOP;
  Color := GetSysColor(COLOR_DESKTOP);
  SetSysColors(1, Kind, Color);
end;

end.

And now the program:

program DeskPop;

uses
  Windows, Messages, ShellAPI, sysutils, DeskIcons in 'DeskIcons.pas';

{$R *.RES}
{$R ICONS.RES}

const
  AppName = 'DeskTop Hide by Brian Slack';

var
  x: integer;
  tid: TNotifyIconData;
  WndClass: array[0..50] of char;

procedure Panic(szMessage: PChar);
begin
  if szMessage <> nil then
    MessageBox(0, szMessage, AppName, mb_ok);
  Halt(0);
end;

procedure HandleCommand(Wnd: hWnd; Cmd: Word);
begin
  case Cmd of
    Ord('A'): MessageBox(0, 'Freeware Ninstall &copy;1999', AppName, mb_ok);
    Ord('E'): PostMessage(Wnd, WM_CLOSE, 0, 0);
    Ord('0'): SetDesktopIconColor($80000000, $C0C0C0, True);
  end;
end;

function DummyWindowProc(Wnd: hWnd; Msg, wParam: Word; lParam: LongInt): LongInt;
  stdcall;
var
  TrayHandle: THandle;
  dc: hDC;
  {i: Integer;}
  pm: HMenu;
  pt: TPoint;
begin
  DummyWindowProc := 0;
  StrPCopy(@WndClass[0], 'Progman');
  TrayHandle := FindWindow(@WndClass[0], nil);
  case Msg of
    WM_CREATE: {Program initialisation - just set up a tray icon}
      begin
        tid.cbSize := sizeof(tid);
        tid.Wnd := Wnd;
        tid.uID := 1;
        tid.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
        tid.uCallBackMessage := WM_USER;
        tid.hIcon := LoadIcon(hInstance, 'MAINICON');
        lstrcpy(tid.szTip, 'Desktop is on');
        Shell_NotifyIcon(nim_Add, @tid);
      end;
    WM_DESTROY:
      begin
        Shell_NotifyIcon(nim_Delete, @tid);
        PostQuitMessage(0);
        ShowWindow(TrayHandle, SW_RESTORE);
        SetDefaultIconColors;
      end;
    WM_COMMAND: {Command notification}
      begin
        HandleCommand(Wnd, LoWord(wParam));
        Exit;
      end;
    WM_USER: {Had a tray notification - see what to do}
      if (lParam = wm_LButtonDown) then
      begin
        if x = 0 then
        begin
          ShowWindow(TrayHandle, SW_HIDE);
          tid.hIcon := LoadIcon(hInstance, 'offICON');
          lstrcpy(tid.szTip, 'Desktop is off');
          Shell_NotifyIcon(NIM_MODIFY, @tid);
          x := 1
        end
        else
        begin
          ShowWindow(TrayHandle, SW_RESTORE);
          tid.hIcon := LoadIcon(hInstance, 'ONICON');
          lstrcpy(tid.szTip, 'Desktop is on');
          Shell_NotifyIcon(NIM_MODIFY, @tid);
          x := 0;
        end;
      end
      else if (lParam = wm_RButtonDown) then
      begin
        GetCursorPos(pt);
        pm := CreatePopupMenu;
        AppendMenu(pm, 0, Ord('O'), 'Transparent Icons');
        AppendMenu(pm, 0, Ord('A'), 'About DeskTop Hide...');
        AppendMenu(pm, mf_Separator, 0, nil);
        AppendMenu(pm, 0, Ord('E'), 'Exit DeskTop Hide');
        SetForegroundWindow(Wnd);
        dc := GetDC(0);
        if TrackPopupMenu(pm, tpm_BottomAlign or tpm_RightAlign, pt.x,
          GetDeviceCaps(dc, HORZRES) {pt.y}, 0, Wnd, nil) then
          SetForegroundWindow(Wnd);
        DestroyMenu(pm)
      end;
  end;
  DummyWindowProc := DefWindowProc(Wnd, Msg, wParam, lParam);
end;

procedure WinMain;
var
  Wnd: hWnd;
  Msg: TMsg;
  cls: TWndClass;
begin
  { Previous instance running ?  If so, exit }
  if FindWindow(AppName, nil) <> 0 then
    Panic(AppName + ' is already running.');
  { Register the window class }
  FillChar(cls, sizeof(cls), 0);
  cls.lpfnWndProc := @DummyWindowProc;
  cls.hInstance := hInstance;
  cls.lpszClassName := AppName;
  RegisterClass(cls);
  { Now create the dummy window }
  Wnd := CreateWindow(AppName, AppName, ws_OverlappedWindow, 4, 4, 4, 4, 0, 0,
    hInstance, nil);
  x := 0;
  if Wnd <> 0 then
  begin
    ShowWindow(Wnd, sw_Hide);
    while GetMessage(Msg, 0, 0, 0) do
    begin
      TranslateMessage(Msg);
      DispatchMessage(Msg);
    end;
  end;
end;

begin
  WinMain;

end.