Solved

Form Shapes

Posted on 1997-12-17
4
270 Views
Last Modified: 2010-04-04
Ages ago I saw some code which would allow a programmer to change the shape of their forms from the old square types to a circle or ellipse.  Does anyone know how to do this?  

Stu
0
Comment
Question by:SJohnson
4 Comments
 
LVL 7

Accepted Solution

by:
ahalya earned 50 total points
ID: 1354095
you do that using the Region functions.

Here are the relevant parts from an example i fetched from the net a while ago. sorry i don't have the authors name/info around.



procedure TForm1.DrawRndRectRegion(wnd : HWND; rect : TRect);

begin
rgn := CreateRoundRectRgn(rect.left, rect.top, rect.right, rect.bottom, SpinEdit3.Value*200,SpinEdit3.Value);
SetWindowRgn(wnd, rgn, TRUE);
end;

procedure TForm1.DrawEllipticRegion(wnd : HWND; rect : TRect);
begin
rgn := CreateEllipticRgn(rect.left, rect.top, rect.right, rect.bottom);
SetWindowRgn(wnd, rgn, TRUE);
end;



procedure TForm1.Button1Click(Sender: TObject);
begin
DrawEllipticRegion(Form1.Handle, Form1.ClientRect);
DrawEllipticRegion(BitBtn1.Handle, BitBtn1.BoundsRect);
end;

0
 
LVL 5

Expert Comment

by:ronit051397
ID: 1354096
There is an article about that on The Delphi Corner:
http://www.delumpa.com/
0
 
LVL 1

Author Comment

by:SJohnson
ID: 1354097
Thanks for that.  Did the trick.

Stu
0
 

Expert Comment

by:josephhalter
ID: 1354098
There are many solutions to do this. An exellent exemple of special form written by Neil Rubenking and now release in the Public Domain. This is a dont shaped form with a curved title bar. It works fine. Everyone should use it at less one time. The only thing you have to do is to create a new project, save the main form as rgnu.pas. Then, you should paste the following text in this file (replacing its contents) :

unit rgnu;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons, Menus;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
    rTitleBar : THandle;
    Center    : TPoint;
    CapY   : Integer;
    Circum    : Double;
    SB1       : TSpeedButton;
    RL, RR    : Double;
    procedure TitleBar(Act : Boolean);
    procedure WMNCHITTEST(var Msg: TWMNCHitTest);
      message WM_NCHITTEST;
    procedure WMNCACTIVATE(var Msg: TWMNCACTIVATE);
      message WM_NCACTIVATE;
    procedure WMSetText(var Msg: TWMSetText);
      message WM_SETTEXT;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

CONST
  TitlColors : ARRAY[Boolean] OF TColor =
    (clInactiveCaption, clActiveCaption);
  TxtColors : ARRAY[Boolean] OF TColor =
    (clInactiveCaptionText, clCaptionText);

procedure TForm1.FormCreate(Sender: TObject);
VAR
  rTemp, rTemp2    : THandle;
  Vertices : ARRAY[0..2] OF TPoint;
  X, Y     : INteger;
begin
  Caption := 'OOOH! Doughnuts!';
  BorderStyle := bsNone; {required}
  IF Width > Height THEN Width := Height
  ELSE Height := Width;  {harder to calc if width <> height}
  Center  := Point(Width DIV 2, Height DIV 2);
  CapY := GetSystemMetrics(SM_CYCAPTION)+8;
  rTemp := CreateEllipticRgn(0, 0, Width, Height);
  rTemp2 := CreateEllipticRgn((Width DIV 4), (Height DIV 4),
    3*(Width DIV 4), 3*(Height DIV 4));
  CombineRgn(rTemp, rTemp, rTemp2, RGN_DIFF);
  SetWindowRgn(Handle, rTemp, True);
  DeleteObject(rTemp2);
  rTitleBar  := CreateEllipticRgn(4, 4, Width-4, Height-4);
  rTemp := CreateEllipticRgn(CapY, CapY, Width-CapY, Height-CapY);
  CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_DIFF);
  Vertices[0] := Point(0,0);
  Vertices[1] := Point(Width, 0);
  Vertices[2] := Point(Width DIV 2, Height DIV 2);
  rTemp := CreatePolygonRgn(Vertices, 3, ALTERNATE);
  CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_AND);
  DeleteObject(rTemp);
  RL := ArcTan(Width / Height);
  RR := -RL + (22 / Center.X);
  X := Center.X-Round((Center.X-1-(CapY DIV 2))*Sin(RR));
  Y := Center.Y-Round((Center.Y-1-(CapY DIV 2))*Cos(RR));
  SB1 := TSpeedButton.Create(Self);
  WITH SB1 DO
    BEGIN
      Parent     := Self;
      Left       := X;
      Top        := Y;
      Width      := 14;
      Height     := 14;
      OnClick    := Button1Click;
      Caption    := 'X';
      Font.Style := [fsBold];
    END;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Close;
