Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "WinAPI";
Текущий архив: 2002.08.08;
Скачать: [xml.tar.bz2];

Вниз

<font size=1000>Как зделать круглую форму</font>   Найти похожие ветки 

 
dDaN   (2002-05-09 09:02) [0]

Люди помогите зделать круглую лил любую другую форму только не квадратную а то надоело уже все квадратное


 
Mystic   (2002-05-09 09:48) [1]

CreateEllipticRgn, ... (Platform SDK -> Graphics and multimedia -> Windows GDI)

Еще может понадобиться WM_NCHITTEST для того, чтобы сообщить Windows где у тебя какая область окна (кнопки минимизации, максимизации, граница, ...)


 
Exception   (2002-05-10 10:40) [2]

Ну не расстраивайся ты так !!! Для начала попробуй сделать форму прямоугольной. :)


 
Jo   (2002-05-29 22:49) [3]

unit unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, Menus, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
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;
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 := " How about that!";
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.



 
RV   (2002-05-31 08:11) [4]

В инете надыбал програмку, края рисует фигуры, а потом переводит это дело в *.pas, получается форма, соответствующая нарисованному. Если лень описывать регионы - очень удобно.(LogoMaker.exe, по моему на http://www.delphikingdom.com)



Страницы: 1 вся ветка

Форум: "WinAPI";
Текущий архив: 2002.08.08;
Скачать: [xml.tar.bz2];

Наверх





Память: 0.46 MB
Время: 0.006 c
1-24003
Олеся
2002-07-26 19:41
2002.08.08
Подскажите как работать с компонентом idhttp из пакета indy.


1-24091
Nox
2002-07-26 15:07
2002.08.08
<<<Народ, как написать алгоритмы решения следующих задач:>>>


1-23983
Mr. JS
2002-07-27 13:19
2002.08.08
Имя узла в TreeView?


1-24086
SuMaga
2002-07-25 12:13
2002.08.08
вот такая вот непонятная Фигня?


3-23905
Oleg Oransky
2002-07-17 17:35
2002.08.08
ADOX - Create TABLE (FIELD1 INT NULL,FIELD2 INT NULL)





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский