在窗口标题区添加按钮,让IE右键失效
分类:美高梅游戏官网网站


DFM文件:

procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
  if IsChild(WebBrowser1.Handle,Msg.hwnd) and ((Msg.message=WM_RBUTTONDOWN) or (Msg.message=WM_RBUTTONDBLCLK)) then
  begin
    Handled:=true;
  end;

unit Unit1;

TForm1 = class(TForm)

interface

procedure TForm1.ListBox_MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if TipVisable then     //当鼠标按下,将显示的 Tooltip Window 隐藏
  begin
    SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(false)), 0);
    TipVisable := false;
  end;
end;

Canvas.Pen.Color:=clYellow;

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

代码如下:

  ListBox1.OnMouseMove := ListBox_MouseMove;
  ListBox1.OnMouseDown := ListBox_MouseDown;
end;

DrawCaptButton;

 

 

{直接将下面代码拷贝到新建工程中Form1的Unit1.pas文件即可运行,不需添加任何控件}

end.

演示程序如下:

implementation

procedure TForm1.CreateTipsWindow;
var
  iccex: tagINITCOMMONCONTROLSEX;
begin
  // Load the ToolTip class from the DLL.
  iccex.dwSize := sizeof(tagINITCOMMONCONTROLSEX);
  iccex.dwICC  := ICC_BAR_CLASSES;
  InitCommonControlsEx(iccex);

end;

 

界面代码如下:

procedure TNewListBox.WndProc(var Message: TMessage);
begin
  case Message.Msg of
    CM_MOUSELEAVE: Form1.HideTipsWindow;
  end;
  inherited WndProc(Message);
end;

inherited;

  1. unit Unit1;  
  2. interface  
  3. uses  
  4.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
  5.   Dialogs, uxtheme, StdCtrls, Menus;  
  6. type  
  7.   TForm1 = class(TForm)  
  8.     PopupMenu1: TPopupMenu;  
  9.     procedure FormCreate(Sender: TObject);  
  10.     procedure MenuItemClick(Sender: TObject);  
  11.   private  
  12.     ButtonLastState: Boolean;  
  13.     procedure DrawThemeButton(Hot: Boolean);  
  14.   public  
  15.     procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;  
  16.     procedure WMActivate(var Msg: TWMActivate); message WM_ACTIVATE;  
  17.     procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;  
  18.     procedure WMNCLButtonDown(var Msg: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;  
  19.   end;  
  20. var  
  21.   Form1: TForm1;  
  22. implementation  
  23. {R *.dfm}  
  24. procedure TForm1.DrawThemeButton(Hot: Boolean);  
  25. var  
  26.   ht: HTHEME;  
  27.   WinDC: HDC;  
  28.   R: TRect;  
  29.   State: Integer;  
  30. begin  
  31.   if ButtonLastState = Hot then Exit;  
  32.   WinDC := GetWindowDC(Handle);  
  33.   R.Left := Width-4*GetSystemMetrics(SM_CXSIZE)-1;//GetSystemMetrics(SM_CXFRAME);  
  34.   R.Right := R.Left+GetSystemMetrics(SM_CXSIZE)-1;  
  35.   R.Top := GetSystemMetrics(SM_CYFRAME);  
  36.   R.Bottom := R.Top+GetSystemMetrics(SM_CYCAPTION)-1;  
  37.   if IsAppThemed then begin  
  38.     if Hot then State := SPLS_HOT else State := SPLS_NORMAL;  
  39.     ht := OpenThemeData(Handle, 'STARTPANEL');  
  40.     DrawThemeBackground(ht, WinDC, SPP_LOGOFFBUTTONS, State, R, nil);  
  41.     CloseThemeData(ht);  
  42.   end else begin  
  43.     InflateRect(R, 0, -2);  
  44.     if Hot then State := DFCS_BUTTONPUSH or DFCS_HOT else State := DFCS_BUTTONPUSH;  
  45.     DrawFrameControl(WinDC, R, DFC_BUTTON, State);  
  46.   end;  
  47.   ReleaseDC(Handle, WinDC);  
  48.   ButtonLastState := Hot;  
  49. end;  
  50. procedure TForm1.MenuItemClick(Sender: TObject);  
  51. begin  
  52.   if TMenuItem(Sender).Tag = Monitor.MonitorNum then Exit;  
  53.   if WindowState = wsMaximized then begin  
  54.     WindowState := wsNormal;  
  55.     MakeFullyVisible(Screen.Monitors[TMenuItem(Sender).Tag]);  
  56.     WindowState := wsMaximized;  
  57.   end else  
  58.     MakeFullyVisible(Screen.Monitors[TMenuItem(Sender).Tag]);  
  59.   //Left := Screen.Monitors[TMenuItem(Sender).Tag].Left;  
  60.   //Top := Screen.Monitors[TMenuItem(Sender).Tag].Top;  
  61. end;  
  62. procedure TForm1.FormCreate(Sender: TObject);  
  63. var  
  64.   i: integer;  
  65.   Item: TMenuItem;  
  66. begin  
  67.   for i := 0 to Screen.MonitorCount - 1 do begin  
  68.     Item := TMenuItem.Create(PopupMenu1);  
  69.     Item.Caption := Format('显示器%d-[%d*%d]', [i+1,Screen.Monitors[i].Width,Screen.Monitors[i].Height]);  
  70.     Item.Tag := i;  
  71.     Item.OnClick := MenuItemClick;  
  72.     PopupMenu1.Items.Add(Item);  
  73.   end;  
  74. end;  
  75. procedure TForm1.WMActivate(var Msg: TWMActivate);  
  76. var  
  77.   PaintMsg: TWMNCPaint;  
  78. begin  
  79.   Msg.Result := 1;  
  80.   if not Boolean(Msg.Active) then inherited  
  81.   else begin  
  82.     PaintMsg.Msg := Msg.Msg;  
  83.     PaintMsg.RGN := Msg.Active;  
  84.     WMNCPaint(PaintMsg);  
  85.   end;  
  86. end;  
  87. procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);  
  88. var  
  89.   R: TRect;  
  90.   Pt: TPoint;  
  91. begin  
  92.   R.Left := Width-4*GetSystemMetrics(SM_CXSIZE);//GetSystemMetrics(SM_CXFRAME);  
  93.   R.Right := R.Left+GetSystemMetrics(SM_CXSIZE)-1;  
  94.   R.Top := GetSystemMetrics(SM_CYFRAME);  
  95.   R.Bottom := R.Top+GetSystemMetrics(SM_CYCAPTION)-1;  
  96.   Pt.X := Msg.Pos.x - Left;  
  97.   Pt.Y := Msg.Pos.y - Top;  
  98.   if PtInRect(R, Pt) then begin  
  99.     Msg.Result := htSizeLast + 1;  
  100.     DrawThemeButton(true);  
  101.   end  
  102.   else begin  
  103.     inherited;  
  104.     DrawThemeButton(false);  
  105.   end;  
  106. end;  
  107. procedure TForm1.WMNCLButtonDown(var Msg: TWMNCLButtonDown);  
  108. begin  
  109.   inherited;  
  110.   if (Msg.HitTest = htSizeLast + 1) then  
  111.   PopupMenu1.Popup(Left+Width-4*GetSystemMetrics(SM_CXSIZE), Top+GetSystemMetrics(SM_CYFRAME)+GetSystemMetrics(SM_CYCAPTION)-2);  
  112. end;  
  113. procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);  
  114. var  
  115.   ht: HTHEME;  
  116.   WinDC: HDC;  
  117.   R: TRect;  
  118. begin  
  119.   inherited;  
  120.   if not Application.Active then Exit;  
  121.   ButtonLastState := true;  
  122.   DrawThemeButton(false);  
  123. end;  
  124. end.  

