Delphi
Статьи:

· Интерфейс

· WinAPI

· Компоненты

· Базы данных

· ShellAPI

Интерфейс пользователя

Как сделать перемещение формы, подобно WinAmp

Форма запоминает в какую сторону ее перемещают и затем возвращает это.

Unit frmSplashUnit;

Interface

Uses
    Windows,  Messages, SysUtils, Classes,
    Graphics, Controls, Forms,    Dialogs,
    ExtCtrls, StdCtrls, ComCtrls, Buttons,
    Menus,    ImgList;

Const
    MagneticField = 10;

Type
    TAlignSide1 = ( fasNone, fasTop, fasBottom, fasRight, fasLeft );
    TAlignSide = Set Of TAlignSide1;
    TfrmSplash =
        Class( TForm )
                bvlForm       : TBevel;
                lblAction     : TLabel;
                lblFile       : TLabel;
                bvlTitle      : TBevel;
                imgTitle      : TImage;
                lblProgress   : TLabel;
                pbProgress    : TProgressBar;
                bvlLine       : TBevel;
                cmdCancel     : TSpeedButton;
                popSystemMenu : TPopupMenu;
                mnuRestore    : TMenuItem;
                mnuMove       : TMenuItem;
                mnuSize       : TMenuItem;
                mnuMinimize   : TMenuItem;
                mnuMaximize   : TMenuItem;
                mnuBar1       : TMenuItem;
                mnuClose      : TMenuItem;
                ilSystemMenu  : TImageList;
                mnuBar2       : TMenuItem;
                mnuAbout      : TMenuItem;
                cmdAbout      : TSpeedButton;
                Procedure imgTitleMouseDown( Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer );
                Procedure imgTitleMouseUp( Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer );
                Procedure imgTitleMouseMove( Sender : TObject; Shift : TShiftState; X, Y : Integer );
                Procedure ClientAreaVerify( Var Msg : TWMSettingChange ); Message WM_SETTINGCHANGE;
                Procedure FormCreate( Sender : TObject );
                Procedure cmdCancelClick( Sender : TObject );
                Procedure FormResize( Sender : TObject );
            Private
            Public
                FSide   : TAlignSide;
                FMoving : Boolean;
                FOldX   : Integer;
                FOldY   : Integer;
                FArea   : TRect;
        End;

Var
    frmSplash : TfrmSplash;

Implementation

{$R *.DFM}

Procedure TfrmSplash.imgTitleMouseDown( Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer );
Begin
    FMoving := True;
    FOldX := X;
    FOldY := Y;
End;

Procedure TfrmSplash.imgTitleMouseUp( Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer );
Begin
    FMoving := False;
End;

Procedure TfrmSplash.imgTitleMouseMove( Sender : TObject; Shift : TShiftState; X, Y : Integer );
Var
    WorkArea: TRect;
Begin
    If ( SystemParametersInfo( SPI_GETWORKAREA, 0, @WorkArea, 0 ) ) Then
        FArea := WorkArea;
        If ( FMoving ) Then Begin
            FSide := [fasNone];
            If ( ( ( frmSplash.Left - ( FOldX - X ) ) > ( WorkArea.Left + MagneticField ) )
			      And ( ( frmSplash.Left - ( FOldX - X ) + 
			           frmSplash.Width ) < ( WorkArea.Right - MagneticField ) ) ) Then
                frmSplash.Left := frmSplash.Left - ( FOldX - X )
            Else
                If ( ( frmSplash.Left - ( FOldX - X ) ) <= ( WorkArea.Left + MagneticField ) ) Then Begin
                    frmSplash.Left := WorkArea.Left;
                    FSide := FSide + [fasLeft];
                End Else Begin
                    frmSplash.Left := WorkArea.Right - frmSplash.Width;
                    FSide := FSide + [fasRight];
                End;
            If ( ( ( frmSplash.Top - ( FOldY - Y ) ) > ( WorkArea.Top + MagneticField ) )
			      And ( ( frmSplash.Top - ( FOldY - Y ) +
			        frmSplash.Height ) < ( WorkArea.Bottom - MagneticField ) ) ) Then Begin
                frmSplash.Top := frmSplash.Top - ( FOldY - Y );
                FSide := [fasNone];
            End Else
                If ( ( frmSplash.Top - ( FOldY - Y ) ) <= ( WorkArea.Top + MagneticField ) ) Then Begin
                    frmSplash.Top := WorkArea.Top;
                    FSide := FSide + [fasTop];
                End Else Begin
                    frmSplash.Top := WorkArea.Bottom - frmSplash.Height;
                    FSide := FSide + [fasBottom];
                End;
            // Removes [fasNone] if anything else is found in FSide.
            If ( ( ( fasBottom In FSide ) Or ( fasTop In FSide ) Or ( fasLeft In FSide ) Or ( fasRight In FSide ) )
			And ( fasNone In FSide ) ) Then
                FSide := FSide - [fasNone];
        End;
End;

Procedure TfrmSplash.ClientAreaVerify( Var Msg : TWMSettingChange );
Var
    WorkArea : TRect;
Begin
    If ( Not( FMoving ) ) Then
        If ( SystemParametersInfo( SPI_GETWORKAREA, 0, @WorkArea, 0 ) ) Then Begin
            If ( fasLeft In FSide ) Then frmSplash.Left := WorkArea.Left;
            If ( fasRight In FSide ) Then frmSplash.Left := WorkArea.Right - frmSplash.Width;
            If ( fasTop In FSide ) Then frmSplash.Top := WorkArea.Top;
            If ( fasBottom In FSide ) Then frmSplash.Top := WorkArea.Bottom - frmSplash.Height;
        End;
