procedure TForm1.Button1Click(Sender: TObject);

var i:integer;

s:string;

begin

s:='';

for i:=1 to 150 do

s:=s+inttostr(i mod 10);

label1.Caption:=s;

form1.Paint;

end;



procedure TForm1.FormPaint(Sender: TObject);

begin

label1.Repaint;

application.processmessages;{yield;}

statusbar1.Canvas.CopyRect(rect(2,round((statusbar1.height- label1.height)/2),label1.width,label1.height),

label1.canvas,rect(0,0,label1.width,label1.height));

end;

procedure TForm1.Button1Click(Sender: TObject);

var

logfont: TLogFont;

font: Thandle;

count: integer;

begin

LogFont.lfheight := 20;

logfont.lfwidth := 20;

logfont.lfweight := 750;

LogFont.lfEscapement := -200;

logfont.lfcharset := 1;

logfont.lfoutprecision := out_tt_precis;

logfont.lfquality := draft_quality;

logfont.lfpitchandfamily := FF_Modern;

font := createfontindirect(logfont);

Selectobject(Form1.canvas.handle, font);

SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));

SetBKmode(Form1.canvas.handle, transparent);

for count := 1 to 100 do

begin

canvas.textout(Random(form1.width), Random(form1.height), 'Hello');

SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255), Random

(255)));

end;

Deleteobject(font);

end;

{ Не надо VCL переписывать :-) }



unit MainForm;



interface



uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Menus;



type

TfMain = class(TForm)

MainMenu1: TMainMenu;

Newchild1: TMenuItem;

Newchild2: TMenuItem;

procedure Newchild2Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;



var

fMain: TfMain;



implementation



uses ChildForm;



{$R *.DFM}



procedure TfMain.Newchild2Click(Sender: TObject);

begin

with TfChild.Create(Application) do

Show();

end;



function ClientWindowProc( wnd: HWND; msg: Cardinal; wparam, lparam: Integer ): Integer; stdcall;

var

f: Pointer;

begin

f := Pointer( GetWindowLong( wnd, GWL_USERDATA ));

case msg of

WM_NCCALCSIZE:

if ( GetWindowLong( wnd, GWL_STYLE ) and

(WS_HSCROLL or WS_VSCROLL)) <> 0 then

SetWindowLong( wnd, GWL_STYLE, GetWindowLong( wnd, GWL_STYLE )

and not (WS_HSCROLL or WS_VSCROLL));

end;

Result := CallWindowProc( f, wnd, msg, wparam, lparam );

end;



procedure TfMain.FormCreate(Sender: TObject);

begin

if ClientHandle <> 0 then begin

if GetWindowLong( ClientHandle, GWL_USERDATA ) <> 0 then

Exit; {cannot subclass client window, userdata already in use}

SetWindowLong(ClientHandle, GWL_USERDATA, SetWindowLong( ClientHandle,

GWL_WNDPROC, integer( @ClientWindowProc)));

end;



end;



end.

Form1.AlphaBlendValue := 200 {Уровень прозрачности};

Form1.AlphaBlend := True;

type

TyourForm = class(TForm)

private

{ Private declarations }

procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;

end;



procedure TyourForm.WMNCHitTest(var Message: TWMNCHitTest);

begin

inherited;



with Message do

if Result = HTCAPTION then

Result := HTNOWHERE;

end;

type

TForm1 = class(TForm)

procedure WndProc (var message: TMessage); override;

private

{ Private declarations }

public

{ Public declarations }

end;



var

Form1: TForm1;



implementation



{$R *.dfm}



procedure TForm1.WndProc (var message: TMessage);

begin

case message.Msg of

WM_WINDOWPOSCHANGING: PWindowPos(Message.LParam)^.hwndInsertAfter:=HWND_BOTTOM;

end;

inherited;

end;

type

TForm1 = class(TForm)

Button1: TButton;

procedure WndProc(var Message: TMessage); override;

procedure Button1Click(Sender: TObject);

private

{Private declarations}

public

{Public declarations}

end;



var

Form1: TForm1;



implementation



{$R *.DFM}



procedure TForm1.WndProc(var Message: TMessage);

begin

if Message.Msg = WM_CANCELMODE then

begin

Form1.Caption := 'A dialog or message box has popped up';

end

else

inherited // <- остальное сделает родительская процедура

end;



procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage('Test Message');

end;

{ ... }

type

TForm1 = class(TForm)

private

procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;

public

