FAQ VCL
Компоненты\Общие вопросы

:: Меню ::
:: На главную ::
:: FAQ ::
:: Заметки ::
:: Практика ::
:: Win API ::
:: Проекты ::
:: Скачать ::
:: Секреты ::
:: Ссылки ::

:: Сервис ::
:: Написать ::

:: MVP ::

:: RSS ::

Яндекс.Метрика

Как "опустить" компонент в самый низ по Z-порядку?

Panel1.SendToBack;


Как "поднять" компонент на самый верх по Z-порядку?

Panel1.BringToFront;


Как изменить Z-порядок контрола вверх или вниз на единицу?

procedure ChangeControlZOrder( Sender: TObject; MoveUp: Boolean = True );
var
  i, Curr: Integer;
  Control: TControl;
  List: TList;
begin
  if Sender is TControl then
  begin
    // Only components of type TControl and descendends work
    Control := Sender as TControl;

    // Has no parent, cannot move ;-)
    if Control.Parent = nil then
      Exit;

    // Determine position in z-order
    Curr := -1;
    for i := 0 to Pred(Control.Parent.ControlCount) do
      if Control.Parent.Controls[i] = Sender then
      begin
        Curr := i;
        Break;
      end;

    // Position not found, quit
    if Curr < 0 then
      Exit;

    List := TList.Create;
    try
      if MoveUp then
      begin
        for i := Curr+2 to Pred(Control.Parent.ControlCount) do
        // Load other controls in group
        List.Add(Control.Parent.Controls[i]);
        Control.BringToFront;
        for i := 0 to Pred(List.Count) do
          // Move other controls to front, too
          TControl(List[i]).BringToFront;
      end
      else
      begin
        for i := 0 to Curr-2 do
          // Load other controls in group
          List.Add(Control.Parent.Controls[i]);
        Control.SendToBack;
        for i := Pred(List.Count) downto 0 do
          // Move other controls to back, too
          TControl(List[i]).SendToBack;
      end;
    finally
      List.Free;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  // На 1 позицию вверх
  ChangeControlZOrder(Panel1{, True});
  // На 1 позицию вниз
  ChangeControlZOrder(Panel1, False);
end;


Как нарисовать рамку фокуса вокруг активного компонента?

uses
  {...,} ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    procedure ActiveControlChange(Sender: TObject);
  end;

var
  Form1: TForm1;
  FocusRect: TShape;

implementation

procedure TForm1.ActiveControlChange(Sender: TObject);
begin
  with FocusRect do
  begin
    Parent := Screen.ActiveControl.Parent;
    Top := Screen.ActiveControl.Top - 2;
    Height := Screen.ActiveControl.Height + 4;
    Left := Screen.ActiveControl.Left - 2;
    Width := Screen.ActiveControl.Width + 4;
    Visible := True;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FocusRect := TShape.Create(Self);
  FocusRect.Shape := stRectangle;
  FocusRect.Visible := False;
  FocusRect.Brush.Style := bsClear;
  FocusRect.Pen.Style := psDot;
  FocusRect.Pen.Color := clRed;
  FocusRect.Pen.Width := 1;
  Screen.OnActiveControlChange := ActiveControlChange;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Screen.OnActiveControlChange := nil;
  FocusRect.Free;
end;


Как скрыть свойства объекта из Object Inspector'а?

// Спрсоб первый
// Для того, чтобы скрыть свойства, объявленые в published-области,
// но при этом оставить возможность доступа к ним во время работы
// программы, нужно объявить эти свойства "по новой" в public-области.
// В примере скрытым будет свойство Height у объекта TMyControl.
interface

type
  TMyControl = class(TWinControl)
  protected
    procedure SetHeight(Value: Integer);
    function GetHeight: Integer;
  public
    property Height: Integer read GetHeight write SetHeight;
  end;

implementation

procedure TMyControl.SetHeight(Value: Integer);
begin
  inherited Height := Value;
end;

function TMyControl.GetHeight;
begin
  Result := inherited Height;
end;

// Спрсоб второй
// Для того, чтобы скрыть свойства, объявленые в published-области,
// но при этом оставить возможность доступа к ним во время работы
// программы, можно вомпользоваться процедурой RegisterPropertyEditor,
// объявленной в ToolsAPI.pas. Компилятор должен знать путь к этому
// файлу (а находится он в $(BDS)\source\ToolsAPI\).
interface

type
  TMyPanel = class(TPanel)
  private
  protected
  public
  published
  end;

procedure Register;

implementation

uses
  DesignIntf;

procedure Register;
begin
  RegisterComponents('Decoding', [TMyPanel]);
  RegisterPropertyEditor(TypeInfo(Integer), TMyPanel, 'Width', nil);
  RegisterPropertyEditor(TypeInfo(Integer), TMyPanel, 'Height', nil);
end;


Как рисовать поверх TWinControl?