End;

procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitTest);
begin
  Inherited;
  WITH Msg DO
    WITH ScreenToClient(Point(XPos,YPos)) DO
      IF PtInRegion(rTitleBar, X, Y) AND
       (NOT PtInRect(SB1.BoundsRect, Point(X,Y))) THEN
        Result := htCaption;
end;

procedure TForm1.WMNCActivate(var Msg: TWMncActivate);
begin
  Inherited;
  TitleBar(Msg.Active);
end;

procedure TForm1.WMSetText(var Msg: TWMSetText);
begin
  Inherited;
  TitleBar(Active);
end;

procedure TForm1.TitleBar(Act: Boolean);
VAR
  TF      : TLogFont;
  R       : Double;
  N, X, Y : Integer;
begin
  IF Center.X = 0 THEN Exit;
  WITH Canvas DO
    begin
      Brush.Style := bsSolid;
      Brush.Color := TitlColors[Act];
      PaintRgn(Handle, rTitleBar);
      R  := RL;
      Brush.Color := TitlColors[Act];
      Font.Name := 'Arial';
      Font.Size := 12;
      Font.Color := TxtColors[Act];
      Font.Style := [fsBold];
      GetObject(Font.Handle, SizeOf(TLogFont), @TF);
      FOR N := 1 TO Length(Caption) DO
        BEGIN
          X := Center.X-Round((Center.X-6)*Sin(R));
          Y := Center.Y-Round((Center.Y-6)*Cos(R));
          TF.lfEscapement := Round(R * 1800 / pi);
          Font.Handle := CreateFontIndirect(TF);
          TextOut(X, Y, Caption[N]);
          R := R - (((TextWidth(Caption[N]))+2) / Center.X);
          IF R < RR THEN Break;
        END;
      Font.Name := 'MS Sans Serif';
      Font.Size := 8;
      Font.Color := clWindowText;
      Font.Style := [];
    end;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  WITH Canvas DO
    BEGIN
      Pen.Color := clBlack;
      Brush.Style := bsClear;
      Pen.Width := 1;
      Pen.Color := clWhite;
      Arc(1, 1, Width-1, Height-1, Width, 0, 0, Height);
      Arc((Width DIV 4)-1, (Height DIV 4)-1,
        3*(Width DIV 4)+1, 3*(Height DIV 4)+1, 0, Height, Width, 0);
      Pen.Color := clBlack;
      Arc(1, 1, Width-1, Height-1, 0, Height, Width, 0);
      Arc((Width DIV 4)-1, (Height DIV 4)-1,
        3*(Width DIV 4)+1, 3*(Height DIV 4)+1, Width, 0, 0, Height);
      TitleBar(Active);
    END;
end;

end.
0

Featured Post

Gigs: Get Your Project Delivered by an Expert

Select from freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely and get projects done right.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
This Micro Tutorial will give you a basic overview how to record your screen with Microsoft Expression Encoder. This program is still free and open for the public to download. This will be demonstrated using Microsoft Expression Encoder 4.
In this video I am going to show you how to back up and restore Office 365 mailboxes using CodeTwo Backup for Office 365. Learn more about the tool used in this video here: http://www.codetwo.com/backup-for-office-365/ (http://www.codetwo.com/ba…

813 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now