完美解决方法:
unit ModalForm;
{$IFNDEF _DEBUG_}
{$D-}
{$ENDIF}
{********************************************************************}
{* *}
{* Base Form for Modal Dialog *}
{* Copyright Kingron 2002.10.22 *}
{* WEB:http://kingron.myetang.com *}
{* Bug Report: Kingron@163.net *}
{* *}
{********************************************************************}
interface
uses
Windows, Messages, SysUtils, Classes, Forms, Controls, StdCtrls, Buttons,
ExtCtrls;
type
TCallBackProc = procedure(AForm: TForm) of object;
type
TFrmModal = class(TForm)
btnCancel: TButton;
btnOk: TButton;
bvlSpaceline: TBevel;
lblShadow: TLabel;
lblDivid: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject
var Action: TCloseAction);
procedure FormDestroy(Sender: TObject);
private
FAnimateStyle: integer;
OldWndProc: Pointer;
NewWndProc: Pointer;
procedure Hook;
procedure UnHook;
procedure Hooked(var Msg: TMessage);
procedure WMSysCommand(var Msg: TWMCommand)
message WM_SYSCOMMAND;
protected
{ Private declarations }
procedure CreateParams(var Para: TCreateParams)
override;
procedure DoShow
override;
published
property AnimateStyle: integer read FAnimateStyle write FAnimateStyle;
public
{ Public declarations }
class function Execute(BeforeShow: TCallBackProc = nil;
AfterClose: TCallBackProc = nil): TModalResult
virtual;
end;
implementation
{$R *.DFM}
const
CM_POPUP_MENU = WM_USER + $500
{ User Define Message for Menu Popup }
CM_APP_MENU = $0313
{ System App Menu Popup Message }
procedure TFrmModal.FormCreate(Sender: TObject);
begin
inherited;
FAnimateStyle := 0;
Screen.Cursors[crHandPoint] := LoadCursor(0, IDC_HAND);
DeleteMenu(GetSystemMenu(Handle, False), SC_SIZE, MF_BYCOMMAND);
Hook;
end;
procedure TFrmModal.CreateParams(var Para: TCreateParams);
begin
inherited;
if Application.MainForm <> nil then Para.WndParent := GetActiveWindow;
end;
class function TFrmModal.Execute(BeforeShow: TCallBackProc = nil
AfterClose:
TCallBackProc = nil): TModalResult;
var
Form: TForm;
begin
Form := Create(Application);
with Form do
try
if Assigned(BeforeShow) then BeforeShow(Form);
Result := ShowModal;
if Assigned(AfterClose) then AfterClose(Form);
finally
Free;
end;
end;
procedure TFrmModal.FormShow(Sender: TObject);
procedure RefreshControl(Control: TControl)
{ Refresh Self and SubControls }
var
i: integer;
begin
Control.Invalidate;
if Control is TWinControl then
for i := 0 to TWinControl(Control).ControlCount - 1 do
RefreshControl(TWinControl(Control).Controls);
end;
begin
if (Position = poDesigned) and (FAnimateStyle <> 0) then
begin
AnimateWindow(Handle, 200, FAnimateStyle or AW_ACTIVATE)
{ Animate Window }
SetActiveWindow(Handle)
{ Active Window }
RefreshControl(Self)
{ Update UI }
end;
end;
procedure TFrmModal.FormClose(Sender: TObject
var Action: TCloseAction);
begin
if FAnimateStyle <> 0 then
AnimateWindow(Handle, 200, AW_HIDE or FAnimateStyle)
{ Animate Window }
end;
procedure TFrmModal.DoShow;
begin
inherited;
EnableWindow(Application.Handle, True);
end;
procedure TFrmModal.Hook;
begin
OldWndProc := Pointer(GetWindowLong(Application.Handle, GWL_WNDPROC));
{ Make New WndProc }
NewWndProc := Classes.MakeObjectInstance(Hooked);
if not (csDesigning in ComponentState) then
SetWindowLong(Application.Handle, GWL_WNDPROC, longint(NewWndProc));
end;
procedure TFrmModal.UnHook;
begin
{ Restore Old WndProc }
SetWindowLong(Application.Handle, GWL_WNDPROC, longint(OldWndProc));
if Assigned(NewWndProc) then Classes.FreeObjectInstance(NewWndProc);
NewWndProc := nil;
end;
procedure TFrmModal.Hooked(var Msg: TMessage);
begin
case Msg.Msg of
{ Dont use SendMessage! }
WM_SYSCOMMAND:
case Msg.WParam of
SC_MINIMIZE: SendMessage(Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0);
SC_RESTORE:
SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0);
end;
CM_APP_MENU:
with Mouse.CursorPos do
begin
SendMessage(Handle, CM_APP_MENU, Msg.WParam, MakeLParam(X, Y));
Exit;
end;
end;
{ Call Default Window Proc }
Msg.Result := CallWindowProc(OldWndProc, Application.Handle, Msg.Msg, Msg.wParam, Msg.lParam);
end;
procedure TFrmModal.FormDestroy(Sender: TObject);
begin
UnHook;
end;
procedure TFrmModal.WMSysCommand(var Msg: TWMCommand);
begin
case Msg.ItemID of
SC_RESTORE: Application.Restore;
SC_MINIMIZE: Application.Minimize;
end;
inherited;
end;
end.
////////////////////////////
object FrmModal: TFrmModal
Left = 450
Top = 102
Width = 388
Height = 396
BorderIcons = [biSystemMenu, biMinimize, biHelp]
Caption = 'Dialog'
Color = clBtnFace
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = '宋体'
Font.Style = []
OldCreateOrder = True
OnClose = FormClose
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
DesignSize = (
380
364)
PixelsPerInch = 96
TextHeight = 12
object bvlSpaceline: TBevel
Left = 160
Top = 315
Width = 214
Height = 5
Anchors = [akLeft, akRight, akBottom]
Shape = bsBottomLine
end
object lblShadow: TLabel
Left = 3
Top = 312
Width = 156
Height = 12
Anchors = [akLeft, akBottom]
Caption = 'Powered by Kylix.'
Enabled = False
Transparent = True
end
object lblDivid: TLabel
Left = 2
Top = 311
Width = 156
Height = 12
Anchors = [akLeft, akBottom]
Caption = 'Powered by Kylix.'
Enabled = False
Transparent = True
end
object btnCancel: TButton
Left = 307
Top = 329
Width = 68
Height = 26
Anchors = [akRight, akBottom]
Cancel = True
Caption = '&Cancel'
ModalResult = 2
TabOrder = 1
end
object btnOk: TButton
Left = 231
Top = 329
Width = 70
Height = 26
Anchors = [akRight, akBottom]
Caption = '&OK'
Default = True
ModalResult = 1
TabOrder = 0
end
end