怎么用DELPHI实现奇怪或者图形窗体？？？？？？？？

Question

怎么用DELPHI实现奇怪或者图形窗体？？？？？？？？

Answer 1

1、用第三方控件；
2、用CreateRectRgn及相关方法

Answer 2

上边是PAS文件，下边是DFM文件
////unit1.pas
unit Unit1;interfaceuses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, Buttons;type
  TForm1 = class(TForm)
    ImageRight: TImage;
    ImageDown: TImage;
    Panel1: TPanel;
    ImageCenter: TImage;
    MemoRight: TMemo;
    MemoDown: TMemo;
    SpeedButtonRight: TSpeedButton;
    SpeedButtonDown: 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);
  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
  ///////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;end.///////unit1.dfm
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
    Lines.Strings = (
      'MemoDown')
    TabOrder = 2
  end
  object MemoRight: TMemo
    Left = 410
    Top = 52
    Width = 156
    Height = 225
    Lines.Strings = (
      'MemoRight')
    TabOrder = 1
  end
  object Panel1: 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
  end
end

Answer 3

unit Unit1;interfaceuses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  HTTPApp, SvcMgr, ExtCtrls, StdCtrls, Menus;type
  TForm1 = class(TForm)
    Image1: TImage;
    PopupMenu1: TPopupMenu;
    C1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    OriginalPos:TPoint;    // 记录原始位置
    CurrentPos:TPoint;     // 记录当前位置
    DownPos:TPoint;        // 记录鼠标按下时位置
    MouseLButtonDown:Boolean;   // 标记鼠标左键是否按下
  public    { Public declarations }
  end;var
  Form1: TForm1;implementation{$R *.DFM}procedure TForm1.FormCreate(Sender: TObject);
var
   hr :THandle;
begin
     MouseLButtonDown:=False;
     // 创建一个圆形窗口
     hr:=CreateEllipticRgn(0,0,Width,Height);
     SetWindowRgn(Handle,hr,True);
end;procedure TForm1.FormResize(Sender: TObject);
var
    hr :THandle;
begin
     // 刷新圆形窗口
     hr:=CreateEllipticRgn(0,0,width,height);
     setwindowrgn(handle,hr,true);
end;procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
     OriginalPos.x:=Form1.Left;         // 记录下原始坐标位置
     OriginalPos.y:=Form1.Top;
     DownPos.x:=X;                      // 鼠标按下的位置
     DownPos.y:=Y;
     DownPos:=ClientToScreen(DownPos);   // 将客户区坐标转换为屏幕坐标
     if Button = mbLeft then
          MouseLButtonDown:=True;
end;procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
     if MouseLButtonDown then
     begin
          CurrentPos.x:=X;
          CurrentPos.y:=Y;
          CurrentPos:=ClientToScreen(CurrentPos);  // 将客户区坐标转换为屏幕坐标
          // 确定窗体的新位置
          Form1.Left:=OriginalPos.x+(CurrentPos.x-DownPos.x);
          Form1.Top :=OriginalPos.y+(CurrentPos.y-DownPos.y);
     end;
end;procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
     MouseLButtonDown:=False;        // 鼠标左键弹起
end;
end.

Answer 4

将窗口定义为园角矩形的例子：
procedure TPortForm.FormCreate(Sender: Tobject);
var hr :thandle;
begin
hr:=createroundrectrgn(0,0,width,height,20,20);//定义园角矩形(win API函数)
setwindowrgn(handle,hr,true); //设置园角窗口
end;
为了使该窗口更好，应在onResize事件处理程序放相同的代码。
/////////////////////////////////////
用汉字做窗体形状
procedure TForm1.FormCreate(Sender: TObject);
var
rgn:HRGN;
begin
 BeginPath(Canvas.Handle);
 SetBkMode( Canvas.Handle, TRANSPARENT );
 Canvas.Font.Name:= '宋体';
 Canvas.Font.Size:=100;
 Canvas.TextOut( 20, 20, '漂亮吗?');//用"漂亮吗?"作为form的形状
 EndPath(Canvas.Handle);
 rgn:= PathToRegion(Canvas.Handle);
 SetWindowRgn( Handle, rgn, true );
end;

Answer 5

下面的内容摘自 <未经证实的葵花宝典>,感谢原作者利用win32 API函数setwindowrgn就可以将窗口定义为任何形状，以下是将窗口定义为园角矩形的例子：
procedure TPortForm.FormCreate(Sender: Tobject);
var hr :thandle;
begin
hr:=createroundrectrgn(0,0,width,height,20,20);//定义园角矩形(win API函数)
setwindowrgn(handle,hr,true); //设置园角窗口
end;
为了使该窗口更好，应在onResize事件处理程序放相同的代码。
/////////////////////////////////////
用汉字做窗体形状
procedure TForm1.FormCreate(Sender: TObject);
var
rgn:HRGN;
begin
 BeginPath(Canvas.Handle);
 SetBkMode( Canvas.Handle, TRANSPARENT );
 Canvas.Font.Name:= '宋体';
 Canvas.Font.Size:=100;
 Canvas.TextOut( 20, 20, '漂亮吗?');//用"漂亮吗?"作为form的形状
 EndPath(Canvas.Handle);
 rgn:= PathToRegion(Canvas.Handle);
 SetWindowRgn( Handle, rgn, true );
end;

Answer 6

to cg1120(代码最优化－§为这世界,添些美丽色彩§) 感谢!!!!!!!!!!感谢!!!!!!!!!!!!!!!!

Answer 7

例如：椭圆型窗体
(1)备一椭圆的图片，椭圆外部是Delphi可以透视的颜色，内部是不可透视的。
(2)窗体borderStyle属性设为bsNone
(3)窗体上放一个 TImage 部件:属性 Align=alClient ;  Picture=椭圆图片
(3)procedure TForm1.FormCreate(Sender: TObject);
   begin
     self.ClientWidth := HotImage1.Width ;
     self.ClientHeight := HotImage1.Height ;
     brush.style:=bsClear;
   end;