End;

Procedure TfrmSplash.FormCreate( Sender : TObject );
Begin
    // TO DO: Check if form is on one of the corners.
    FSide   := [fasNone];
    FMoving := False;
End;

Procedure TfrmSplash.cmdCancelClick( Sender : TObject );
Begin
    Application.Terminate;
End;

Procedure TfrmSplash.FormResize( Sender : TObject );
Begin
    imgTitle.Width := bvlTitle.Width;
    bvlLine.Width := frmSplash.Width - ( 2 * bvlLine.Left );
    pbProgress.Width := frmSplash.Width - pbProgress.Left - bvlLine.Left;
    cmdCancel.Left := frmSplash.Width - cmdCancel.Width - cmdAbout.Left;
    cmdAbout.Top := frmSplash.Height - cmdAbout.Height - cmdAbout.Left;
    cmdCancel.Top := cmdAbout.Top;
    bvlLine.Top := cmdAbout.Top - bvlLine.Height;
End;

End.

Если Вы максимизируете форму, то появится ошибка. Просто добавьте строку в код, чтобы избежать этого

Хотя... В какой версии WinAmp Вы можете развернуть форму?

Procedure TfrmSplash.imgTitleMouseMove( Sender : TObject; Shift : TShiftState; X, Y : Integer );
Var
    WorkArea: TRect;
Begin
    If SystemParametersInfo( SPI_GETWORKAREA, 0, @WorkArea, 0 ) then
        FArea := WorkArea;
        If ( FMoving and not IsZoomed(frmSplash.Handle) ) Then Begin
            FSide := [fasNone];

Вот еще один пример:

//Сначала нужно объявить 3 переменные в Вашей форме:

  FMoving : Boolean;
  FOldX   : Integer;
  FOldY   : Integer;


//Затем, поместите этот код в Вашу форму:

Procedure TfrmSplash.frmSplashMouseDown( Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer );
Begin
    FMoving := True;
    FOldX := X;
    FOldY := Y;
End;

Procedure TfrmSplash.frmSplashMouseUp( Sender : TObject; Button : TMouseButton;
Shift : TShiftState; X, Y : Integer );
Begin
    FMoving := False;
End;

Procedure TfrmSplash.frmSplashMouseMove( Sender : TObject; Shift : TShiftState; X, Y : Integer );
Const
    BorderSize = 10; // Размер "магнитного поля".
Var
    WorkArea : TRect;
Begin
    If ( SystemParametersInfo( SPI_GETWORKAREA, 0, @WorkArea, 0 ) ) Then Begin // Soluzione con l'area di lavoro.
        If ( FMoving ) Then Begin
            If ( ( ( frmSplash.Left - ( FOldX - X ) ) > ( WorkArea.Left + BorderSize ) )
			      And ( ( frmSplash.Left - ( FOldX - X ) +
			      frmSplash.Width ) < ( WorkArea.Right - BorderSize ) ) ) Then
                frmSplash.Left := frmSplash.Left - ( FOldX - X )
            Else
                If ( ( frmSplash.Left - ( FOldX - X ) ) <= ( WorkArea.Left + BorderSize ) ) Then
                    frmSplash.Left := WorkArea.Left
                Else
                    frmSplash.Left := WorkArea.Right - frmSplash.Width;
            If ( ( ( frmSplash.Top - ( FOldY - Y ) ) > ( WorkArea.Top + BorderSize ) )
			      And ( ( frmSplash.Top - ( FOldY - Y ) + 
			       frmSplash.Height ) < ( WorkArea.Bottom - BorderSize ) ) ) Then
                frmSplash.Top := frmSplash.Top - ( FOldY - Y )
            Else
                If ( ( frmSplash.Top - ( FOldY - Y ) ) <= ( WorkArea.Top + BorderSize ) ) Then
                    frmSplash.Top := WorkArea.Top
                Else
                    frmSplash.Top := WorkArea.Bottom - frmSplash.Height;
        End;
    End Else Begin // Soluzione con il solo screen.
        If ( FMoving ) Then Begin
            If ( ( ( frmSplash.Left - ( FOldX - X ) ) > BorderSize )
			      And ( ( frmSplash.Left - ( FOldX - X ) + frmSplash.Width ) < ( 
			    Screen.Width - BorderSize ) ) ) Then
                frmSplash.Left := frmSplash.Left - ( FOldX - X )
            Else
                If ( ( frmSplash.Left - ( FOldX - X ) ) <= BorderSize ) Then
                    frmSplash.Left := 0
                Else
                    frmSplash.Left := Screen.Width - frmSplash.Width;
            If ( ( ( frmSplash.Top - ( FOldY - Y ) ) > BorderSize )
			      And ( ( frmSplash.Top - ( FOldY - Y ) + frmSplash.Height ) < (
			      Screen.Height - BorderSize ) ) ) Then
                frmSplash.Top := frmSplash.Top - ( FOldY - Y )
            Else
                If ( ( frmSplash.Top - ( FOldY - Y ) ) <= ( Screen.Height + BorderSize ) ) Then
                    frmSplash.Top := 0
                Else
                    frmSplash.Top := Screen.Height - frmSplash.Height;
        End;
    End;
End;

А теперь запустите Вашу программу и проверьте "магнетизм"

По материалам http://delphi3000.com