- {
- ALScreenSnap v1.02
- Description:
- This component allows a form to snap to the edges of the screen when dragged
- and released.
- History:
- v1.0 17-Jul-1999 Initial release.
- v1.01 20-Nov-1999 Fixed access violation when destroying component at design
- time. Will now raise exception if owner is not a form and
- will only allow one instance per form.
- v1.02 15-Dec-2001 Will now work properly under the new Windows XP interface
- style.
- }
- unit ALScreenSnap;
- interface
- uses
- Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
- ShellAPI;
- type
- TALScreenSnap = class(TComponent)
- private
- OldWndProc, NewWndProc: Pointer;
- fActive: Boolean;
- fThreshold: Integer;
- procedure NewWndMethod(var Msg: TMessage);
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- published
- property Active: Boolean read fActive write fActive default True;
- property Threshold: Integer read fThreshold write fThreshold default 30;
- end;
- procedure Register;
- implementation
- procedure Register;
- begin
- RegisterComponents('ALComps', [TALScreenSnap]);
- end;
- { TALScreenSnap }
- constructor TALScreenSnap.Create(AOwner: TComponent);
- var
- i: Integer;
- begin
- // Only allow one instance per form
- for i := 0 to AOwner.ComponentCount-1 do
- if AOwner.Components[i] is TALScreenSnap then
- raise Exception.Create('TALScreenSnap component cannot be duplicated in ' + AOwner.Name);
- inherited;
- // Check if the owner is a form
- if (Owner = nil) or not(AOwner is TForm) then
- raise Exception.Create('Owner of TALScreenSnap component must be a form');
- // Form subclassing
- if not(csDesigning in ComponentState) then
- begin
- NewWndProc := MakeObjectInstance(NewWndMethod);
- OldWndProc := Pointer(SetWindowLong(TForm(Owner).Handle, gwl_WndProc, Longint(NewWndProc)));
- end
- else
- begin
- NewWndProc := nil;
- OldWndProc := nil;
- end;
- fActive := True;
- fThreshold := 30;
- end;
- destructor TALScreenSnap.Destroy;
- begin
- if Assigned(NewWndProc) then
- FreeObjectInstance(NewWndProc);
- inherited;
- end;
- procedure TALScreenSnap.NewWndMethod(var Msg: TMessage);
- var
- Pabd: AppBarData;
- ScreenWidth, ScreenHeight: Integer;
- ScreenRect, TaskBarRect: TRect;
- begin
- if (Msg.Msg = WM_EXITSIZEMOVE) and Active then
- begin
- Pabd.cbSize := SizeOf(APPBARDATA);
- SHAppBarMessage(ABM_GETTASKBARPOS, Pabd);
- TaskBarRect := Pabd.rc;
- ScreenWidth := GetSystemMetrics(SM_CXSCREEN);
- ScreenHeight := GetSystemMetrics(SM_CYSCREEN);
- ScreenRect := Rect(0, 0, ScreenWidth, ScreenHeight);
- if (TaskBarRect.Left < 1) and (TaskBarRect.Bottom >= ScreenHeight) and (TaskBarRect.Right >= ScreenWidth) then
- // Bottom
- ScreenRect.Bottom := TaskBarRect.Top
- else if (TaskBarRect.Top < 1) and (TaskBarRect.Left < 1) and (TaskBarRect.Right >= ScreenWidth) then
- // Top
- ScreenRect.Top := TaskBarRect.Bottom
- else if (TaskBarRect.Left < 1) and (TaskBarRect.Top < 1) and (TaskBarRect.Bottom >= ScreenHeight) then
- // Left
- ScreenRect.Left := TaskBarRect.Right
- else if (TaskBarRect.Right >= ScreenWidth) and (TaskBarRect.Top < 1) and (TaskBarRect.Bottom >= ScreenHeight) then
- // Right
- ScreenRect.Right := TaskBarRect.Left;
- // Position form
- if TForm(Owner).Left < ScreenRect.Left + fThreshold then
- TForm(Owner).Left := ScreenRect.Left;
- if TForm(Owner).Top < ScreenRect.Top + fThreshold then
- TForm(Owner).Top := ScreenRect.Top;
- if TForm(Owner).Left+TForm(Owner).Width > ScreenRect.Right-fThreshold then
- TForm(Owner).Left := ScreenRect.Right-TForm(Owner).Width;
- if TForm(Owner).Top+TForm(Owner).Height > ScreenRect.Bottom-fThreshold then
- TForm(Owner).Top := ScreenRect.Bottom-TForm(Owner).Height;
- end;
- Msg.Result := CallWindowProc(OldWndProc, TForm(Owner).Handle, Msg.Msg, Msg.WParam, Msg.LParam);
- end;
- end.
- //该片段来自于http://www.codesnippet.cn/detail/111120137024.html
来源: http://www.codesnippet.cn/detail/111120137024.html