让应用程序在多桌面间自由飞翔

Windows支持多桌面，Delphi了支持多桌面，今天让程序也支持上多桌面了。

程序运行时会在标题栏最小化按钮旁边显示一个按钮（支持Theme效果），按钮引出一个菜单供用户选择要显示的桌面位置，通过它即可在多桌面间自由往返。（PS:可惜CSDN现在不能上图了。）

演示程序如下：

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, uxtheme, StdCtrls, Menus;
type
  TForm1 = class(TForm)
    PopupMenu1: TPopupMenu;
    procedure FormCreate(Sender: TObject);
    procedure MenuItemClick(Sender: TObject);
  private
    ButtonLastState: Boolean;
    procedure DrawThemeButton(Hot: Boolean);
  public
    procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
    procedure WMActivate(var Msg: TWMActivate); message WM_ACTIVATE;
    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
    procedure WMNCLButtonDown(var Msg: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
  end;
var
  Form1: TForm1;
implementation
{R *.dfm}
procedure TForm1.DrawThemeButton(Hot: Boolean);
var
  ht: HTHEME;
  WinDC: HDC;
  R: TRect;
  State: Integer;
begin
  if ButtonLastState = Hot then Exit;
  WinDC := GetWindowDC(Handle);
  R.Left := Width-4*GetSystemMetrics(SM_CXSIZE)-1;//GetSystemMetrics(SM_CXFRAME);
  R.Right := R.Left+GetSystemMetrics(SM_CXSIZE)-1;
  R.Top := GetSystemMetrics(SM_CYFRAME);
  R.Bottom := R.Top+GetSystemMetrics(SM_CYCAPTION)-1;
  if IsAppThemed then begin
    if Hot then State := SPLS_HOT else State := SPLS_NORMAL;
    ht := OpenThemeData(Handle, 'STARTPANEL');
    DrawThemeBackground(ht, WinDC, SPP_LOGOFFBUTTONS, State, R, nil);
    CloseThemeData(ht);
  end else begin
    InflateRect(R, 0, -2);
    if Hot then State := DFCS_BUTTONPUSH or DFCS_HOT else State := DFCS_BUTTONPUSH;
    DrawFrameControl(WinDC, R, DFC_BUTTON, State);
  end;
  ReleaseDC(Handle, WinDC);
  ButtonLastState := Hot;
end;
procedure TForm1.MenuItemClick(Sender: TObject);
begin
  if TMenuItem(Sender).Tag = Monitor.MonitorNum then Exit;
  if WindowState = wsMaximized then begin
    WindowState := wsNormal;
    MakeFullyVisible(Screen.Monitors[TMenuItem(Sender).Tag]);
    WindowState := wsMaximized;
  end else
    MakeFullyVisible(Screen.Monitors[TMenuItem(Sender).Tag]);
  //Left := Screen.Monitors[TMenuItem(Sender).Tag].Left;
  //Top := Screen.Monitors[TMenuItem(Sender).Tag].Top;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
  Item: TMenuItem;
begin
  for i := 0 to Screen.MonitorCount - 1 do begin
    Item := TMenuItem.Create(PopupMenu1);
    Item.Caption := Format('显示器%d-[%d*%d]', [i+1,Screen.Monitors[i].Width,Screen.Monitors[i].Height]);
    Item.Tag := i;
    Item.OnClick := MenuItemClick;
    PopupMenu1.Items.Add(Item);
  end;
end;
procedure TForm1.WMActivate(var Msg: TWMActivate);
var
  PaintMsg: TWMNCPaint;
begin
  Msg.Result := 1;
  if not Boolean(Msg.Active) then inherited
  else begin
    PaintMsg.Msg := Msg.Msg;
    PaintMsg.RGN := Msg.Active;
    WMNCPaint(PaintMsg);
  end;
end;
procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
var
  R: TRect;
  Pt: TPoint;
begin
  R.Left := Width-4*GetSystemMetrics(SM_CXSIZE);//GetSystemMetrics(SM_CXFRAME);
  R.Right := R.Left+GetSystemMetrics(SM_CXSIZE)-1;
  R.Top := GetSystemMetrics(SM_CYFRAME);
  R.Bottom := R.Top+GetSystemMetrics(SM_CYCAPTION)-1;
  Pt.X := Msg.Pos.x - Left;
  Pt.Y := Msg.Pos.y - Top;
  if PtInRect(R, Pt) then begin
    Msg.Result := htSizeLast + 1;
    DrawThemeButton(true);
  end
  else begin
    inherited;
    DrawThemeButton(false);
  end;
end;
procedure TForm1.WMNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
  inherited;
  if (Msg.HitTest = htSizeLast + 1) then
  PopupMenu1.Popup(Left+Width-4*GetSystemMetrics(SM_CXSIZE), Top+GetSystemMetrics(SM_CYFRAME)+GetSystemMetrics(SM_CYCAPTION)-2);
end;
procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
  ht: HTHEME;
  WinDC: HDC;
  R: TRect;
begin
  inherited;
  if not Application.Active then Exit;
  ButtonLastState := true;
  DrawThemeButton(false);
end;
end.

DFM文件：

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 292
  ClientWidth = 490
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object PopupMenu1: TPopupMenu
    Left = 112
    Top = 152
  end
end

http://blog.csdn.net/nhconch/article/details/4005102