窗体问题

Question

如何绘制一个圆角窗体，并能移动和通过拖拽改变大小。

Answer 1

将窗体BorderStyle设置成bsNone，放一个TShape控件到窗体上，Shape属性设置为stRoundRect，Align设置为alClient，然后重画自己的窗体为Shape的形状即可。

Answer 2

三方控件现成的，VcLSkin或者BSF都有

Answer 3

procedure TForm1.FormCreate(Sender: TObject);
begin
  SetwindowRgn(Handle, CreateRoundRectRgn(0, 0, Width, Height, 25, 25), True);
end;

Answer 4

用mysterx的方法吧
unit Unit1;interfaceuses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormResize(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure SetTheRegion;
    procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd); message WM_ERASEBKGND;
    procedure WMNCHitTest(var msg: TWMNCHitTest); message WM_NCHITTEST;
  end;var
  Form1: TForm1;implementationuses BmpRgn;{$R *.dfm}procedure TForm1.SetTheRegion;
var
  HR: HRGN;
begin
  Image1.Picture.Bitmap.Width := Self.Width;
  Image1.Picture.Bitmap.Height := Self.Height;
  BitBlt(Image1.Picture.Bitmap.Canvas.Handle, 0, 0, Width, Height, GetWindowDC(Handle), 0, 0, SRCCOPY);  HR := BmpToRegion(Self, Image1.Picture.Bitmap);
  SetWindowRgn(handle, HR, true);
  Invalidate;
end;procedure TForm1.WMEraseBkGnd(var Msg: TWMEraseBkGnd);
var
  Brush: TBrush;
begin
  Brush := TBrush.Create;
  Brush.Color := Color;
  FillRect(Msg.DC, ClientRect, Brush.Handle);
  Brush.Free;
  with Image1.Picture.Bitmap do
    BitBlt(Msg.DC, 0, 0, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);
  Msg.Result := 1;
end;procedure TForm1.WMNCHitTest(var msg: TWMNCHitTest);
var
  i: integer;
  p: TPoint;
  AControl: TControl;
  MouseOnControl: boolean;
begin
  inherited;
  if msg.result = HTCLIENT then
  begin
    p.x := msg.XPos;
    p.y := msg.YPos;
    p := ScreenToClient(p);
    MouseOnControl := false;
    for i := 0 to ControlCount - 1 do
    begin
      if not MouseOnControl
        then
      begin
        AControl := Controls[i];
        if ((AControl is TWinControl) or (AControl is TGraphicControl))
          and (AControl.Visible)
          then MouseOnControl := PtInRect(AControl.BoundsRect, p);
      end
      else
        break;
    end;
    if (not MouseOnControl) then msg.Result := HTCAPTION;
  end;
end;procedure TForm1.Button1Click(Sender: TObject);
begin
  Close;
end;procedure TForm1.FormResize(Sender: TObject);
begin
  //SetTheRegion;
  SetwindowRgn(Handle, CreateRoundRectRgn(0, 0, Width, Height, 25, 25), True);
end;end.

Answer 5

4楼朋友的方法好像只能create一个圆角窗体，好像并不能移动和通过拖拽改变大小啊

Answer 6

那是直接用背景图片画的，给你个例子：调用：
unit uDetail;interfaceuses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,
  Buttons, ExtCtrls, Grids, DBGrids, DB;type
  TfmDetail = class(TForm)
    ImageAll: TImage;
    LabTitle2: TLabel;
    LabTitle1: TLabel;
    Image3: TImage;
    btClose: TSpeedButton;
    DBGrid1: TDBGrid;
    DataSource1: TDataSource;
    procedure FormCreate(Sender: TObject);
    procedure btCloseClick(Sender: TObject);
  private
    { Private declarations }
    procedure SetTheRegion;
    procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd); message WM_ERASEBKGND;
    procedure WMNCHitTest(var msg: TWMNCHitTest); message WM_NCHITTEST;
  public
    { Public declarations }
  end;{var
  fmDetail: TfmDetail;}implementationuses BmpRgn;{$R *.dfm}procedure TfmDetail.SetTheRegion;
