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

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

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

演示程序如下：

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