end;



var

Form1: TForm1;



implementation



{$R *.dfm}



procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);

var

ACanvas: TCanvas;

begin

inherited;

ACanvas := TCanvas.Create;

try

ACanvas.Handle := GetWindowDC(Form1.Handle);

with ACanvas do

begin

Brush.Color := clActiveCaption;

Font.Name := 'Tahoma';

Font.Size := 8;

Font.Color := clred;

Font.Style := [fsItalic, fsBold];

TextOut(GetSystemMetrics(SM_CYMENU) + GetSystemMetrics(SM_CXBORDER),

Round((GetSystemMetrics(SM_CYCAPTION) - Abs(Font.Height)) / 2) + 1,

' Some Text');

end;

finally

ReleaseDC(Form1.Handle, ACanvas.Handle);

ACanvas.Free;

end;

end;

unit Unit1;



interface



uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;



type

TForm1 = class(TForm)

private

{Private declarations}

procedure WMNCMOUSEMOVE(var Message: TMessage);

message WM_NCMOUSEMOVE;

public

{Public declarations}

end;



var

Form1: TForm1;



implementation



{$R *.DFM}



procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage);

var

s : string;

begin

case Message.wParam of

HTERROR:

s:= 'HTERROR';

HTTRANSPARENT:

s:= 'HTTRANSPARENT';

HTNOWHERE:

s:= 'HTNOWHERE';

HTCLIENT:

s:= 'HTCLIENT';

HTCAPTION:

s:= 'HTCAPTION';

HTSYSMENU:

s:= 'HTSYSMENU';

HTSIZE:

s:= 'HTSIZE';

HTMENU:

s:= 'HTMENU';

HTHSCROLL:

s:= 'HTHSCROLL';

HTVSCROLL:

s:= 'HTVSCROLL';

HTMINBUTTON:

s:= 'HTMINBUTTON';

HTMAXBUTTON:

s:= 'HTMAXBUTTON';

HTLEFT:

s:= 'HTLEFT';

HTRIGHT:

s:= 'HTRIGHT';

HTTOP:

s := 'HTTOP';

HTTOPLEFT:

s:= 'HTTOPLEFT';

HTTOPRIGHT:

s:= 'HTTOPRIGHT';

HTBOTTOM:

s:= 'HTBOTTOM';

HTBOTTOMLEFT:

s:= 'HTBOTTOMLEFT';

HTBOTTOMRIGHT:

s:= 'HTBOTTOMRIGHT';

HTBORDER:

s:= 'HTBORDER';

HTOBJECT:

s:= 'HTOBJECT';

HTCLOSE:

s:= 'HTCLOSE';

HTHELP:

s:= 'HTHELP';

else s:= '';

end;

Form1.Caption := s;

Message.Result := 0;

end;



end.

uses

Windows;



procedure PlaceMyMouse(Sender: TForm; X, Y: word);

var

MyPoint: TPoint;

begin

MyPoint := Sender.ClientToScreen(Point(X, Y));

SetCursorPos(MyPoint.X, MyPoint.Y);

end;

... = class(TForm)

...

protected

procedure CreateParams( var params: TCreateParams ); override;

...



procedure TForm2.Createparams(var params: TCreateParams);

var

aHWnd : HWND;

begin

inherited;

{как-нибудь получаем существующий дескриптор}

ahWnd := GetForegroundWindow;

{а теперь:}

params.WndParent := ahWnd;

end;

procedure TMainForm.SetBands(AControls: array of TWinControl;

ABreaks: array of boolean);

var

i: integer;

begin

with CoolBar do

begin

for i:=0 to High(AControls) do

begin

if Bands.Count=succ(i) then

TCoolBand.Create(Bands);

with Bands[succ(i)] do

begin

if Assigned(Control) then

Control.Hide;

MinHeight:=AControls[i].Height;

Break:=ABreaks[i];

Control:=AControls[i];

Control.Show;

Visible:=true;

end

end;

for i:=High(AControls)+2 to pred(Bands.Count) do

Bands[i].Free

end

end;

procedure TMsgForm.FormActivate(Sender: TObject);

begin

MainForm.SetBands([ToolBar],[false])

end;

AutoSize := false;

try

...

finally

AutoSize := true;

TMainForm

...

object SpeedBar: TPanel

...

Align = alTop

BevelOuter = bvNone

object ToolBar: TPanel

...

Align = alLeft

BevelOuter = bvNone

end