var HR: HRGN;
begin
  HR := BmpToRegion(Self, ImageAll.Picture.Bitmap);
  SetWindowRgn(Handle, HR, true);
  Invalidate;
end;procedure TfmDetail.FormCreate(Sender: TObject);
var
  sImage: String;
begin
  sImage := ExtractFilePath(Application.ExeName) + 'sDetail.bmp';
  if FileExists(sImage) then
  begin
    ImageAll.Picture.LoadFromFile(sImage);
    SetTheRegion;
  end;
end;procedure TfmDetail.WMEraseBkGnd(var Msg: TWMEraseBkGnd);
var Brush: TBrush;
begin
  Brush := TBrush.Create;
  Brush.Color := Color;
  FillRect(Msg.DC, ClientRect, Brush.Handle);
  Brush.Free;
  with ImageAll.Picture.Bitmap do
    BitBlt( Msg.DC, 0, 0, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);
  Msg.Result := 1;
end;procedure TfmDetail.WMNCHitTest(var msg: TWMNCHitTest);
var
  i: integer;
  p: TPoint;
  AControl: TControl;
  MouseOnControl: boolean;
begin
  inherited;
  if msg.result = HTCLIENT then begin
    p.x := msg.XPos;
    p.y := msg.YPos;
    p := ScreenToClient(p);
    MouseOnControl := false;
    for i := 0 to ControlCount-1 do begin
      if not MouseOnControl
      then begin
        AControl := Controls[i];
        if ((AControl is TWinControl) or (AControl is TGraphicControl))
          and (AControl.Visible)
        then MouseOnControl := PtInRect( AControl.BoundsRect, p);
      end
      else
        break;
    end;
    if (not MouseOnControl) then msg.Result := HTCAPTION;
  end;
end;

Answer 7

unit BmpRgn;interfaceuses
  Windows,SysUtils, Classes, Graphics, Dialogs, Forms;(***************************************************************************)
(*          This is the only function you need to call                     *)
(***************************************************************************)
(**)  function BmpToRegion( Form: TForm; Bmp: tbitmap): HRGN;            (**)
(***************************************************************************)
TYPE
  TBooleanArray = array of array of boolean;
  TPointsArray = array of TPoint;  TRGBTripleRow =array[0..30000]of trgbtriple;
  PRGBTripleRow=^TRGBTripleRow;
VAR
  Mask: TBooleanArray;
  Points: TPointsArray;  BmpWidth: integer;
  BmpHeight: integer;
  MaskWidth: integer;
  MaskHeight: integer;
  PointCount: integer;CONST
  ErrSuccess  = 0;
  ErrNoStart  = -1;
  ErrUnclosed = -2;
implementation(***************************************************************************)
(**)                                                                     (**)
(*   A few utility procedures and functions for debugging purposes         *)
(**)                                                                     (**)
(***************************************************************************)procedure ShowXY(s: string; x,y: integer);
begin
  ShowMessage( Format('%s %d,%d',[s,x,y]));
end;
procedure DumpMask( filename: string);
var f: TextFile; x,y: integer; c: char;
begin
  AssignFile( f, filename);
  Rewrite(f);
  for y := 0 to MaskHeight-1 do begin
    for x := 0 to MaskWidth-1 do begin
      if mask[x,y] then c := 'X' else c := '.';
      Write(f,c);
    end;
    Writeln(f);
  end;
  CloseFile( f);
end;
procedure DumpPoints( filename: string);
var f: TextFile; i: integer;
begin
  AssignFile( f, filename);
  Rewrite( f);
  if PointCount > 0 then begin
    for i := 0 to PointCount-1 do begin
      with Points[i] do writeln( f, Format('%d -> %d,%d',[i,x,y]));
    end;
  end else begin
    writeln(f, 'Points array is empty');
  end;
  CloseFile( f);
end;
procedure Init( w,h: integer);
begin
  BmpWidth   := w+2;
  BmpHeight  := h+2;
  MaskWidth  := BmpWidth*3;
  MaskHeight := BmpHeight*3;
  PointCount := 0;
  SetLength( Mask,    MaskWidth, MaskHeight);
  SetLength( Points,  BmpWidth * BmpHeight);
