Программирование на Delphi

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

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

Как получить ширину ScrollBar'а?


// Этим способом вы можите получить ширину ScrollBar'a
// любого компонента, способного его отображать.
// В примере мы узнаем ширину ScrollBar'ов TMemo

function ScrollBarVisible(Handle: HWnd; Style: Longint): Boolean;
begin
  Result := (GetWindowLong(Handle, GWL_STYLE) and Style) <> 0;
end;

// Получаем ширину вертикального ScrollBar'a
procedure TForm1.Button1Click(Sender: TObject);
var
  ScrollBarWidth: Integer;
begin
  if ScrollBarVisible(Memo1.Handle, WS_VSCROLL) then
    ScrollBarWidth := GetSystemMetrics(SM_CXVSCROLL)
  else
    ScrollBarWidth := 0;
  ShowMessage(IntToStr(ScrollBarWidth));
end;

// Получаем ширину горизонтального ScrollBar'a
procedure TForm1.Button2Click(Sender: TObject);
var
  ScrollBarWidth: Integer;
begin
  if ScrollBarVisible(Memo1.Handle, WS_HSCROLL) then
    ScrollBarWidth := GetSystemMetrics(SM_CXHSCROLL)
  else
    ScrollBarWidth := 0;
  ShowMessage(IntToStr(ScrollBarWidth));
end;

Как в программе получить список TabOrder'ов?


var
  Form1: TForm1;
  ControlList: TList;

{...}

function GetTabOrdersList(Ctrl: TWinControl): TList;
begin
  if Ctrl = nil then
    Exit;

  Result := TList.Create;
  Ctrl.GetTabOrderList(Result);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  // ControlList := GetTabOrdersList(Form1);
  ControlList := GetTabOrdersList(Panel1);
  Memo1.Lines.Clear;
  if ControlList.Count > 0 then
    for i := 0 to ControlList.Count-1 do
      Memo1.Lines.Add(TControl(ControlList.Items[i]).Name);
end;

Как заблокировать/разблокировать перерисовку компонента?


// Способ первый
procedure LockControl(c: TWinControl; Lock: Boolean);
begin
  if (c = nil) or (c.Handle = 0) then
    Exit;

  if Lock then
    SendMessage(c.Handle, WM_SETREDRAW, 0, 0)
  else
  begin
    SendMessage(c.Handle, WM_SETREDRAW, 1, 0);
    RedrawWindow(c.Handle, nil, 0,
      RDW_ERASE or RDW_FRAME or RDW_INVALIDATE or RDW_ALLCHILDREN);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  LockControl(DBGrid1, True); 
  try 
    // Различные действия с компонентом
  finally 
    LockControl(DBGrid1, False); 
  end; 
end;

// Способ второй
// Заблокировать
LockWindowUpdate(ListView1.Handle);
// Разблокировать
LockWindowUpdate(0);

// Способ третий
// Заблокировать
ListView1.Perform(WM_SETREDRAW, 0, 0);
// SendMessage(ListView1.Handle, WM_SETREDRAW, 0, 0); // или так
// Разблокировать
ListView1.Perform(WM_SETREDRAW, 1, 0);
// SendMessage(ListView1.Handle, WM_SETREDRAW, 1, 0); // или так
RedrawWindow(ListView1.Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_ALLCHILDREN);

Как рисовать на компоненте, не имеющем свойства Canvas?


// Способ первый
interface

{...}

type
  TPanel = class(ExtCtrls.TPanel)
  public
    Canvas: TCanvas;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

{...}

implementation

{ TPanel }

constructor TPanel.Create(AOwner: TComponent);
begin
  inherited;
  Canvas := TControlCanvas.Create;
  TControlCanvas(Canvas).Control := Self;
end;

destructor TPanel.Destroy;
begin
  Canvas.Free;
  inherited;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Panel1.Canvas.MoveTo(10, 10);
  Panel1.Canvas.LineTo(50, 50);
end;

// Способ второй
interface

{...}

type
  TPanel = class(ExtCtrls.TPanel)
  public
    Canvas: TCanvas;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

{...}

implementation

{ TPanel }

constructor TPanel.Create(AOwner: TComponent);
begin
  inherited;
  Canvas := TCanvas.Create;
  Canvas.Handle := GetDC(Self.Handle);
end;

destructor TPanel.Destroy;
begin
  Canvas.Free;
  inherited;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Panel1.Canvas.MoveTo(10, 10);
  Panel1.Canvas.LineTo(50, 50);