// Суть примера сводится к перекрытию оконной процедуры, в которой
// вывод графики производится уже непосредственно на канве контрола.
// Попробуйте изменить размеры формы и понаблюдать за поведением линии.
unit Unit1; 

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    ButtonsData: array [0..19] of TButton;
    procedure GenerateButtons;
    procedure ReleaseButtons;
    procedure ButtonClick(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function ButtonSubclassProc( hWnd: HWND; Msg: Integer;
  wParam: WPARAM; lParam: LPARAM ): LRESULT; stdcall;
var
  OldWndProc, LeftOffset, TopOffset: Integer;
  WndRect, ParentRect, ParentClientRect: TRect;
  TmpCanvas: TCanvas;
  X1, Y1, X2, Y2: Integer;
begin
  OldWndProc := GetWindowLong(hWnd, GWL_USERDATA);
  Result := CallWindowProc(Pointer(OldWndProc), hWnd, Msg, wParam, lParam);
  if Msg = WM_PAINT then
  begin
    GetWindowRect(hWnd, WndRect);
    GetWindowRect(GetParent(hWnd ), ParentRect);
    GetClientRect(GetParent(hWnd ), ParentClientRect);
    TopOffset := (ParentRect.Bottom - ParentRect.Top) -
                 (ParentClientRect.Bottom - ParentClientRect.Top);
    LeftOffset := (ParentRect.Right - ParentRect.Left) -
                  (ParentClientRect.Right - ParentClientRect.Left);
    X1 := ParentClientRect.Left + LeftOffset div 2 -
          (WndRect.Left - ParentRect.Left);
    Y1 := ParentClientRect.Top + TopOffset -
          (WndRect.Top - ParentRect.Top) - LeftOffset div 2;
    X2 := X1 + (ParentClientRect.Right - ParentClientRect.Left);
    Y2 := Y1 + (ParentClientRect.Bottom - ParentClientRect.Top);
    TmpCanvas := TCanvas.Create;
    try
      TmpCanvas.Handle := GetDC(hWnd);
      TmpCanvas.Pen.Color := clRed;
      TmpCanvas.Pen.Width := 4;
      TmpCanvas.MoveTo(X1, Y1);
      TmpCanvas.LineTo(X2, Y2);
    finally
      ReleaseDC(hWnd, TmpCanvas.Handle);
      TmpCanvas.Free;
    end;
  end;
end;

procedure TForm1.ButtonClick(Sender: TObject);
begin
  ReleaseButtons;
  GenerateButtons;
  Invalidate;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := True;
  GenerateButtons;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  ReleaseButtons;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  Canvas.Pen.Color := clRed;
  Canvas.Pen.Width := 4;
  Canvas.MoveTo(0, 0);
  Canvas.LineTo(ClientWidth, ClientHeight);
end;

procedure TForm1.FormResize(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to 19 do
    ButtonsData[i].Invalidate;
  Invalidate;
end;

procedure TForm1.GenerateButtons;
var
  i: Integer;
begin
  Randomize;
  for i := 0 to 19 do
  begin
     ButtonsData[i] := TButton.Create(Self);
     ButtonsData[i].Parent := Self;
     ButtonsData[i].Left := Random(ClientWidth - ButtonsData[i].Width);
     ButtonsData[i].Top := Random(ClientHeight - ButtonsData[i].Height);
     ButtonsData[i].Caption := 'Button' + IntToStr(i+1);
     ButtonsData[i].OnClick := ButtonClick;
     SetWindowLong(ButtonsData[i].Handle, GWL_USERDATA,
                   GetWindowLong(ButtonsData[i].Handle, GWL_WNDPROC));
     SetWindowLong(ButtonsData[i].Handle, GWL_WNDPROC,
                   Integer(@ButtonSubclassProc));
  end;
end;

procedure TForm1.ReleaseButtons;
var
  i: Integer;
begin
  for i := 0 to 19 do
    ButtonsData[i].Free;
end;

end.


Как построить дерево контролов/компонентов формы?

type
  TForm1 = class(TForm)
    Button1: TButton;
    TreeView1: TTreeView;
    Panel1: TPanel;
    Image1: TImage;
    ActionList1: TActionList;
    FlowPanel1: TFlowPanel;
    TrayIcon1: TTrayIcon;
    BalloonHint1: TBalloonHint;
    BitBtn1: TBitBtn;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure TreeView1Expanding(Sender: TObject; Node: TTreeNode;
      var AllowExpansion: Boolean);
  private
    procedure Scan(RootControl: TWinControl; RootNode: TTreeNode);
    {...}
  end;

implementation

procedure TForm1.Button1Click(Sender: TObject);
begin
  Scan(Self, nil);
end;

procedure TForm1.Scan(RootControl: TWinControl; RootNode: TTreeNode);
var
  i: Integer;
  Node: TTreeNode;
begin
  Node := TreeView1.Items.AddChild(RootNode,
                                   RootControl.Name + ' [' +
                                   RootControl.ClassName + ']'
          );

  for i := 0 to RootControl.ControlCount-1 do
  begin
    if RootControl.Controls[i] is TWinControl then
    begin
      Scan(RootControl.Controls[i] as TWinControl, Node);
      Continue;
    end;

    TreeView1.Items.AddChild(Node,
                             RootControl.Controls[i].Name + ' [' +
                             RootControl.Controls[i].ClassName + ']'
    );
  end;

  for i := 0 to RootControl.ComponentCount-1 do
  begin
    if not (RootControl.Components[i] is TControl) then
      if RootControl.Components[i].Name <> '' then
        TreeView1.Items.AddChild(Node,
                                 RootControl.Components[i].Name + ' [' +
                                 RootControl.Components[i].ClassName + ']'
        );
  end;
end;

procedure TForm1.TreeView1Expanding(Sender: TObject; Node: TTreeNode;
  var AllowExpansion: Boolean);
begin
  Node.AlphaSort;
end;

При использовании материала - ссылка на сайт обязательна