end;
procedure CleanupPointers;
begin
  Mask := nil;
  Points := nil;
end;procedure CreateMask(var Bmp: TBitmap);
var
  x,y:integer;
  r,g,b: byte;
  p: prgbtriplerow;
  TranspColor: TColor;
  Temp: TBitmap;  procedure SetMaskValues( value: boolean);
  var i,j: integer;
  begin
    for j := 0 to 2 do begin
      for i := 0 to 2 do begin
        mask[x*3+i,y*3+j] := value;
      end;
    end;
  end;begin
  TranspColor := Bmp.Canvas.Pixels[0,0];
  r := GetRValue( TranspColor);
  g := GetGValue( TranspColor);
  b := GetBValue( TranspColor);  Temp := TBitmap.Create;
  with Temp do begin
    Width := BmpWidth;
    Height := BmpHeight;
    Canvas.Brush.Color := TranspColor;
    Canvas.FillRect( Rect(0,0,BmpWidth,BmpHeight));
    Canvas.Draw(1,1,Bmp);
  end;
  Temp.PixelFormat := pf24bit;  for y := 0 to BmpHeight-1 do begin
    p := Temp.Scanline[y];
    for x := 0 to BmpWidth-1 do begin
      with p[x] do begin
        // set mask to false for transparent pixels
        if (rgbtred = r) and (rgbtgreen = g) and (rgbtblue = b)
        then SetMaskValues( false)
        else SetMaskValues( true);
      end;
    end;
  end;  Temp.Free;
end;function ConvertMaskToPoints: integer;
var
  x,y: integer;
  startx, starty: integer;
  nextx,  nexty:  integer;
  prev1x, prev1y: integer;
  prev2x, prev2y: integer;
  function Available(px,py: integer): boolean;
  begin
    result := (not ((px = prev1x) and (py = prev1y))) and
              (not ((px = prev2x) and (py = prev2y)));
  end;  function OnEdge(px,py: integer): boolean;
  begin
    result := (not mask[px+0,py-1]) or // north
              (not mask[px+1,py-1]) or // northeast
              (not mask[px+1,py+0]) or // east
              (not mask[px+1,py+1]) or // southeast
              (not mask[px+0,py+1]) or // south
              (not mask[px-1,py+1]) or // southwest
              (not mask[px-1,py+0]) or // west
              (not mask[px-1,py-1]);   // northwest
  end;  function SamePoint( p1,p2: TPoint): boolean;
  begin
    result := (p1.x = p2.x) and (p1.y = p2.y);
  end;begin
  PointCount := 0;  // find a coordinate where tracing can begin
  startx := -1;
  starty := -1;
  for y := 0 to MaskHeight-1 do begin
    for x := 0 to MaskWidth-1 do begin
      if (startx < 0) or (starty < 0) then begin
        if Mask[x,y] then begin
          startx := x;
          starty := y;
        end;
      end;
    end;
  end;  // if no starting point found, exit
  if (startx < 0) or (starty < 0) then begin
    result := ErrNoStart;
    exit;
  end;  // points coordinates are in actual size, not inflated size
  PointCount := 1;
  Points[0] := Point( startx div 3, starty div 3);  // at startx,starty begin tracing counter of mask
  nextx := startx;
  nexty := starty;
  x := startx;
  y := starty;
  if mask[x+1,y] then begin
    nextx := x+1;
    nexty := y;
  end else
  if mask[x,y+1] then begin
    nextx := x;
    nexty := y+1;
  end;  prev2x := 0;
  prev2y := 0;
  prev1x := x;
  prev1y := y;
  x := nextx;
  y := nexty;  repeat    // north
    if mask[x,y-1] and available(x,y-1) and onedge(x,y-1) then begin
      nextx := x;
      nexty := y-1;
    end else
    // east
    if mask[x+1,y] and available(x+1,y) and onedge(x+1,y) then begin
      nextx := x+1;
      nexty := y;
    end else
    // south
    if mask[x,y+1] and available(x,y+1) and onedge(x,y+1) then begin
      nextx := x;
      nexty := y+1;
    end else
    // west
    if mask[x-1,y] and available(x-1,y) and onedge(x-1,y) then begin
      nextx := x-1;
      nexty := y;
    end;    // if next not found, then unclosed path so exit
    if (nextx = x) and (nexty = y) then begin
      ShowXY('Unclosed at ',x,y);
      result := ErrUnclosed;
      exit;
    end;    // if we're not back at the start, add nextx, nexty to points
    if (nextx <> startx) or (nexty <> starty) then begin
      if  not SamePoint( Point(nextx div 3, nexty div 3), Points[ PointCount-1]) then begin
        inc( PointCount);
        Points[PointCount-1] := Point( nextx div 3, nexty div 3);
      end;
      prev2x := prev1x;
      prev2y := prev1y;
      prev1x := x;
      prev1y := y;
      x := nextx;
      y := nexty;
    end;  until (nextx = startx) and (nexty = starty);
  setlength( Points, PointCount);
  result := ErrSuccess;