美高梅网址 1 

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    GHWND: HWND;
    TipVisable: Boolean;
    OldIndex, CurrentIndex: Integer;
    ti: TOOLINFO;
    ListBox1: TListBox;

try

 

end;

{ TNewListBox }

if(Msg.HitTest=htCaptionBtn)then

 


var
  Form1: TForm1;

R:=Bounds(Width-xFrame-4*xSize+3,yFrame+3,xSize-2,ySize-7);

 

unit Unit1;

procedure TForm1.InitListBox;
begin
  ListBox1 := TNewListBox.Create(Self);
  ListBox1.Parent := Self;
  ListBox1.Left := 50;
  ListBox1.Top := 50;
  ListBox1.Width := 200;
  ListBox1.Height := 200;
  //添加几项,以供测试用
  ListBox1.Items.Append(happyjoe);
  ListBox1.Items.Append(Please send me email: [email protected]);
  ListBox1.Items.Append(Delphi 5 开发人员指南);
  ListBox1.Items.Append(Delphi 5.X ADO/MTS/COM+ 高级程序设计篇);

Canvas.Brush.Color:=clBtnFace;

 

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, AppEvnts, OleCtrls, SHDocVw;

{$R *.dfm}

end;

[delphi] view plain copy

var
  Form1: TForm1;

procedure TForm1.ListBox_MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  Index: Integer;
  APoint: TPoint;
  ARect: TRect;
  ScreenRect: TRect;
begin
  Index := ListBox1.ItemAtPos(Point(X, Y), true);
  if Index = -1 then  //如果鼠标下没有 Item,将 Tooltip Window 隐藏
  begin
    SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(false)), 0);
    OldIndex := -1;
    TipVisable := false;
    exit;
  end;
  CurrentIndex := Index; 
  if Index = OldIndex then exit;  //如果鼠标在同一 Item 上移动,退出处理
  if TipVisable then   //先将显示的 Tooltip Window 隐藏
  begin
    SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(false)), 0);
    OldIndex := -1;
