单击PageControl中的右上方的左右箭头时,PageControl的执行结果让人很不满意,我想让它执行我的自定义过程!
下面是ANiDelphi大侠写的组件:
unit Unit1;
interface
uses
Windows, Messages, Classes, ComCtrls;
type
TLRClickingEvent = procedure(Sender: TObject; var AllowClick: Boolean) of Object;
TLRPageControl = class(TPageControl)
private
IsLeftBtn: Boolean;
FOnLeftClick, FOnRightClick: TNotifyEvent;
FOnLRClicking: TLRClickingEvent;
procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
procedure DoLeftClick;
procedure DoRightClick;
procedure DoLRClicking(var AllowClick: Boolean);
published
property OnLeftClick: TNotifyEvent read FOnLeftClick write FOnLeftClick;
property OnLRClicking: TLRClickingEvent read FOnLRClicking write FOnLRClicking;
property OnRightClick: TNotifyEvent read FOnRightClick write FOnRightClick;
end;
implementation
uses
CommCtrl;
{ TLRPageControl }
procedure TLRPageControl.DoLeftClick;
begin
if Assigned(FOnLeftClick) then FOnLeftClick(Self);
end;
procedure TLRPageControl.DoLRClicking(var AllowClick: Boolean);
begin
if Assigned(FOnLRClicking) then FOnLRClicking(Self, AllowClick);
end;
procedure TLRPageControl.DoRightClick;
begin
if Assigned(FOnRightClick) then FOnRightClick(Self);
end;
procedure TLRPageControl.WMHScroll(var Message: TWMHScroll);
begin
inherited;
if Message.ScrollCode = SB_THUMBPOSITION then
if IsLeftBtn then DoLeftClick
else DoRightClick;
end;
procedure TLRPageControl.WMNotify(var Message: TWMNotify);
var
AllowClick: Boolean;
begin
inherited;
with Message do
if NMHdr^.code = UDN_DELTAPOS then
begin
IsLeftBtn := PNMUpDown(NMHdr).iDelta < 0;
AllowClick := not LongBool(Result);
DoLRClicking(AllowClick);
LongBool(Result) := not AllowClick;
end;
end;
end.