end;// This routine shifts each point by a fixed amount, to compensate
// for forms with differing border styles.
procedure ShiftPoints( var points: tpointsarray; pointcount, xdelta, ydelta: integer);
var i: integer;
begin
  for i := 0 to pointcount-1 do begin
    points[i].x := points[i].x+xdelta;
    points[i].y := points[i].y+ydelta;
  end;
end;// This routine follows the sequence of points in the outline and
// using LineTo commands, creates a closed path that can then be
// converted to a region.
function PointsToRegion( dc: hDC; points: tpointsarray; pointcount: integer): HRGN;
var i: integer;
begin
  MoveToEx( dc, Points[0].x, Points[0].y, nil);
  BeginPath( dc);
  for i := 1 to pointcount-1 do with points[i] do lineto( dc, x,y);
  EndPath( dc);
  result := PathToRegion( dc);
end;
//---------------------------------------------------------------------
// This is the All-In-One routine and should be the only one that
// you need to call in your program. It calls everything above and
// if all goes well, Voila! - a form with a custom skin created from
// a bitmap.
//
// Parameters:
//   Form - your form (usually Self) in the form's OnCreate handler
//   Bmp  - the bitmap to use for the form's region.
//
// Returns:
//   If successful, a handle to the new region is returned which
//   can then be passed to SetWindowRgn. If not successful, the
//   return value is null, which can also be passed to SetWindowRgn
//   but only serves to draw the entire form.
//----------------------------------------------------------------------
function BmpToRegion( Form: TForm; Bmp: tbitmap): HRGN;
var
  DeltaX, DeltaY, Success: integer;
  rgn: HRGN;
  MenuHandle: HMENU;
begin  Init( Bmp.Width, Bmp.Height);
  CreateMask( Bmp);
  Success := ConvertMaskToPoints;  if Success = errSuccess then begin    DeltaX := -1;
    DeltaY := -1;
    case Form.BorderStyle of      bsDialog:
      begin
        DeltaX := DeltaX+GetSystemMetrics( sm_cxFixedFrame);
        DeltaY := DeltaY+GetSystemMetrics( sm_cyFixedFrame)
                        +GetSystemMetrics( sm_cyCaption);
      end;
      bsSingle:
      begin
        DeltaX := DeltaX+GetSystemMetrics( sm_cxFixedFrame);
        DeltaY := DeltaY+GetSystemMetrics( sm_cyFixedFrame)
                        +GetSystemMetrics( sm_cyCaption);
      end;
      bsSizeable:
      begin
        DeltaX := DeltaX+GetSystemMetrics( sm_cxSizeFrame);
        DeltaY := DeltaY+GetSystemMetrics( sm_cySizeFrame)
                        +GetSystemMetrics( sm_cyCaption);
      end;
      bsSizeToolWin:
      begin
        DeltaX := DeltaX+GetSystemMetrics( sm_cxSizeFrame);
        DeltaY := DeltaY+GetSystemMetrics( sm_cySizeFrame)
                        +GetSystemMetrics( sm_cySMCaption);
      end;
      bsToolWindow:
      begin
        DeltaX := DeltaX+GetSystemMetrics( sm_cxFixedFrame);
        DeltaY := DeltaY+GetSystemMetrics( sm_cyFixedFrame)
                        +GetSystemMetrics( sm_cySMCaption);
      end;
    end;    MenuHandle := GetMenu( Form.Handle);
    if MenuHandle <> 0
      then DeltaY := DeltaY + GetSystemMetrics( sm_cyMenu);    ShiftPoints( Points, PointCount, DeltaX, DeltaY);
    rgn := PointsToRegion( Bmp.Canvas.Handle, Points, PointCount);  end else begin
    rgn := 0;
  end;  CleanupPointers;
  result := rgn;