object RxSplitter1: TRxSplitter

...

ControlFirst = ToolBar

ControlSecond = ChildBar

Align = alLeft

BevelOuter = bvLowered

end

object ChildBar: TPanel

...

Align = alClient

BevelOuter = bvNone

end

end



TMdiChild {пpородитель всех остальных}

...

object pnToolBar: TPanel

...

Align = alTop

BevelOuter = bvNone

Visible = False

end



procedure TMDIForm.FormActivate(Sender: TObject);

begin

pnToolBar.Parent := MainForm.ChildBar;

pnToolBar.Visible := True;

end;



procedure TMDIForm.FormDeactivate(Sender: TObject);

begin

pnToolBar.Visible := false;

pnToolBar.Parent := self

end;

unit testmain;



interface



uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls, Buttons, ShellAPI;



type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

FOldHeight: Integer;

procedure WMNCRButtonDown(var Msg: TWMNCRButtonDown);

message WM_NCRBUTTONDOWN;

public

{ Public declarations }

end;



var

Form1: TForm1;



implementation



{$R *.DFM}



procedure TForm1.FormCreate(Sender: TObject);

begin

FOldHeight := ClientHeight;

end;



procedure TForm1.WMNCRButtonDown(var Msg: TWMNCRButtonDown);

var

I: Integer;

begin

if (Msg.HitTest = HTCAPTION) then

if (ClientHeight = 0) then

begin

I := 0;

while (I < FOldHeight) do

begin

I := I + 40;

if (I > FOldHeight) then

I := FOldHeight;

ClientHeight := I;

Application.ProcessMessages;

end;

end

else

begin

FOldHeight := ClientHeight;

I := ClientHeight;

while (I > 0) do

begin

I := I - 40;

if (I < 0) then

I := 0;

ClientHeight := I;

Application.ProcessMessages;

end;

end;

end;



end.

var

RecS, RecL: TRect;

begin

RecS := Rect(Screen.Width, Screen.Height, Screen.Width, Screen.Height);

RecL := ThisForm.BoundsRect;

DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RecS, RecL);

{ ... }

end;

var

RecS, RecL: TRect;

begin

HideTimer.Enabled := False;

RecS := Rect(Screen.Width, Screen.Height, Screen.Width, Screen.Height);

RecL := ThisForm.BoundsRect;

DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RecL, RecS);

end;

procedure TForm1.Button4Click(Sender: TObject);

var

HRegion1, Hreg2, Hreg3: THandle;

Col: TColor;

begin

ShowMessage ('Ready for a real crash?');

Col := Color;

Color := clRed;

PlaySound ('boom.wav', 0, snd_sync);

HRegion1 := CreatePolygonRgn (Pts,

sizeof (Pts) div 8,

alternate);

SetWindowRgn (

Handle, HRegion1, True);

ShowMessage ('Now, what have you done?');

Color := Col;

ShowMessage ('Вам лучше купить новый монитор');

end;

procedure TForm1.Button1Click(Sender: TObject);

var

x: word ;

begin

x := SetSysModalWindow(AboutBox.handle) ;

AboutBox.showmodal ;

SetSysModalWindow(x) ;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

AnimateWindow(Handle, 500, AW_HIDE or AW_BLEND);

end;

procedure ShowMainForm;

var

hWnd, hCurWnd, dwThreadID, dwCurThreadID: THandle;

OldTimeOut: DWORD;

AResult: Boolean;

begin

ShowWindow(Application.Handle, SW_RESTORE);

Application.MainForm.Visible := True; // Показываем главную форму



// Ставим нашу форму впереди всех окон

hWnd := Application.Handle;

SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @OldTimeOut, 0);

SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, Pointer(0), 0);

SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);

hCurWnd := GetForegroundWindow;

AResult := False;

while not AResult do

begin

dwThreadID := GetCurrentThreadId;

dwCurThreadID := GetWindowThreadProcessId(hCurWnd);

AttachThreadInput(dwThreadID, dwCurThreadID, True);

AResult := SetForegroundWindow(hWnd);

AttachThreadInput(dwThreadID, dwCurThreadID, False);

end;

SetWindowPos(hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);

SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, Pointer(OldTimeOut), 0);

end;

protected

procedure CreateParams(var Params: TCreateParams); override;



//...



procedure TForm.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

if Assigned(Application.MainForm) then

begin

Params.WndParent := GetDesktopWindow;

Params.Style := WS_CHILD;

end;

end;