不规则窗体的弹出效果

(*//
标题:不规则窗体的弹出效果
说明:加上图片效果就好点
日期:2002-10-07
设计:Zswang
//*)unit Unit1;interfaceuses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, Buttons;type
  TForm1 = class(TForm)
    ImageRight: TImage;
    ImageDown: TImage;
    PanelCenter: TPanel;
    ImageCenter: TImage;
    MemoRight: TMemo;
    MemoDown: TMemo;
    SpeedButtonRight: TSpeedButton;
    SpeedButtonDown: TSpeedButton;
    SpeedButtonClose: TSpeedButton;
    procedure SpeedButtonRightClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure SpeedButtonDownClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ImageCenterMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure SpeedButtonCloseClick(Sender: TObject);
  private
    { Private declarations }
    FRGNRight: HRGN;
    FRGNDown: HRGN;
    FRGNCenter: HRGN;
    FRGNForm: HRGN;
    FShowRight: Boolean;
    FShowDown: Boolean;
    procedure SetShowRight(const Value: Boolean);
    procedure SetShowDown(const Value: Boolean);
    procedure ShowFormRgn;
  public
    { Public declarations }
    property ShowRight: Boolean read FShowRight write SetShowRight;
    property ShowDown: Boolean read FShowDown write SetShowDown;
  end;var
  Form1: TForm1;implementation{$R *.DFM}procedure TForm1.SpeedButtonRightClick(Sender: TObject);
begin
  ShowRight := not ShowRight;
end;procedure TForm1.SpeedButtonDownClick(Sender: TObject);
begin
  ShowDown := not ShowDown;
end;procedure TForm1.FormCreate(Sender: TObject);
begin
  with ImageCenter do begin
    Picture.Bitmap.Width := Width;
    Picture.Bitmap.Height := Height;
    Picture.Bitmap.Canvas.Brush.Color := clBlue;
    Picture.Bitmap.Canvas.FillRect(Rect(0, 0, Width, Height));
  end;  ///////Begin 创建不规则的区域
  { TODO : 修改区域 }
  FRGNRight := CreateRectRgn(
    ImageRight.BoundsRect.Left,
    ImageRight.BoundsRect.Top,
    ImageRight.BoundsRect.Right,
    ImageRight.BoundsRect.Bottom);  FRGNDown := CreateRectRgn(
    ImageDown.BoundsRect.Left,
    ImageDown.BoundsRect.Top,
    ImageDown.BoundsRect.Right,
    ImageDown.BoundsRect.Bottom);  FRGNCenter :=  CreateRectRgn(
    ImageCenter.BoundsRect.Left,
    ImageCenter.BoundsRect.Top,
    ImageCenter.BoundsRect.Right,
    ImageCenter.BoundsRect.Bottom);
  ///////End 创建不规则的区域
  
  ShowFormRgn;  DoubleBuffered := True;
  FShowRight := False;
  FShowDown := False;
end;procedure TForm1.SetShowRight(const Value: Boolean);
const
  {$J+}vChanging: Boolean = False;
const
  cOffset = 3;
var
  I: Integer;
  vStart, vEnd: Integer;
  vOffset: Integer; //偏移量
begin
  if FShowRight = Value then Exit;
  if vChanging then Exit;
  FShowRight := Value;
  vChanging := True;
  if FShowRight then begin
    vOffset := -cOffset;
    vStart := ImageRight.Left;
    vEnd := ImageRight.Left - ImageRight.Width + 20;
  end else begin
    vOffset := +cOffset;
    vStart := ImageRight.Left;
    vEnd := ImageRight.Left + ImageRight.Width - 20;
  end;
  I := vStart;
  while Abs(I - vEnd) > Abs(vOffset) do begin
    ImageRight.Left := I;
    MemoRight.Left := I + 1;
    SpeedButtonRight.Left := I + 170;
    Application.ProcessMessages;
    OffsetRgn(FRGNRight, vOffset, 0); //偏移区域
    ShowFormRgn;
    ClientWidth := I + ImageRight.Width + 2; //宽度改变
    Update;
    I := I + vOffset;
  end;
  vChanging := False;
end;procedure TForm1.SetShowDown(const Value: Boolean);
const
  {$J+}vChanging: Boolean = False;
const
  cOffset = 3;
var
  I: Integer;
  vStart, vEnd: Integer;
  vOffset: Integer; //偏移量
begin
  if FShowDown = Value then Exit;
  if vChanging then Exit;
  FShowDown := Value;
  vChanging := True;
  if FShowDown then begin
    vOffset := -cOffset;
    vStart := ImageDown.Top;
    vEnd := ImageDown.Top - ImageDown.Height + 20;
  end else begin
    vOffset := +cOffset;
    vStart := ImageDown.Top;
    vEnd := ImageDown.Top + ImageDown.Height - 20;
  end;
  I := vStart;
  while Abs(I - vEnd) > Abs(vOffset) do begin
    ImageDown.Top := I;
    MemoDown.Top := I + 1;
    SpeedButtonDown.Top := I + 95;
    Application.ProcessMessages;
    OffsetRgn(FRGNDown, 0, vOffset); //偏移区域
    ShowFormRgn;
    ClientHeight := I + ImageDown.Height + 2; //宽度改变
    Update;
    I := I + vOffset;
  end;
  vChanging := False;
end;procedure TForm1.FormDestroy(Sender: TObject);
begin
  DeleteObject(FRGNRight);
  DeleteObject(FRGNDown);
  DeleteObject(FRGNCenter);
  DeleteObject(FRGNForm);
end;procedure TForm1.ShowFormRgn;
begin
  ///////Begin 清除区域
  DeleteObject(FRGNForm);
  FRGNForm := CreateRectRgn(0, 0, 0, 0);
  ///////End 清除区域
  CombineRgn(FRGNForm, FRGNCenter, FRGNRight, RGN_OR);
  CombineRgn(FRGNForm, FRGNForm, FRGNDown, RGN_OR);
  SetWindowRgn(Handle, FRGNForm, True);
end;procedure TForm1.ImageCenterMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  ReleaseCapture;
  Perform(WM_SYSCOMMAND, SC_MOVE + 1, 0);
end;procedure TForm1.SpeedButtonCloseClick(Sender: TObject);
begin
  Close;
end;end.//------------------------------------------------------------------------object Form1: TForm1
  Left = 97
  Top = 22
  BorderStyle = bsNone
  Caption = 'Form1'
  ClientHeight = 486
  ClientWidth = 602
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object ImageRight: TImage
    Left = 408
    Top = 36
    Width = 190
    Height = 263
  end
  object ImageDown: TImage
    Left = 64
    Top = 368
    Width = 294
    Height = 115
  end
  object SpeedButtonRight: TSpeedButton
    Left = 576
    Top = 140
    Width = 17
    Height = 33
    OnClick = SpeedButtonRightClick
  end
  object SpeedButtonDown: TSpeedButton
    Left = 192
    Top = 464
    Width = 41
    Height = 17
    OnClick = SpeedButtonDownClick
  end
  object MemoDown: TMemo
    Left = 83
    Top = 369
    Width = 256
    Height = 80
    BevelKind = bkFlat
    Lines.Strings = (
      'MemoDown')
    TabOrder = 2
  end
  object MemoRight: TMemo
    Left = 410
    Top = 52
    Width = 156
    Height = 225
    BevelKind = bkFlat
    Lines.Strings = (
      'MemoRight')
    TabOrder = 1
  end
  object PanelCenter: TPanel
    Left = 0
    Top = 0
    Width = 409
    Height = 369
    BevelOuter = bvNone
    TabOrder = 0
    object ImageCenter: TImage
      Left = -2
      Top = 0
      Width = 411
      Height = 369
      ParentShowHint = False
      ShowHint = False
      OnMouseDown = ImageCenterMouseDown
    end
    object SpeedButtonClose: TSpeedButton
      Left = 380
      Top = 5
      Width = 23
      Height = 22
      OnClick = SpeedButtonCloseClick
    end
  end
end