end;end.

Answer 8

下面的代码可以实现的是，无边框的矩形窗体，也有背景图片，可以移动和通过拖拽来改变大小。能够改成圆角窗体，同时也能移动和通过拖拽改变大小呢？unit uFrmMain;interfaceuses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, pngimage;type
  TfrmMain = class(TForm)
    Image1: TImage;
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    procedure WMNCHITTEST(var msg: TWMNCHitTest); message WM_NCHITTEST;  public
    { Public declarations }
  end;var
  frmMain: TfrmMain;implementation{$R *.dfm}const
  arr: array[-2..21] of string = (
    'HTERROR',
    'HTTRANSPARENT',
    'HTNOWHERE',
    'HTCLIENT - 客户区',
    'HTCAPTION - 标题',
    'HTSYSMENU - 系统菜单',
    'HTGROWBOX',
    'HTMENU - 菜单',
    'HTHSCROLL - 水平滚动条',
    'HTVSCROLL - 垂直滚动条',
    'HTMINBUTTON - 最小化按钮',
    'HTMAXBUTTON - 最大化按钮',
    'HTLEFT - 左边界',
    'HTRIG - 右边界',
    'HTTOP - 上边界',
    'HTTOPLEFT - 左上角',
    'HTTOPRIG - 右上角',
    'HTBOTTOM - 下边界',
    'HTBOTTOMLEFT - 左下角',
    'HTBOTTOMRIG - 右下角',
    'HTBORDER',
    'HTOBJECT',
    'HTCLOSE - 关闭按钮',
    'HTHELP');procedure TfrmMain.WMNCHITTEST(var msg: TWMNCHitTest);   //确定鼠标落的位置
var
   ix, iy: Integer;
begin
  inherited;  ix := msg.XPos;
  iy := msg.YPos;  if (ix >= Left + Width - 2) and (iy >= Top + Height - 2) then
  begin
    Msg.Result := HTBOTTOMRIGHT;       //右下角
  end
  else if (ix <= Left + 2) and (iy >= Top + Height - 2) then
  begin
    Msg.Result := HTBOTTOMLEFT;          //左下角
  end  else if (ix <= Left + 2) and (iy <= Top + 2) then
  begin
    Msg.Result := HTTOPLEFT;            //左上角
  end
  else if (ix >= Left + Width - 2) and (iy <= Top + 2) then
  begin
    Msg.Result := HTTOPRIGHT;                //右上角
  end
  else if (ix >= Left) and (ix <= left + 2) and (iy >= Top + 2) then
  begin
    Msg.Result := HTLEFT;                         //   左边界
  end
  else if (ix >= Left + Width - 2) then
  begin
    Msg.Result := HTRIGHT;                            //右边界
  end
  else if (iy <= Top + 2) then
  begin
    Msg.Result := HTTOP;                            //上边界
  end
  else if (iy >= Top + Height - 2) then
  begin
    Msg.Result := HTBOTTOM;                          //底部
  end
  else if ((ix >= left)) and ((iy >= top + 2) and (iy <= top + 50)) then
  begin
    Msg.Result := HTCAPTION;                         //标题栏
  end;
end;
procedure TfrmMain.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (ssleft in Shift) then   //鼠标左键
begin
ReleaseCapture; Perform(WM_syscommand, $F012, 0);end;
end;procedure TfrmMain.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (ssleft in Shift) then   //鼠标左键begin
ReleaseCapture; Perform(WM_syscommand, $F012, 0);end;
end;end.