Вопросы и ответы - Delphi - Формы, дочерние окна и контролы - Библиотека программиста
Пользователь

Добро пожаловать,

Регистрация или входРегистрация или вход
Потеряли пароль?Потеряли пароль?

Ник:
Пароль:

Меню сайта




Ваше мнение
Как вы оцените наш сайт?

Замечательный
Хороший
Обычный
Плохой
Отвратительный


Результаты
Другие опросы

Всего голосов: 782
Комментарии: 10


Наши партнеры



Статистика




Programming books  Download software  Documentation  Scripts  Content Managment Systems(CMS)  Templates  Icon Sets  Articles  Contacts  Voting  Site Search




Вопросы и ответы - Delphi - Формы, дочерние окна и контролы

                  
 
В каком порядке происходят события при создании и показе окна?
При создании окна обработчики событий выполняются в следующем порядке:

  • OnCreate
  • OnShow
  • OnPaint
  • OnActivate
  • OnResize
  • OnPaint (снова)

  • В строке состояния TStatusBar выводится только 127 символов
    В строке состояния TStatusBar выводится только 127 символов.

    Можно ли как-нибудь увеличить это число?

    Код
    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;
    Выводим цветной текст на форме под любым углом
    Пример демонстрирует вывод теста случайным образом на форме под определённым углом. Добавляем в форму компонент TButton и в событие OnClick следующий код:

    Код
    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;
    Избавление от скролов в MDI форме
    Код
    { Не надо 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;
    Как изменить оконную процедуру для TForm?
    Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере оконная процедура переопределяется для того чтобы реагировать на сообщение WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо еще диалог.

    Код
    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;
    Как перехватить события в неклиентской области формы?
    Создайте обработчик одного из сообщений WM_NC (non client - не клиентских) (посмотрите

    WM_NC в Windows API help). Пример показывает как перехватить вижение мыши во всей

    неклиенстской области окна (рамка и заголовок).



    Пример:

    Код
    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;
    Как прикрепить свою форму к другому приложению?
    Для этого Вам понадобится переопределить процедуру CreateParams у желаемой формы. А в ней установить params.WndParent в дескриптор окна, к которому Вы хотите прикрепить форму.

    Код
    ... = 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;
    Как сделать MDI-приложение, где сливаются меню дочернего и главного окна, и полосы инструментов?
    Код
    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;



    Пpимечание:



    Оба массива pавны по длине. CoolBar.Bands[0] должен существовать всегда,.. на нём я pазмешаю "глобальные" кнопки. СoolBar[1] тоже можно сделать в DesignTime с Break:=false и пpидвинуть поближе с началу. Пpи CoolBar.AutoSize:=true возможно "мигании" (пpи добавлении на новую стpоку) так что можно добавить:

    Код
    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;

    Как сделать roll-up форму?
    Код
    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.
    Как сделать анимацию минимизации формы?
    In FormShow:

    Код
    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;



    In FormHide:

    Код
    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;
    Как сделать окно системно-модальным?
    Используйте функцию Windows API SetSysModalWindow(). Код ниже демонстрирует технологию работы с этой функцией. В любой момент времени может быть возможен только один модально-системны диалог, чей дескриптор возвращается функцией SetSysModalWindow(). Вам необходимо запомнить возвращаемую функцией величину для того, чтобы завершить показ диалога таким образом. Вот как примерно это должно выглядеть:

    Код
    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;
    Как сделать форму активной, форма находится в DLL
    Код
    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;


    Печать страницы
    Печать страницы




    Внимание! Если у вас не получилось найти нужную информацию, используйте рубрикатор или воспользуйтесь поиском


    .



    книги по программированию исходники компоненты шаблоны сайтов C++ PHP Delphi скачать