end;

// Способ третий
interface

{...}

type
  TPanel = class(ExtCtrls.TPanel)
  protected
    procedure Paint; override;
  public
    property Canvas;
  end;

{...}

implementation

{ TPanel }

procedure TPanel.Paint;
begin
  inherited Paint;
  Canvas.Pen.Style := psDash;
  Canvas.Rectangle(10, 10, ClientWidth-10, ClientHeight-10);
end;

Как в программе организовать динамический список объектов (компонентов)?


// Способ первый
var
  arrObject: array of TObject;
  pObj: ^TObject;

implementation

procedure TForm1.FormCreate(Sender: TObject);
begin
  SetLength(arrObject, 0);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  i: Integer;
begin
  for i := Length(arrObject)-1 downto 0 do
    arrObject[i].Free;
  arrObject := nil;
end;

// Пример работы со списком

// Добавление объекта в список
procedure arrAdd(var Obj: TObject);
begin
  SetLength(arrObject, Length(arrObject)+1);
  arrObject[Length(arrObject)-1] := Obj;
end;

// Вставка объекта в указанную позицию списка
procedure arrIns(var Obj: TObject; Index: Cardinal);
var
  i: Integer;
begin
  if Index >= Length(arrObject) then
    Exit;

  SetLength(arrObject, Length(arrObject)+1);
  for i := Length(arrObject)-1 downto Index+1 do
    arrObject[i] := arrObject[i-1];
  arrObject[Index] := Obj;
end;

// Удаление объекта из списка
procedure arrDel( Index: Cardinal );
var
  i: Integer;
begin
  if Index >= Length(arrObject) then
    Exit;

  if Index < Length(arrObject)-1 then
    for i := Index+1 to Length(arrObject)-1 do
      arrObject[i-1] := arrObject[i];
  SetLength(arrObject, Length(arrObject)-1);
end;

// Пример добавления объекта в список
procedure TForm1.Button1Click(Sender: TObject);
begin
  New(pObj);
  pObj^ := TEdit.Create(Self); // Добавляем TEdit
  (pObj^ as TEdit).Name := 'Edit' + IntToStr(Length(arrObject));
  arrAdd(pObj^);
end;

// Способ второй
uses
  {...,} Contnrs;

var
  ObjList: TObjectList;
  pObj: ^TObject;

implementation

procedure TForm1.FormCreate(Sender: TObject);
begin
  ObjList := TObjectList.Create;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ObjList.Free;
end;

// Пример добавления объекта в список
procedure TForm1.Button1Click(Sender: TObject);
begin
  New(pObj);
  pObj^ := TEdit.Create(Self); // Добавляем TEdit
  (pObj^ as TEdit).Name := 'Edit' + IntToStr(ObjList.Count);
  ObjList.Add(pObj^);
end;

// Способ третий (для Delphi 2009 и выше)
uses
  {...,} Generics.Collections;

var
  ObjList: TList<TObject>;
  pObj: ^TObject;

implementation

procedure TForm1.FormCreate(Sender: TObject);
begin
  ObjList := TList<TObject>.Create;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ObjList.Free;
end;

// Пример добавления объекта в список
procedure TForm1.Button1Click(Sender: TObject);
begin
  New(pObj);
  pObj^ := TEdit.Create(Self); // Добавляем TEdit
  (pObj^ as TEdit).Name := 'Edit' + IntToStr(ObjList.Count);
  ObjList.Add(pObj^);
end;

Как запретить изменение размера компонента в design-time?


type
  TSomeClass = class(TCustomClass)
  public
    constructor Create(AOwner: TComponent); override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    {...}
  end;

// Установка размеров по умолчанию
constructor TSomeClass.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Self.Width := 50;
  Self.Height := 50;
end;

procedure TSomeClass.SetBounds(ALeft: integer; ATop: integer; AWidth: integer;
  AHeight: integer);
begin
  if csDesigning in ComponentState then
  begin
    AWidth := 50;
    AHeight := 50;
    inherited;
  end;
end;

Как узнать, какой контрол является активным в данный момент?


Screen.ActiveControl;

Как отключить контекстного меню для компонентов, наследников TWinControl?


// Способ первый
procedure TForm1.FormShow(Sender: TObject);
begin
  // Поместите компонент TPopupMenu на форму и назначте его свойству
  // PopupMenu компонентов, чье контекстное меню вы хотите отключить.
  Edit1.PopupMenu := PopupMenu1;
end;