美高梅网址,    TipVisable := false;
  end else
  begin
    ARect := ListBox1.ItemRect(Index);
    //判断该 Item 是否完全显示
    if (ARect.Right - ARect.Left - 2) >= ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) then
    begin
      OldIndex := -1;
      exit;
    end;
    APoint := ListBox1.ClientToScreen(ARect.TopLeft);
    windows.GetClientRect(GetDesktopWindow, ScreenRect);
    //判断 Tooltip Window 显示后是否会超出屏幕范围,这里只判断了右边界
    if ListB

procedure WMNCLButtonDown(var Msg:TWMNCLButtonDown);message WM_NCLButtonDown;

 

type
  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    ApplicationEvents1: TApplicationEvents;
    procedure FormCreate(Sender: TObject);
    procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

implementation

end;

[c-sharp] view plain copy

主要演示了TApplicationEvents.OnMessage 的第二个参数 Handled 如果是 True, 表示消息已经处理过了, 到此为止.

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, CommCtrl;

procedure TForm1.FormResize(Sender: TObject);

 

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'IE'#21491#38190#22833#25928
  ClientHeight = 247
  ClientWidth = 312
  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 WebBrowser1: TWebBrowser
    Left = 4
    Top = 8
    Width = 300
    Height = 201
    TabOrder = 0
    ControlData = {
      4C000000021F0000C61400000000000000000000000000000000000000000000
      000000004C000000000000000000000001000000E0D057007335CF11AE690800
      2B2E126208000000000000004C0000000114020000000000C000000000000046
      8000000000000000000000000000000000000000000000000000000000000000
      00000000000000000100000000000000000000000000000000000000}
  end
  object ApplicationEvents1: TApplicationEvents
    OnMessage = ApplicationEvents1Message
    Left = 24
    Top = 216
  end
end

type
  //改写 TListBox 拦截 CM_MOUSELEAVE 消息
  TNewListBox = class(TListBox)
  protected
    { Protected declarations }
    procedure WndProc(var Message: TMessage); override;
  end;

if PtInRect(CaptionBtn,Point(xPos-Left,yPos-Top)) then

 

{$R *.dfm}

    procedure InitListBox;   //动态生成 ListBox1
    procedure CreateTipsWindow;  //生成 Tooltip Window
    procedure HideTipsWindow;    //隐藏 Tooltip Window

htCaptionBtn=htSizeLast+1;

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

procedure TForm1.FormCreate(Sender: TObject);
begin
  WindowState:= wsMaximized;
  WebBrowser1.Align:=alTop;
  WebBrowser1.Navigate('http://www.baidu.com');;/)
end;

大家知道 TreeView 上的节点如果显示不完全,鼠标移上去会出现一提示,这就是 In-place Tooltips。下面这段代码在 Listbox 上实现这一功能(下面代码只是在标准 Listbox 上测试,如果是自画的,则要修改):

DrawCaptButton;

  1. object Form1: TForm1  
  2.   Left = 0  
  3.   Top = 0  
  4.   Caption = 'Form1'  
  5.   ClientHeight = 292  
  6.   ClientWidth = 490  
  7.   Color = clBtnFace  
  8.   Font.Charset = DEFAULT_CHARSET  
  9.   Font.Color = clWindowText  
  10.   Font.Height = -11  
  11.   Font.Name = 'Tahoma'  
  12.   Font.Style = []  
  13.   OldCreateOrder = False  
  14.   OnCreate = FormCreate  
  15.   PixelsPerInch = 96  
  16.   TextHeight = 13  
  17.   object PopupMenu1: TPopupMenu  
  18.     Left = 112  
  19.     Top = 152  
  20.   end  
  21. end  

end.

{ TForm1 }

procedure TForm1.WMNCLButtonDown(var Msg: TWMNCLButtonDown);

 

