那位高手帮我修改一下这个控件(有源码如下)(50分)

  • 主题发起人 主题发起人 Jhdandcl
  • 开始时间 开始时间
J

Jhdandcl

Unregistered / Unconfirmed
GUEST, unregistred user!
我刚写了个控件,主要功能是把指定TpopupMenu菜单类容添加到窗体系统菜单里,
不爽的是FORM被CREATE 后,窗体的系统菜单有恢复原状,(当然我可以在窗体CREATE后
在OPEN，去实现我的功能!不过那样的话.....）

代码如下:那为大虾帮我想想办法.

{*******************************************************}
{ }
{ Borland Delphi Run-time Library }
{ }
{ Copyright (c) 2001-2001, Oncor information }
{ }
{ Translator: 江厚东 }
{ }
{ E_mail: jhdandcl@163.net }
{*******************************************************}




unit SystemMenu;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,MenuS;

type
TSystemMenu = class(TComponent)
private
{ Private declarations }
Factive :Boolean ;
FpopupMenu :TPopupMenu ;
FWnd :HWND ;
Fmenu :HMENU ;
FoldWinProc:FARPROC ;
FNewWinProc:FARPROC ;
procedure AppendMenuToSysmenu();
procedure DeleteMenuFrSysmenu();
procedure SetActive(value :Boolean );
procedure SetPopMenu(value:TPopupMenu );
procedure _SysCommand(var Message :TMessage);
protected
{ Protected declarations }
procedure WndProc(var Message: TMessage);
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy ;override;
procedure Open;
procedure Close;
published
{ Published declarations }
property Active : Boolean Read Factive Write SetActive;
property PopMenu: TPopupMenu Read FPopupMenu Write SetPopMenu;
end;

procedure Register;

implementation


{TsystemMenu}

constructor TSystemMenu.Create (AOwner :TComponent);
begin
inherited;
if (Owner is TForm ) then
begin
FWnd := (Owner as TForm) .Handle ;
Fmenu := GetSystemMenu (FWnd ,False );
FoldWinProc := pointer(GetWindowLong (FWnd ,GWL_WNDPROC));
Factive := False ;
end
else
begin
Raise Exception .Create ('The owner muse be TForm!');
end;
end;

destructor TSystemMenu.Destroy ;
begin
Close ;
inherited Destroy ;
end;

procedure TSystemMenu.WndProc(var Message: TMessage);
begin
with Message do
begin
case Msg of
WM_SYSCOMMAND : _SysCommand( Message );
else
Result := CallWindowProc(FoldWinProc , FWnd , Msg, wParam, lParam);
end;
end;
end;


procedure TSystemMenu._SysCommand (var Message :TMessage);
var
i:Byte ;
begin
with TWMCOMMAND(Message) do
begin
for i:= 0 to FpopupMenu .Items .Count - 1 do
if TWMCOMMAND(Message).ItemID = FpopupMenu .Items .Command then
begin
FpopupMenu .Items .Click ;
end;
end;
CallWindowProc(FoldWinProc , FWnd ,Message. Msg,Message . wParam,Message .lParam);
end;

procedure TsystemMenu.AppendMenuToSysmenu ();
var
i:Integer ;
begin

for i:=0 to FpopupMenu .Items .Count - 1 do
begin
AppendMenu (FMenu ,MF_BYPOSITION ,i+1,
PCHAR(FpopupMenu .Items .Items .Caption ));
end;
DrawMenuBar (FWnd );
end;

procedure TsystemMenu.DeleteMenuFrSysmenu ;
var
i:Integer ;
begin
for i:=0 to FpopupMenu .Items .Count - 1 do
begin
DeleteMenu(Fmenu ,i+1,MF_BYCOMMAND );
end;
DrawMenuBar (FWnd );
end;

procedure TsystemMenu.SetPopMenu (Value :TPopupMenu);
begin
FpopupMenu := value ;
end;

procedure TSystemMenu.SetActive(value :Boolean );
begin
if (value = True) and ( Factive = False ) then
begin
if FpopupMenu <> nil then
begin
AppendMenuTosysmenu();
Factive := value ;
FNewWinProc := MakeObjectInstance (WndProc );
FoldWinProc := pointer(GetWindowLong (FWnd ,GWL_WNDPROC ));
SetWindowLong(FWnd , GWL_WNDPROC, LongInt(FNewWinProc));
end;
end;
if (Value = False) and ( Factive = True ) then
begin
if FpopupMenu <> nil then
begin
DeleteMenuFrSysmenu() ;
Factive := value ;
SetWindowLong(FWnd , GWL_WNDPROC, LongInt(FoldWinProc ));
FreeObjectInstance(FNewWinProc);
end;
end;
end;

procedure TSystemMenu.Open ;
begin
SetActive (True);
end;

procedure TsystemMenu.Close ;
begin
SetActive (False);
end;

procedure Register;
begin
RegisterComponents('Samples', [TSystemMenu]);
end;

end.

 
1、把你的代码改为：
procedure TSystemMenu.SetActive(value :Boolean );
begin
if FActive <> Value then
begin
FActive := Value;
if FActive then
begin
if Assigned(FPopupMenu) then
begin
AppendMenuTosysmenu();
Factive := value ;
FNewWinProc := MakeObjectInstance (WndProc );
FoldWinProc := pointer(GetWindowLong (FWnd ,GWL_WNDPROC ));
SetWindowLong(FWnd , GWL_WNDPROC, LongInt(FNewWinProc));
end;
end else begin
if Assigned(FPopupMenu) then
begin
DeleteMenuFrSysmenu() ;
Factive := value ;
SetWindowLong(FWnd , GWL_WNDPROC, LongInt(FoldWinProc ));
FreeObjectInstance(FNewWinProc);
end;
end;
end;
end;

2、然后再在protected中加入：
procedure Loaded; override;

3、执行部分加入：
procedure TSystemMenu.Loaded;
begin
if Active then
begin
Active := False;
Active := True;
end;
inherited;
end;

搞掂：）

原因：
1、控件的发布属性在运行时装载有个顺序，你的Active属性比PopupMenu先装载，结果
执行SetAcive时FPopupMenu为nil，于是FActive仍为False。
2、控件提供一个保护方法Loaded供重载，该过程在控件的属性全部装载以后调用，所以可以在
这里检测Active并做相应设置。

 
刚才写快了，上面代码应该是：
procedure TSystemMenu.Loaded;
begin
inherited;
if Active then
begin
FActive := False; //直接赋值
Active := True;
end;
end;

 
yygw : 还是不行啊!,
以下是按按你所言修改后的代码:
{*******************************************************}
{ }
{ Borland Delphi Run-time Library }
{ }
{ Copyright (c) 2001-2001, Oncor information }
{ }
{ Translator: 江厚东 }
{ }
{ E_mail: jhdandcl@163.net }
{*******************************************************}




unit SystemMenu;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,MenuS;

type
TSystemMenu = class(TComponent)
private
{ Private declarations }
Factive :Boolean ;
FpopupMenu :TPopupMenu ;
FWnd :HWND ;
Fmenu :HMENU ;
FoldWinProc:FARPROC ;
FNewWinProc:FARPROC ;
procedure AppendMenuToSysmenu();
procedure DeleteMenuFrSysmenu();
procedure SetActive(value :Boolean );
procedure SetPopMenu(value:TPopupMenu );
procedure _SysCommand(var Message :TMessage);
protected
{ Protected declarations }
procedure WndProc(var Message: TMessage);
procedure Loaded;override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy ;override;
procedure Open;
procedure Close;
published
{ Published declarations }
property Active : Boolean Read Factive Write SetActive;
property PopMenu: TPopupMenu Read FPopupMenu Write SetPopMenu;
end;

procedure Register;

implementation


{TsystemMenu}

constructor TSystemMenu.Create (AOwner :TComponent);
begin
inherited;
if (Owner is TForm ) then
begin
FWnd := (Owner as TForm) .Handle ;
Fmenu := GetSystemMenu (FWnd ,False );
FoldWinProc := pointer(GetWindowLong (FWnd ,GWL_WNDPROC));
Factive := False ;
end
else
begin
Raise Exception .Create ('The owner muse be TForm!');
end;
end;

destructor TSystemMenu.Destroy ;
begin
Close ;
inherited Destroy ;
end;

procedure TSystemMenu.WndProc(var Message: TMessage);
begin
with Message do
begin
case Msg of
WM_SYSCOMMAND : _SysCommand( Message );
else
Result := CallWindowProc(FoldWinProc , FWnd , Msg, wParam, lParam);
end;
end;
end;


procedure TSystemMenu._SysCommand (var Message :TMessage);
var
i:Byte ;
begin
with TWMCOMMAND(Message) do
begin
for i:= 0 to FpopupMenu .Items .Count - 1 do
if TWMCOMMAND(Message).ItemID = FpopupMenu .Items .Command then
begin
FpopupMenu .Items .Click ;
end;
end;
CallWindowProc(FoldWinProc , FWnd ,Message. Msg,Message . wParam,Message .lParam);
end;

procedure TsystemMenu.AppendMenuToSysmenu ();
var
i:Integer ;
begin

for i:=0 to FpopupMenu .Items .Count - 1 do
begin
AppendMenu (FMenu ,MF_BYPOSITION ,i+1,
PCHAR(FpopupMenu .Items .Items .Caption ));
end;
DrawMenuBar (FWnd );
end;

procedure TsystemMenu.DeleteMenuFrSysmenu ;
var
i:Integer ;
begin
for i:=0 to FpopupMenu .Items .Count - 1 do
begin
DeleteMenu(Fmenu ,i+1,MF_BYCOMMAND );
end;
DrawMenuBar (FWnd );
end;

procedure TsystemMenu.SetPopMenu (Value :TPopupMenu);
begin
FpopupMenu := value ;
end;

procedure TSystemMenu.SetActive(value :Boolean );
begin
if FActive <> Value then
begin
FActive := Value;
if FActive then
begin
if Assigned(FPopupMenu) then
begin
AppendMenuTosysmenu();
Factive := value ;
FNewWinProc := MakeObjectInstance (WndProc );
FoldWinProc := pointer(GetWindowLong (FWnd ,GWL_WNDPROC ));
SetWindowLong(FWnd , GWL_WNDPROC, LongInt(FNewWinProc));
end;
end else begin
if Assigned(FPopupMenu) then
begin
DeleteMenuFrSysmenu() ;
Factive := value ;
SetWindowLong(FWnd , GWL_WNDPROC, LongInt(FoldWinProc ));
FreeObjectInstance(FNewWinProc);
end;
end;
end;
end;
{
procedure TSystemMenu.SetActive(value :Boolean );
begin
if (value = True) and ( Factive = False ) then
begin
if FpopupMenu <> nil then
begin
AppendMenuTosysmenu();
Factive := value ;
FNewWinProc := MakeObjectInstance (WndProc );
FoldWinProc := pointer(GetWindowLong (FWnd ,GWL_WNDPROC ));
SetWindowLong(FWnd , GWL_WNDPROC, LongInt(FNewWinProc));
end;
end;
if (Value = False) and ( Factive = True ) then
begin
if FpopupMenu <> nil then
begin
DeleteMenuFrSysmenu() ;
Factive := value ;
SetWindowLong(FWnd , GWL_WNDPROC, LongInt(FoldWinProc ));
FreeObjectInstance(FNewWinProc);
end;
end;
end;
}
procedure TSystemMenu.Open ;
begin
SetActive (True);
end;

procedure TsystemMenu.Close ;
begin
SetActive (False);
end;

procedure TSystemMenu.Loaded;
begin
inherited;
if Active then
begin
FActive := False; //直接赋值
Active := True;
end;
end;

procedure Register;
begin
RegisterComponents('Samples', [TSystemMenu]);
end;

end.
 
又来晚了...
 

唉, DFW 上高手这么多，为什么没有多几位像yygw那样,

能够静下心来读我的这段代码,帮我思考呢!


 
再申明一个变量好了,代码如下：

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,MenuS;

type
TSystemMenu = class(TComponent)
private
{ Private declarations }
Factive :Boolean ;
ffff:Boolean;
FpopupMenu :TPopupMenu ;
FWnd :HWND ;
Fmenu :HMENU ;
FoldWinProc:FARPROC ;
FNewWinProc:FARPROC ;
procedure AppendMenuToSysmenu();
procedure DeleteMenuFrSysmenu();
procedure SetActive(value :Boolean );
procedure SetPopMenu(value:TPopupMenu );
procedure _SysCommand(var Message :TMessage);
protected
{ Protected declarations }
procedure WndProc(var Message: TMessage);
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy ;override;
procedure loaded;override;
procedure Open;
procedure Close;
published
{ Published declarations }
property Active : Boolean Read Factive Write SetActive;
property PopMenu: TPopupMenu Read FPopupMenu Write SetPopMenu;
end;

procedure Register;

implementation


{TsystemMenu}

constructor TSystemMenu.Create (AOwner :TComponent);
begin
inherited;
if (Owner is TForm ) then
begin
FWnd := (Owner as TForm) .Handle ;
Fmenu := GetSystemMenu (FWnd ,False );
FoldWinProc := pointer(GetWindowLong (FWnd ,GWL_WNDPROC));
Factive := False ;
end
else
begin
Raise Exception .Create ('The owner muse be TForm!');
end;
end;

destructor TSystemMenu.Destroy ;
begin
Close ;
inherited Destroy ;
end;

procedure TSystemMenu.WndProc(var Message: TMessage);
begin
with Message do
begin
case Msg of
WM_SYSCOMMAND : _SysCommand( Message );
else
Result := CallWindowProc(FoldWinProc , FWnd , Msg, wParam, lParam);
end;
end;
end;


procedure TSystemMenu._SysCommand (var Message :TMessage);
var
i:Byte ;
begin
with TWMCOMMAND(Message) do
begin
for i:= 0 to FpopupMenu .Items .Count - 1 do
if TWMCOMMAND(Message).ItemID = FpopupMenu .Items .Command then
begin
FpopupMenu .Items .Click ;
end;
end;
CallWindowProc(FoldWinProc , FWnd ,Message. Msg,Message . wParam,Message .lParam);
end;

procedure TsystemMenu.AppendMenuToSysmenu ();
var
i:Integer ;
begin

for i:=0 to FpopupMenu .Items .Count - 1 do
begin
AppendMenu (FMenu ,MF_BYPOSITION ,i+1,
PCHAR(FpopupMenu .Items .Items .Caption ));
end;
DrawMenuBar (FWnd );
end;

procedure TsystemMenu.DeleteMenuFrSysmenu ;
var
i:Integer ;
begin
for i:=0 to FpopupMenu .Items .Count - 1 do
begin
DeleteMenu(Fmenu ,i+1,MF_BYCOMMAND );
end;
DrawMenuBar (FWnd );
end;

procedure TsystemMenu.SetPopMenu (Value :TPopupMenu);
begin
FpopupMenu := value ;
end;

procedure TSystemMenu.SetActive(value :Boolean );
begin
ffff:=value;
if (value = True) and ( Factive = False ) then
begin
if FpopupMenu <> nil then
begin
AppendMenuTosysmenu();
Factive := value ;
FNewWinProc := MakeObjectInstance (WndProc );
FoldWinProc := pointer(GetWindowLong (FWnd ,GWL_WNDPROC ));
SetWindowLong(FWnd , GWL_WNDPROC, LongInt(FNewWinProc));
end;
end;
if (Value = False) and ( Factive = True ) then
begin
if FpopupMenu <> nil then
begin
DeleteMenuFrSysmenu() ;
Factive := value ;
SetWindowLong(FWnd , GWL_WNDPROC, LongInt(FoldWinProc ));
FreeObjectInstance(FNewWinProc);
end;
end;
end;

procedure TSystemMenu.Open ;
begin
SetActive (True);
end;

procedure TsystemMenu.Close ;
begin
SetActive (False);
end;

procedure Register;
begin
RegisterComponents('Samples', [TSystemMenu]);
end;

procedure TSystemMenu.loaded;
begin
inherited;
if not(csDesigning in ComponentState) then
SetActive(self.ffff);
end;
 
To Jhdandcl:
我在Delphi 5.0下用你改过的代码没有问题啊！你在哪试的？
我也喜欢写控件，有兴趣可以到我的网站http://yygw.126.com上看看我写的免费控件。
 
多谢yygw.
 
您必须登录或注册才可回复。

Similar threads

L
发布一个显示点阵字的控件，UP得分 (100分)
回复
14
查看
324
LeonSu
L
Q
我初学,自己照书上写了个组件,可是在组件面板上没有显示!源码如下(100分)
回复
6
查看
268
qingfei
Q
L
发布一个显示点阵字的控件(100分)
回复
9
查看
226
LeonSu
L
C
系统托盘的问题。鼠标一移动到图表上，图表就消失了，大家帮我看看。60分全部家当了。(60分)
回复
7
查看
247
coolingxyz
C
陈
给shape控件加上运行时改变大小的特性（帮忙找找错误谢谢）。(100分)
回复
13
查看
237
Another_eYes
A
后退
顶部