// Способ второй
uses
  {...,} TypInfo;

// Процедура отключает всплывающее контекстное меню для всех управлений в контейнере.
procedure DisablePopUp(AControl: TWinControl);
var
  i: Integer;
  pm: TPopupMenu;
begin
  pm := TPopupMenu.Create(AControl);
  for i := 0 to AControl.ControlCount-1 do
    if IsPublishedProp(AControl.Controls[i], 'PopupMenu') then
      SetObjectProp(AControl.Controls[i], 'PopupMenu', pm);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  DisablePopUp(Form1);
  // DisablePopUp(Panel1);
end;

Как из строкового представления компонента получить компонент?


function StringToComponent( const Value: string ): TComponent;
var
  StrStream: TStringStream;
  BinStream: TMemoryStream;
begin
  StrStream := TStringStream.Create(Value);
  try
    BinStream := TMemoryStream.Create;
    try
      ObjectTextToBinary(StrStream, BinStream);
      BinStream.Seek(0, soFromBeginning);
      Result := BinStream.ReadComponent(nil);
    finally
      BinStream.Free;
    end;
  finally
    StrStream.Free;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // В программе необходимо зарегистрировать все классы,
  // с которыми планируется работать. Например TEdit.
  RegisterClass(TEdit);
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  s: string = 'object Edit1: TEdit' +
              '  Left = 16' +
              '  Top = 8' +
              '  Width = 121' +
              '  Height = 21' +
              '  TabOrder = 1' +
              '  Text = ''Edit1''' +
              'end';
var
  c: TComponent;
begin
  c := StringToComponent(s);
  Form1.InsertComponent(c);
  Form1.InsertControl(TControl(c));
  TControl(c).Top := 50;
end;

// или немного иначе

const
  s = 'object MyForm: TForm'#13 +
      '  Left = 0'#13 +
      '  Top = 0'#13 +
      '  Caption = ''Form15'''#13 +
      '  ClientHeight = 287'#13 +
      '  ClientWidth = 629'#13 +
      '  Color = clBtnFace'#13 +
      '  Font.Charset = DEFAULT_CHARSET'#13 +
      '  Font.Color = clWindowText'#13 +
      '  Font.Height = -11'#13 +
      '  Font.Name = ''Tahoma'''#13 +
      '  Font.Style = []'#13 +
      '  OldCreateOrder = False'#13 +
      '  WindowState = wsMaximized'#13 +
      '  PixelsPerInch = 96'#13 +
      '  TextHeight = 13'#13 +
      'end';

function StringToComponent(Value: string; Instance: Tcomponent = nil): Tcomponent;
var
  StrStream: TStringStream;
  BinStream: TMemoryStream;
begin
  StrStream := TStringStream.Create(Value);
  try
    BinStream := TMemoryStream.Create;
    try
      ObjectTextToBinary(StrStream, BinStream);
      BinStream.Seek(0, soFromBeginning);
      Result := BinStream.ReadComponent(Instance);
    finally
      BinStream.Free;
    end;
  finally
    StrStream.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  StringToComponent(s, Self);
  RecreateWnd;
end;

Как заставить компонент трястись?


type
  PThreadData = ^TThreadData;
  TThreadData = record
    Control: TControl;
    Radius: Integer;
  end;

  TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
  public
  end;

{...}

implementation

threadvar
  DataPtr: TThreadData;

function JoltingControl(Parameter: Pointer): Integer;
var
  i, x, y: Integer;
  lpDataPtr: PThreadData;
begin
  lpDataPtr := Parameter;

  x := TControl(lpDataPtr^.Control).Left;
  y := TControl(lpDataPtr^.Control).Top;

  Randomize;
  for i := 1 to 1500 do
  begin
    TControl(lpDataPtr^.Control).Left := x + Random(lpDataPtr^.Radius+1) - Random(lpDataPtr^.Radius+1);
    TControl(lpDataPtr^.Control).Top := y + Random(lpDataPtr^.Radius+1) - Random(lpDataPtr^.Radius+1);
  end;
  TControl(lpDataPtr^.Control).Left := x;
  TControl(lpDataPtr^.Control).Top := y;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ThreadId: DWORD;
  ThreadHandle: THandle;
begin
  DataPtr.Control := Edit1;
  DataPtr.Radius := 3;
  ThreadHandle := BeginThread(nil, 0, @JoltingControl, @DataPtr, 0, ThreadId);
  CloseHandle(ThreadHandle);
end;

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