TreeView 上的节点如果显示不完全,鼠标移上去会出现一提示,这就是 In-place Tooltips。下面这段代码在 Listbox 上实现这一功能(下面...

Canvas.Font.Name:=宋体;

    //拦截 WM_NOTIFY 消息,动态改变 Tooltip Window 显示的内容
    procedure WMNotify(var Msg: TMessage); message WM_NOTIFY;

end;

  // Create the ToolTip control.
  GHWND := CreateWindow(TOOLTIPS_CLASS, ,
                        WS_POPUP,
                        Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
                        Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
                        0, 0, hInstance,
                        nil);

inherited;

interface

const

  // Prepare TOOLINFO structure for use as tracking ToolTip.
  ti.cbSize := sizeof(ti);
  ti.uFlags := TTF_IDISHWND + TTF_TRACK + TTF_ABSOLUTE + TTF_TRANSPARENT;
  ti.hwnd   := Self.Handle;
  ti.uId    := ListBox1.Handle;
  ti.hinst  := hInstance;
  ti.lpszText  := LPSTR_TEXTCALLBACK;
  ti.rect.left := 0;
  ti.rect.top := 0;
  ti.rect.bottom := 0;
  ti.rect.right := 0;

ReadBook是一款优秀的软件,我相信读者中也有不少人在使用它。今天,我想给大家谈谈它是如何在窗口的标题区添加按钮的。有可能我的实现方法和ReadBook的不一样,没关系,大家互相学习吧!
  程序主要用到了几个消息,除了程序中消息函数定义的方法外,大家还要注意每一个消息函数中都调用了inherited,原因不用我饶舌了吧?程序中还调用了GetSystemMetrics、DrawButtonFace等几个函数。我本来在程序中详细地加了注释,不过我后来都删除了,因为Delphi的帮助文件可以说是最好的注释了。如果你有什么不懂之处,别忘了按“F1”键,怎么样,一切都写得清清楚楚的吧?
  把下边的程序输进计算机,自己用帮助文件研究吧。记住,学习编程可不能偷懒哦

    procedure ListBox_MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ListBox_MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  public
    { Public declarations }
  end;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Self.Font.Name := Tahoma;
  InitListBox;
  CreateTipsWindow;
end;

inherited;

procedure TForm1.WMNotify(var Msg: TMessage);
var
  phd :PHDNotify;
  NMTTDISPINFO: PNMTTDispInfo;
begin
  phd := PHDNotify(Msg.lParam);
  if phd.Hdr.hwndFrom = GHWND then
  begin
    if phd.Hdr.code = TTN_NEEDTEXT then
    begin
      NMTTDISPINFO := PNMTTDispInfo(phd);
      NMTTDISPINFO.lpszText := PChar(ListBox1.Items[CurrentIndex]);
    end;
  end;
end;

end;

//------------------------------------------------------------------------------
//  在 ListBox 上实现 In-place Tooltips
//  原创作者:Joe Huang                 Email:[email protected]
//
//------------------------------------------------------------------------------

procedure WMNCHitTest(var Msg:TWMNCHitTest);message WM_NCHittest;

  SendMessage(GHWND, WM_SETFONT, ListBox1.Font.Handle, Integer(LongBool(false)));
  SendMessage(GHWND,TTM_ADDTOOL,0,Integer(@ti));
end;

inherited;

interface

Canvas.Font.Color:=clBlack;

  仔细研究一下程序中有关计算的几个句子,试着改变某个数字看一看,这将有助于你理解程序。

Form1: TForm1;

procedure DrawCaptButton;

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);

Result:=htCaptionBtn;

DrawCaptButton;

xFrame:=GetSystemMetrics(SM_CXFRAME);

end;

{ Private declarations }

 

Canvas.TextRect(R,R.Left+2,R.Top+2,?);

Canvas.Handle:=0;

begin

yFrame:=GetSystemMetrics(SM_CYFRAME);

procedure WMSetText(var Msg:TWMSetText);message WM_SetText;

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);

end;

Canvas.Handle:=GetWindowDC(Self.Handle);

Perform(WM_NCACTIVATE,Word(Active),0);

implementation

begin

CaptionBtn:=Bounds(Width-xFrame-4*xSize+2,yFrame+2,xSize+1,ySize-4);

procedure TForm1.WMSetText(var Msg: TWMSetText);

with Msg do

xFrame,yFrame,xSize,ySize:Integer;

unit Unit1;

end;

var

with CaptionBtn do

var

begin

xSize:=GetSystemMetrics(SM_CXSIZE);

begin

rocedure WMNCPaint(var Msg:TWMNCPaint);message WM_NCPaint;

ySize:=GetSystemMetrics(SM_CYSIZE);

begin

R:TRect;

procedure FormResize(Sender: TObject);

begin

finally

private

DrawButtonFace(Canvas,CaptionBtn,1,bsAutoDetect,False,False,False);

procedure TForm1.DrawCaptButton;

procedure TForm1.WMNCActivate(var Msg: TWMNCActivate);

begin

end;

Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

public

showmessage(成功了!);

procedure WMNCActivate(var Msg:TWMNCActivate);message WM_NCActivate;

uses

type

CaptionBtn:TRect;

{ Public declarations }

ReleaseDC(Self.Handle,Canvas.Handle);

inherited;

本文由美高梅网址发布于美高梅游戏官网网站,转载请注明出处:在窗口标题区添加按钮,让IE右键失效

上一篇:没有了 下一篇:P1982小朋友数字
猜你喜欢
热门排行
精彩图文