Как разместить прозрачную надпись на TBitmap?

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
   OldBkMode : integer;
begin
   Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
   OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,TRANSPARENT);
   Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
   SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,OldBkMode);
end;

Можно ли обратиться к колонке или строке grid'а по заголовку?

Ответ:

В следующем примере приведены две функции: GetGridColumnByName() 
и GetGridRowByName(), которые возвращают колонку или строку, 
имеющую заданный заголовок (caption).
Пример:

procedure TForm1.FormCreate(Sender: TObject);
begin
	StringGrid1.Rows[1].Strings[0] := 'This Row';
	StringGrid1.Cols[1].Strings[0] := 'This Column';
end;

function GetGridColumnByName(Grid : TStringGrid; ColName : string): integer;
var
	i : integer;
begin
	for i := 0 to Grid.ColCount - 1 do
		if Grid.Rows[0].Strings[i] = ColName then 
			begin
		Result := i;
				exit;
			end;
	Result := -1;
end;

function GetGridRowByName(Grid : TStringGrid; RowName : string): integer;
var
	i : integer;
begin
	for i := 0 to Grid.RowCount - 1 do
		if Grid.Cols[0].Strings[i] = RowName then
			begin
				Result := i;
				exit;
			end;
	Result := -1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
	Column : integer;
	Row : integer;
begin
	Column := GetGridColumnByName(StringGrid1, 'This Column');
	if Column = -1 then
		ShowMessage('Column not found')
	else
		ShowMessage('Column found at ' + IntToStr(Column));
	Row := GetGridRowByName(StringGrid1, 'This Row');
	if Row = -1 then
		ShowMessage('Row not found')
	else
		ShowMessage('Row found at ' + IntToStr(Row));
end;

Как использовать клавишу-акселератор в TTabsheets? Я добавляю клавишу-акселератор в заголовок каждого Tabsheet моего PageControl, но при попытке переключать страницы этой клавишей программа пикает и ничего не происходит.

Ответ:
Можно перехватить сообщение CM_DIALOGCHAR.

Пример:
type
	TForm1 = class(TForm)
		PageControl1: TPageControl;
		TabSheet1: TTabSheet;
		TabSheet2: TTabSheet;
		TabSheet3: TTabSheet;
	private
		{Private declarations}
		procedure CMDialogChar(var Msg:TCMDialogChar);
		message CM_DIALOGCHAR;
	public
		{Public declarations}
end;

var
	Form1: TForm1;

implementation
{$R *.DFM}
procedure TForm1.CMDialogChar(var Msg:TCMDialogChar);
var
	i : integer;
begin
	with PageControl1 do
	begin
          if Enabled then
		for i := 0 to PageControl1.PageCount - 1 do
			if ((IsAccel(Msg.CharCode, Pages[i].Caption)) and
				(Pages[i].TabVisible)) then 
			begin
				Msg.Result:=1;
				ActivePage := Pages[i];
				exit;
			end;
	end;
	inherited;
end;

При использованиии компонента TRegistry под NT пользователь с права доступа ниже чем "администратор" не может получить доступа к информации реестра в ключе HKEY_LOCAL_MACHINE. Как это обойти? Ответ: Проблема вызвана тем, что TRegistry всегда открывает реестр с параметром KEY_ALL_ACCESS (полный доступ), даже если необходим доступ KEY_READ (только чтение). Избежать этого можно используя функции API для работы с реестром (RegOpenKey и т.п.), или создать новый класс из компонента TRegestry, и изменить его так чтобы можно было задавать режим открытия реестра. Наверх к содержанию

Можно ли изменить число колонок и их ширину в компоненте TFileListBox?

Ответ:

В приведенном примере FileListBox приводится к типу TDirectoryListBox
- таким образом можно добавиь дополнительные колонки.

Пример:

with TDirectoryListBox(FileListBox1) do 
begin
  Columns := 2;
  SendMessage(Handle, LB_SETCOLUMNWIDTH, Canvas.TextWidth('WWWWWWWW.WWW'),0);
end;

Как настроить табуляцию в компоненте TMemo? Ответ: Пошлите в Memo сообщение EM_SETTABSTOPS. Например установим первую позицию табуляции на 20-й пиксел. Пример:

procedure TForm1.FormCreate(Sender: TObject);
var
	DialogUnitsX : LongInt;
	PixelsX : LongInt;
	i : integer;
	TabArray : array[0..4] of integer;
begin
	Memo1.WantTabs := true;
	DialogUnitsX := LoWord(GetDialogBaseUnits);
	PixelsX := 20;
	for i := 1 to 5 do
	begin
		TabArray[i - 1] :=((PixelsX * i ) * 4) div DialogUnitsX;
	end;
	SendMessage(Memo1.Handle,
	EM_SETTABSTOPS,5,LongInt(@TabArray));
	Memo1.Refresh;
end;

Как перехватить нажатия функциональных клавиш и стрелок? Ответ: Проверяйте значение переменной key на равенство VK_RIGHT, VK_LEFT, VK_F1 и т.д. на событии KeyDown формы.

Пример:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
	if Key = VK_RIGHT then
		Form1.Caption := 'Right';
	if Key = VK_F1 then
		Form1.Caption := 'F1';
end;

При обработке события DrawCell компонента DrawGrid я пишу Font.Color := clRed; и получаю бесконечный цикл мерцаний. Почему?

Ответ:
Правильно укажите границы используемого канваса.

Пример:

If (Row = 0) then
  begin
     DrawGrid1.Canvas.Font.Color := clRed;
     DrawGrid1.Canvas.TextOut(Rect.Left,Rect.Top, IntToStr(Col));
  end;

При использовании BitBtn Caption(текст) и картинка(bitmap) из файла не видны одновременно. Почему? Ответ: Это может происходить если картинка слишком велика. Класс TBitBtn сначала рисует картинку, а затем выводит текст над, под, слева или справа от картинки (в завивимости от свойства Layout). Если размер картинки такой же как у всей кнопки для вывода текста просто не остается места. Если Вам нужно получить кнопку такого же размера как Ваша картинка и видеть при этом надпись на кнопке Вам придется выводить текст надписи непосредственно на канву картинки.

Пример:

var
	bm : TBitmap;
	OldBkMode : integer;
begin
	bm := TBitmap.Create;
	bm.Width := BitBtn1.Glyph.Width;
	bm.Height := BitBtn1.Glyph.Height;
	bm.Canvas.Draw(0, 0, BitBtn1.Glyph);
	OldBkMode := SetBkMode(bm.Canvas.Handle, Transparent);
	bm.Canvas.TextOut(0, 0, 'The Caption');
	SetBkMode(bm.Canvas.Handle, OldBkMode);
	BitBtn1.Glyph.Assign(bm);
end;

Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента управления Windows? Ответ: Можно! В примере показано как создать два цветных "bitmap'а": "улыбчивый" и "хмурый" и присвоить их курсору edit'а. Для этого нужно перехватить оконную процедуру edit'а. Чтобы сделать это заменим адрес оконной процедуры Edit'а нашим собственным, а старую оконную процедуру будем вызывать по необходимости. Пример показывает "улыбчивый" курсор при наборе текста и "хмурый" при забое клавишей backspace.

Пример:

unit caret1;

interface

{$IFDEF WIN32}
uses
	Windows, Messages, SysUtils, Classes, Graphics, Controls, 
	Forms, Dialogs, StdCtrls;
{$ELSE}
uses
	WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, 
	Controls, Forms, Dialogs, StdCtrls;
{$ENDIF}

type
	TForm1 = class(TForm)
		Edit1: TEdit;
		procedure FormCreate(Sender: TObject);
		procedure FormDestroy(Sender: TObject);
	private
		{Private declarations}
	public
		{Public declarations}
		CaretBm : TBitmap;
		CaretBmBk : TBitmap;
		OldEditsWindowProc : Pointer;
end;

var
	Form1: TForm1;

implementation
{$R *.DFM}

type
{$IFDEF WIN32}
	WParameter = LongInt;
{$ELSE}
	WParameter = Word;
{$ENDIF}
	LParameter = LongInt;

{New windows procedure for the edit control}
function NewWindowProc(WindowHandle : hWnd; 
			TheMessage : WParameter; ParamW : WParameter;
			ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
begin
{Call the old edit controls windows procedure}
	NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, 
			WindowHandle, TheMessage, ParamW, ParamL);
	if TheMessage = WM_SETFOCUS then
	begin
		CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
		ShowCaret(WindowHandle);
	end;
	if TheMessage = WM_KILLFOCUS then
	begin
		HideCaret(WindowHandle);
		DestroyCaret;
	end;
	if TheMessage = WM_KEYDOWN then
	begin
		if ParamW = VK_BACK then
			CreateCaret(WindowHandle, 
				Form1.CaretBmBk.Handle, 0, 0)
		else
			CreateCaret(WindowHandle, 
				Form1.CaretBm.Handle, 0, 0);
		ShowCaret(WindowHandle);
	end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
{Create a smiling bitmap using the wingdings font}
	CaretBm := TBitmap.Create;
	CaretBm.Canvas.Font.Name := 'WingDings';
	CaretBm.Canvas.Font.Height := Edit1.Font.Height;
	CaretBm.Canvas.Font.Color := clWhite;
	CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;
	CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;
	CaretBm.Canvas.Brush.Color := clBlue;
	CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, 
						CaretBm.Height));
	CaretBm.Canvas.TextOut(1, 1, 'J');
{Create a frowming bitmap using the wingdings font}
	CaretBmBk := TBitmap.Create;
	CaretBmBk.Canvas.Font.Name := 'WingDings';
	CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;
	CaretBmBk.Canvas.Font.Color := clWhite;
	CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;
	CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;
	CaretBmBk.Canvas.Brush.Color := clBlue;
	CaretBmBk.Canvas.FillRect(Rect(0,0, CaretBmBk.Width, 
						CaretBmBk.Height));
	CaretBmBk.Canvas.TextOut(1, 1, 'L');
{Hook the edit controls window procedure}
	OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle,
			GWL_WNDPROC, LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{Unhook the edit controls window procedure and clean up}
	SetWindowLong(Edit1.Handle,GWL_WNDPROC, 
				LongInt(OldEditsWindowProc));
	CaretBm.Free;
	CaretBmBk.Free;
end;

При использовании модулей доступа к BDE (DbiTypes, DbiProcs, DbiErrs), любая попытка вызвать процедуру abort выдает ошибку при компиляции при вызове метода abort "Statement expected, but expression of type 'Integer' found". Я пытался найти DbiTypes.pas, DbiProcs.pas и DbiErrs.pas чтобы разобраться но не нашел этих файлов. Где расположены эти файлы и как обойти ошибку?
Ответ:

Модули DbiTypes, DbiProcs, DbiErrs это псевдонимы модуля "BDE", обьявлены в Projects->Options->Directories/Conditionals->Unit Aliases. Исходник модуля DBE находится в каталоге "doc" и называется "BDE.INT". В этом файле обьявленна константа ABORT со значением -2. Так как Вы хотите использовать процедуру Abort(), которая обьявлена в модуле SysUtils, Вам нужно добавить префикс SysUtils перед вызовом процедуры Abort.

Пример:

SysUtils.Abort;


Наверх к содержанию



Вопрос:

Почему при изменении цвета букв StatusBar'а ничего не происходит?

Ответ:

Status bar - стандартный элемент управления Windows, и соответственно цвет его букв - значение clBtnText которое изменяется с помощью настроек в Control Panel. Этот цвет черный по умолчанию и может изменяться в зависимости от выбранной цветовой схемы. Другие стандартные элемент управления Windows, например кнопки, также имеют цвет букв, настраиваемый из ControlPanel. StatusBar и его панели имеют свойство "owner-draw", позволяющее Вам использовать любой цвет букв.

Пример:

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
			Panel: TStatusPanel; const Rect: TRect);
begin
  if Panel = StatusBar.Panels[0] then
	begin
	  StatusBar.Canvas.Font.Color := clRed;
	  StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0')
	end 
  else
	begin
	  StatusBar.Canvas.Font.Color := clGreen;
	  StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
	end;
  end;

Как сделать многострочную надпись на TBitBtn?
Ответ:

Выводите текст надписи непосредственно на "glyph" TBitBtn'а. См. пример.

Пример:

procedure TForm1.FormCreate(Sender: TObject);
var
	R : TRect;
	N : Integer;
	Buff : array[0..255] of Char;
begin
	with BitBtn1 do
	begin
		Caption := 'A really really long caption';
		Glyph.Canvas.Font := Self.Font;
		Glyph.Width  := Width - 6;
		Glyph.Height := Height - 6;
		R := Bounds(0, 0, Glyph.Width, 0);
		StrPCopy(Buff, Caption);
		Caption := '';
		DrawText(Glyph.Canvas.Handle,Buff,StrLen(Buff),R,
			DT_CENTER or DT_WORDBREAK or DT_CALCRECT);
		OffsetRect(R,(Glyph.Width - R.Right) div 2,
				(Glyph.Height - R.Bottom) div 2);
		DrawText(Glyph.Canvas.Handle,Buff,StrLen(Buff),R,
			DT_CENTER or DT_WORDBREAK);
	end;
end;

Как изменить стиль шрифта RichEdit нажатиями соответствующих комбинаций клавиш? (например включить курсив по нажатию Ctrl + I)

Ответ:
В примере стили шрифта меняются по нажатию след. комбинаций клавиш
	Ctrl + B - вкл/выкл жирного шрифта
	Ctrl + I - вкл/выкл наклонного шрифта
	Ctrl + S - вкл/выкл зачеркнутого шрифта
	Ctrl + U - вкл/выкл подчеркнутого шрифта


Пример:

const
	KEY_CTRL_B = 02;
	KEY_CTRL_I =  9;
	KEY_CTRL_S = 19;
	KEY_CTRL_U = 21;

procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char);
begin
  case Ord(Key) of
    KEY_CTRL_B: 
      begin
	Key := #0;
	if fsBold in (Sender as TRichEdit).SelAttributes.Style then
		(Sender as TRichEdit).SelAttributes.Style :=
		(Sender as TRichEdit).SelAttributes.Style - [fsBold]
	else
		(Sender as TRichEdit).SelAttributes.Style :=
		(Sender as TRichEdit).SelAttributes.Style + [fsBold];
      end;
    KEY_CTRL_I:
      begin
	Key := #0;
		if fsItalic in (Sender as TRichEdit).SelAttributes.Style then
			(Sender as TRichEdit).SelAttributes.Style :=
			(Sender as TRichEdit).SelAttributes.Style - [fsItalic]
		else
			(Sender as TRichEdit).SelAttributes.Style :=
			(Sender as TRichEdit).SelAttributes.Style + [fsItalic];
      end;
    KEY_CTRL_S:
      begin
	Key := #0;
	if fsStrikeout in (Sender as TRichEdit).SelAttributes.Style then
	  (Sender as TRichEdit).SelAttributes.Style :=
	  (Sender as TRichEdit).SelAttributes.Style-[fsStrikeout]
	else
	  (Sender as TRichEdit).SelAttributes.Style :=
	  (Sender as TRichEdit).SelAttributes.Style+[fsStrikeout];
      end;
    KEY_CTRL_U:
      begin
	Key := #0;
	if fsUnderline in (Sender as TRichEdit).SelAttributes.Style then
	  (Sender as TRichEdit).SelAttributes.Style :=
	  (Sender as TRichEdit).SelAttributes.Style-[fsUnderline]
	else
	  (Sender as TRichEdit).SelAttributes.Style :=
	  (Sender as TRichEdit).SelAttributes.Style+[fsUnderline];
      end;
    end;
end;

В документации компонента TRegIniFile говорится, что можно изменять корневой ключ (root key). Я пытаюсь это сделать но ничего не получается.

Ответ:
См. пример.

Пример:

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
	WinIni : TRegIniFile;
begin
	WinIni := TRegIniFile.Create('');
	WinIni.RootKey := HKEY_LOCAL_MACHINE;
	WinIni.WriteString('Frank','Borland','Writes Fast Code!');
	WinIni.Free;
end;

Можно ли динамически изменять свойство "owner" компонента во время выполнения программы? Ответ: Вы можете менять свойство "owner" и после создания компонента с помощью методов InsertComponent() и RemoveComponent(). Наверх к содержанию

Как очистить содержимое Canvas'а?

Ответ:

Просто нарисуйте прямоугольник любого цвета.

Пример:

Canvas.Brush.Color := ClWhite;
Canvas.FillRect(Canvas.ClipRect);

Можно ли динамически менять какая форма считается главной в приложении во время работы программы?
Ответ:

Можно, но только во время загрузки приложения. Чтобы сделать это выберите "View->Project Source" и измените код инициализации приложения, так что порядок создания форм зависил от какого-то условия.
Примечание: Вам придется редактировать этот код, если Вы добавите в приложение новые формы.

begin
	Application.Initialize;
	if <какое-то условие> then 
		begin
			Application.CreateForm(TForm1, Form1);
			Application.CreateForm(TForm2, Form2);
		end 
	else 
		begin
			Application.CreateForm(TForm2, Form2);
			Application.CreateForm(TForm1, Form1);
		end;
end.
Application.Run;

Как программно "щелкнуть" по компоненту speed button? Я пытался использовать SendMessage но у Speedbuttons нет "handle".

Ответ:
В примере используется метод Perform класса TControl для 
отправки сообщения.

Пример:

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
	ShowMessage('clicked');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
	SpeedButton1.Perform(WM_LBUTTONDOWN, 0, 0);
	SpeedButton1.Perform(WM_LBUTTONUP, 0, 0);
end;

Можно ли отключить определенный элемент в RadioGroup?
Ответ: В примере показано как получить доступ к отдельным элементам компонента TRadioGroup.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
	TRadioButton(RadioGroup1.Controls[1]). Enabled := False;
end;

Почему методы рисования Delphi (например MoveTo и LineTo) рисуют на один пиксел короче?
Ответ:

Так работает большинство графических систем, включая Windows. Библиотека VCL просто передает вызовы в функции GDI. Если Вы хотите нарисовать линию с последним пикселом включительно просто добавте единицу к координатам.

Наверх к содержанию

Как показать подсказки "hints" для элементов меню?
Ответ:

В примере создается обработчик события Application.Hint - подсказки меню изображаются на status panel.

Пример:

type
	TForm1 = class(TForm)
		Panel1: TPanel;
		MainMenu1: TMainMenu;
		MenuItemFile: TMenuItem;
		MenuItemOpen: TMenuItem;
		MenuItemClose: TMenuItem;
		OpenDialog1: TOpenDialog;
		procedure FormCreate(Sender: TObject);
		procedure MenuItemCloseClick(Sender: TObject);
		procedure MenuItemOpenClick(Sender: TObject);
	private
		{Private declarations}
		procedure HintHandler(Sender: TObject);
	public
		{Public declarations}
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
	Panel1.Align := alBottom;
	MenuItemFile.Hint := 'File Menu';
	MenuItemOpen.Hint := 'Opens A File';
	MenuItemClose.Hint := 'Closes the Application';
	Application.OnHint := HintHandler;
end;

procedure TForm1.HintHandler(Sender: TObject);
begin
	Panel1.Caption := Application.Hint;
end;

procedure TForm1.MenuItemCloseClick(Sender: TObject);
begin
	Application.Terminate;
end;

procedure TForm1.MenuItemOpenClick(Sender: TObject);
begin
	if OpenDialog1.Execute then
		Form1.Caption := OpenDialog1.FileName;
end;

Как опеделить состояние списка ComboBox, выпал/скрыт?
Ответ:

Пошлите ComboBox сообщение CB_GETDROPPEDSTATE.

Пример:

if SendMessage(ComboBox1.Handle, CB_GETDROPPEDSTATE,0,0) = 1 then
	begin {список ComboBox выпал}

	end;

Как удалить каталог вместе со всеми содержащимися в нем файлами?
Ответ:

В примере стираются все файлы в каталоге и сам каталог. Чтобы удалить файл, помечанные только для чтения (read only) и занятые другими программами в момент удаления - напишите дополнительную процедуру.

procedure TForm1.Button1Click(Sender: TObject);
var
	DirInfo: TSearchRec;
	r: integer;
begin
  r := FindFirst('C:\Download\*.*', FaAnyfile, DirInfo);
  while r = 0 do
  begin
    if ((DirInfo.Attr and FaDirectory <> FaDirectory) and
	(DirInfo.Attr and FaVolumeId <> FaVolumeID)) then
    if DeleteFile(pChar('C:\Download\' + DirInfo.Name))= false then
	ShowMessage('Unable to delete: C:\Download\'+DirInfo.Name);
    r := FindNext(DirInfo);
  end;
  SysUtils.FindClose(DirInfo);
  if RemoveDirectory('C:\Download\') = false then
	ShowMessage('Unable to delete directory: C:\Download\');
end;

Как отключить системное меню формы и кнопки Minimize, Maximize, and Close во время выполнения(Runtime)?
Ответ:

В приведенном примере показано как это сделать

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
	{Disable}
	Form1.BorderIcons := Form1.BorderIcons - 
			[biSystemMenu, biMinimize, biMaximize];
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
	{Enable}
	Form1.BorderIcons := Form1.BorderIcons + 
			[biSystemMenu, biMinimize, biMaximize];
end;

Как извлечь Red, Green, и Blue компонент из определенного цвета? Ответ: Используйте функции Window API Get RValue(), GetGValue(), и GetBValue(). Пример: procedure TForm1.Button1Click(Sender: TObject); begin Form1.Canvas.Pen.Color := clRed; Memo1.Lines.Add('Red := ' + IntToStr(GetRValue(Form1.Canvas.Pen.Color))); Memo1.Lines.Add('Red := ' + IntToStr(GetGValue(Form1.Canvas.Pen.Color))); Memo1.Lines.Add('Blue:= ' + IntToStr(GetBValue(Form1.Canvas.Pen.Color))); end; Наверх к содержанию

Как определить номер текущей строки в TMemo? Ответ: Чтобы определить номер текущей строки любого объекта управления edit - пошлите ей сообщение EM_LINEFROMCHAR

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
	LineNumber : integer;
begin
	LineNumber := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, word(-1), 0);
	ShowMessage(IntToStr(LineNumber));
end;


Наверх к содержанию



Вопрос:

Как проигрываеть MPEG файл в Delphi-программе?

Ответ:

Если в системе Windows MMSystem установлен декодер MPEG - используя компонент 
TMediaPlayer

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
	MediaPlayer1.Filename := 'C:\DownLoad\rsgrow.mpg';
	MediaPlayer1.Open;
	MediaPlayer1.Display := Panel1;
	MediaPlayer1.DisplayRect := Panel1.ClientRect;
	MediaPlayer1.Play;
end;


Наверх к содержанию



Вопрос:

Как использовать анимированный курсор?

Ответ:

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
	h : THandle;
begin
	h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or
			LR_LOADFROMFILE);
	if h = 0 then
		ShowMessage('Cursor not loaded')
	else
		begin
			Screen.Cursors[1] := h;
			Form1.Cursor := 1;
		end;
end;


Наверх к содержанию



Вопрос:

Как узнать о нажатии "non-menu" клавиши в момент когда меню показано?

Ответ:
Создайте обработчик сообщения WM_MENUCHAR.

Пример:

unit Unit1;

interface

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

type 
	TForm1 = class(TForm)
		MainMenu1: TMainMenu;
		One1: TMenuItem;
		Two1: TMenuItem;
		THree1: TMenuItem;
	private
		{Private declarations}
		procedure WmMenuChar(var m : TMessage); message WM_MENUCHAR;
	public
		{Public declarations}
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WmMenuChar(var m : TMessage);
begin
	Form1.Caption := 'Non standard menu key pressed';
	m.Result := 1;
end;
end.


Наверх к содержанию



Вопрос:

Как определить наличие сопроцессора?

Ответ:

Пример:

{$IFDEF WIN32}

uses Registry;

{$ENDIF}

function HasCoProcesser : bool;
{$IFDEF WIN32}
var
	TheKey : hKey;
{$ENDIF}
begin
	Result := true;
	{$IFNDEF WIN32}
	if GetWinFlags and Wf_80x87 = 0 then
	Result := false;
	{$ELSE}
	if RegOpenKeyEx(HKEY_LOCAL_MACHINE,
	'HARDWARE\DESCRIPTION\System\FloatingPointProcessor',0,
	KEY_EXECUTE, TheKey) <> ERROR_SUCCESS then result := false;
	RegCloseKey(TheKey);
{$ENDIF}
	end;

procedure TForm1.Button1Click(Sender: TObject);
begin
	if HasCoProcesser then
		ShowMessage('Has CoProcessor') 
	else
		ShowMessage('No CoProcessor - Windows Emulation Mode');
end;


Наверх к содержанию



Вопрос:

Как узнать серийный номер аудио CD?

Ответ:

Пример:

uses MMSystem, MPlayer;

procedure TForm1.Button1Click(Sender: TObject);
var
	mp : TMediaPlayer;
	msp : TMCI_INFO_PARMS;
	MediaString : array[0..255] of char;
	ret : longint;
begin
	mp := TMediaPlayer.Create(nil);
	mp.Visible := false;
	mp.Parent := Application.MainForm;
	mp.Shareable := true;
	mp.DeviceType := dtCDAudio;
	mp.FileName := 'D:';
	mp.Open;
	Application.ProcessMessages;
	FillChar(MediaString, sizeof(MediaString), #0);
	FillChar(msp, sizeof(msp), #0);
	msp.lpstrReturn := @MediaString;
	msp.dwRetSize := 255;
	ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY,
			longint(@msp));
	if Ret <> 0 then
		begin
			MciGetErrorString(ret, @MediaString, sizeof(MediaString));
			Memo1.Lines.Add(StrPas(MediaString));
		end
	else
		Memo1.Lines.Add(StrPas(MediaString));
	mp.Close;
	Application.ProcessMessages;
	mp.free;
end;
end.


Наверх к содержанию



Вопрос:

Как вывести на элемент управления (Window control) текст, содержащий амперсанд - & ?

Ответ:

Пример:

Button1.Caption := 'Черное && Белое';

Наверх к содержанию



Вопрос:

Как поместить bitmap в Metafile?

Ответ: см. пример

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
	m : TmetaFile;
	mc : TmetaFileCanvas;
	b : tbitmap;
begin
	m := TMetaFile.Create;
	b := TBitmap.create;
	b.LoadFromFile('C:\SomePath\SomeBitmap.BMP');
	m.Height := b.Height;
	m.Width := b.Width;
	mc := TMetafileCanvas.Create(m, 0);
	mc.Draw(0, 0, b);
	mc.Free;
	b.Free;
	m.SaveToFile('C:\SomePath\Test.emf');
	m.Free;
	Image1.Picture.LoadFromFile('C:\SomePath\Test.emf');
end;


Наверх к содержанию



Вопрос:

Как узнать, что курсор мыши над моей формой?

Ответ:
Можно использовать функцию GetCapture() из Windows API.

Примечание: Cм. документацию Windows для информации об ограничениях функции GetCapture.

Пример:

procedure TForm1.FormDeactivate(Sender: TObject);
begin
	ReleaseCapture;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
	If GetCapture = 0 then
		SetCapture(Form1.Handle);
	if PtInRect(Rect(Form1.Left,Form1.Top,Form1.Left + Form1.Width,
			Form1.Top + Form1.Height), ClientToScreen(Point(x, y))) then
		Form1.Caption := 'Мышка над формой!'
	else
		Form1.Caption := 'Мышка вне формы...';
end;


Наверх к содержанию



Вопрос:

Как программно определить, что приложение работает под Windows NT?

Ответ:см. пример

Пример:

function IsNT : bool;
var
	osv : TOSVERSIONINFO;
begin
	result := true;
	GetVersionEx(osv);
	if osv.dwPlatformId = VER_PLATFORM_WIN32_NT then exit;
	result := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
	if IsNt then
		ShowMessage('Running on NT')
	else
		ShowMessage('Not Running on NT');
end;


Наверх к содержанию



Вопрос:

Как создать bitmap из пиктогрммы (icon)?

Ответ:
Используя Bitmap.Canvas.Draw нарисуйте пиктограмму на Bitmap'е.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
	TheIcon : TIcon;
	TheBitmap : TBitmap;
begin
		TheIcon := TIcon.Create;
		TheIcon.LoadFromFile('C:\Program Files\Borland\IcoCur32\EARTH.ICO');
		TheBitmap := TBitmap.Create;
		TheBitmap.Height := TheIcon.Height;
		TheBitmap.Width := TheIcon.Width;
		TheBitmap.Canvas.Draw(0, 0, TheIcon);
		Form1.Canvas.Draw(10, 10, TheBitmap);
		TheBitmap.Free;
		TheIcon.Free;
	end;


Наверх к содержанию



Вопрос:

  Как создать отдельную подсказку (hint) для каждой ячейки StringGrid?

Ответ:

Пример:

type
	TForm1 = class(TForm)
		StringGrid1: TStringGrid;
		procedure StringGrid1MouseMove(Sender: TObject;
		Shift: TShiftState; X, Y: Integer);
		procedure FormCreate(Sender: TObject);
	private
	{Private declarations}
		Col : integer;
		Row : integer;
	public
	{Public declarations}
   end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
	StringGrid1.Hint := '0 0';
	StringGrid1.ShowHint := True;
end;

procedure TForm1.StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
	r : integer;
	c : integer;
begin
	StringGrid1.MouseToCell(X, Y, C, R);
	with StringGrid1 do
		begin
			if ((Row <> r) or(Col <> c)) then
				begin
					Row := r;
					Col := c;
					Application.CancelHint;
					StringGrid1.Hint :=IntToStr(r)+#32+IntToStr(c);
				end;
		end;
end;


Наверх к содержанию



Вопрос:

Как внести изменения в код VCL?

Ответ:

Delphi 1 : Options | Environment | Library
Delphi 2 : Tools | Options | Library
Delphi 3 :  Tools | Environment Options | Library
Delphi 4 :  Tools | Environment Options | Library
C++ Builder : Options | Environment | Library


Наверх к содержанию



Вопрос:


Как в Delphi реализовать функцию - эквивалент TwipsPerPixel из VisualBasic?

Ответ:
Функции  TwipsPerPixelX и TwipsPerPixelY, приведенные в примере реализуют ту же
функциональность в  Delphi.

Пример:

function TwipsPerPixelX(Canvas : TCanvas) : Extended;
begin
	result := 1440 / GetDeviceCaps(Canvas.Handle, LOGPIXELSX);
end;

function TwipsPerPixelY(Canvas : TCanvas) : Extended;
begin
	result := 1440 / GetDeviceCaps(Canvas.Handle, LOGPIXELSY);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
	ShowMessage(FloatToStr(TwipsPerPixelX(Form1.Canvas)));
	ShowMessage(FloatToStr(TwipsPerPixelY(Form1.Canvas)));
end;


Наверх к содержанию



Вопрос:

Как вставить содержимое файла в текущую позицию курсора в компонете TMemo?

Ответ:

var
	TheMStream : TMemoryStream;
	Zero : char;
begin
	TheMStream := TMemoryStream.Create;
	TheMStream.LoadFromFile('C:\AUTOEXEC.BAT');
	TheMStream.Seek(0, soFromEnd); 
	//Null terminate the buffer!
	Zero := #0;
	TheMStream.Write(Zero, 1);
	TheMStream.Seek(0, soFromBeginning);
	Memo1.SetSelTextBuf(TheMStream.Memory);
	TheMStream.Free;
end;


Наверх к содержанию



Вопрос:

Ответ:
См. пример.

Пример:

uses ClipBrd;

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
	if ((Key = ord('V')) and (ssCtrl in Shift)) then
		begin
			if Clipboard.HasFormat(CF_TEXT) then 
				ClipBoard.Clear;
			Memo1.SelText := 'Delphi is RAD!';
			key := 0;
		end;
end;


Наверх к содержанию



Вопрос:

Ответ:

Пример:

procedure TForm1.FormCreate(Sender: TObject);
begin
	Memo1.Alignment := taRightJustify;
	Memo1.MaxLength := 24;
	Memo1.WantReturns := false;
	Memo1.WordWrap := false;
end;

procedure MultiLineMemoToSingleLine(Memo : TMemo);
var
	t : string;
begin
	t := Memo.Text;
	if Pos(#13, t) > 0  then
		begin
			while Pos(#13, t) > 0 do
				delete(t, Pos(#13, t), 1);
			while Pos(#10, t) > 0 do
				delete(t, Pos(#10, t), 1);
			Memo.Text := t;
		end;
end;

procedure TForm1.Memo1Change(Sender: TObject);
begin
	MultiLineMemoToSingleLine(Memo1);
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
	MultiLineMemoToSingleLine(Memo1);
end;


Наверх к содержанию



Вопрос:


Как запрограммировать undo?

Ответ:См. пример

Memo1.Perform(EM_UNDO, 0, 0);

Если Вы хотите узнать, возможно ли выполнить операцию "Undo", проверьте "Undo status":

If Memo1.Perform(EM_CANUNDO, 0, 0) <> 0 then
begin
	{Undo is possible}
end;

Для выполнения "Redo" выполните "Undo" еще раз.


Наверх к содержанию



Вопрос:

Можно ли создать форму, которая получает дополнительные параметры в методе Сreate?

Ответ:
Просто замените конструктор Create класса Вашей формы.

Пример:

unit Unit2;

interface

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

type
	TForm2 = class(TForm)
	private
		{Private declarations}
	public
		constructor CreateWithCaption(aOwner: TComponent; aCaption: string);
		{Public declarations} 
end;

var
	Form2: TForm2;

implementation

{$R *.DFM}

constructor TForm2.CreateWithCaption(aOwner: TComponent; aCaption: string);
begin
	Create(aOwner);
	Caption := aCaption;
end;

uses Unit2;
procedure TForm1.Button1Click(Sender: TObject);
begin
	Unit2.Form2 :=Unit2.TForm2.CreateWithCaption(Application, 'My Caption');
	Unit2.Form2.Show;
end;


Наверх к содержанию



Вопрос:

Почему при изменении цвета шрифта в StatusBar's он (шрифт) не меняется?

Ответ:

Пример:

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel;
								const Rect: TRect);
begin
	if Panel = StatusBar.Panels[0] then
		begin
			StatusBar.Canvas.Font.Color := clRed;
			StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0')
		end
	else
		begin
			StatusBar.Canvas.Font.Color := clGreen;
			StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
		end;
end;


Наверх к содержанию



Вопрос:

Ответ:

Пример:

uses CommCtrl, ComCtrls;

type TMyTrackBar = class(TTrackBar)
	procedure CreateParams(var Params: TCreateParams); override;
end;

procedure TMyTrackBar.CreateParams(var Params: TCreateParams);
begin
	inherited;
		Params.Style := Params.Style and not TBS_ENABLESELRANGE;
end;

var
	MyTrackbar : TMyTrackbar;

procedure TForm1.Button1Click(Sender: TObject);
begin
	MyTrackBar := TMyTrackbar.Create(Form1);
	MyTrackbar.Parent := Form1;
	MyTrackbar.Left := 100;
	MyTrackbar.Top := 100;
	MyTrackbar.Width := 150;
	MyTrackbar.Height := 45;
	MyTrackBar.Visible := true;
end;


Наверх к содержанию



Вопрос:

Ответ:

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
	bm : TBitmap;
begin
	bm := TBitmap.Create;
	bm.Width := 100;
	bm.Height := 100;
	bm.Canvas.Brush.Color := clRed;
	bm.Canvas.FillRect(Rect(0, 0, 100, 100));
	bm.Canvas.MoveTo(0, 0);
	bm.Canvas.LineTo(100, 100);
	Form1.Canvas.StretchDraw(Form1.ClientRect,Bm);
	bm.Free;
end;


Наверх к содержанию



Вопрос:

Ответ:

Пример:

function InitStdBitBtn(BitBtn : TBitBtn; kind : TBitBtnKind) : bool;
var
	Bm1 : TBitmap;
	Bm2 : TBitmap;
begin
	Result := false;
	if Kind = bkCustom then exit;
	Bm1 := TBitmap.Create;
	case Kind of
		bkOK : Bm1.Handle := LoadBitmap(hInstance, 'BBOK');
		bkCancel : Bm1.Handle := LoadBitmap(hInstance, 'BBCANCEL');
		bkHelp : Bm1.Handle := LoadBitmap(hInstance, 'BBHELP');
		bkYes : Bm1.Handle := LoadBitmap(hInstance, 'BBYES');
		bkNo : Bm1.Handle := LoadBitmap(hInstance, 'BBNO');
		bkClose : Bm1.Handle := LoadBitmap(hInstance, 'BBCLOSE');
		bkAbort : Bm1.Handle := LoadBitmap(hInstance, 'BBABORT');
		bkRetry : Bm1.Handle := LoadBitmap(hInstance, 'BBRETRY');
		bkIgnore : Bm1.Handle := LoadBitmap(hInstance, 'BBIGNORE');
		bkAll : Bm1.Handle := LoadBitmap(hInstance, 'BBALL');
	end;
	Bm2 := TBitmap.Create;
	Bm2.Width := Bm1.Width;
	Bm2.Height := Bm1.Height;
	Bm2.Canvas.Brush.Color := ClBtnFace;
	Bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
					Rect(0, 0, Bm1.width, Bm1.Height),
	Bm1.canvas.pixels[0,0]);
	Bm1.Free;
	LockWindowUpdate(BitBtn.Parent.Handle);
	BitBtn.Kind := kind;
	BitBtn.Glyph.Assign(bm2);
	LockWindowUpdate(0);
	Bm2.Free;
	Result := true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
	InitStdBitBtn(BitBtn1, bkOk);
end;


Наверх к содержанию



Вопрос:

Создание PolyPolygon используя массив точек?

Ответ:

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
	ptArray : array[0..9] of TPOINT;
	PtCounts : array[0..1] of integer;
begin
	PtArray[0] := Point(0, 0);
	PtArray[1] := Point(0, 100);
	PtArray[2] := Point(100, 100);
	PtArray[3] := Point(100, 0);
	PtArray[4] := Point(0, 0);
	PtCounts[0] := 5;
	PtArray[5] := Point(25, 25);
	PtArray[6] := Point(25, 75);
	PtArray[7] := Point(75, 75);
	PtArray[8] := Point(75, 25);
	PtArray[9] := Point(25, 25);
	PtCounts[1] := 5;
	PolyPolygon(Form1.Canvas.Handle,
	PtArray,PtCounts,2);
end;


Наверх к содержанию



Вопрос:

Ответ:

Наверх к содержанию



Вопрос:

Ответ:
См. пример

Пример:

procedure TForm1.FormCreate(Sender: TObject);
begin
	{Высоту combobox'а не изменишь, так что вместо combobox'а
				будем изменять высоту строки grid'а !}
	StringGrid1.DefaultRowHeight := ComboBox1.Height;
	{Спрятать combobox}
	ComboBox1.Visible := False;
	ComboBox1.Items.Add('Delphi Kingdom');
	ComboBox1.Items.Add('Королевство Дельфи');
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
	{Перебросим выбранное в значение из ComboBox в grid}
	StringGrid1.Cells[StringGrid1.Col,
	StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex];
	ComboBox1.Visible := False;
	StringGrid1.SetFocus;
end;

procedure TForm1.ComboBox1Exit(Sender: TObject);
begin
	{Перебросим выбранное в значение из ComboBox в grid}
	StringGrid1.Cells[StringGrid1.Col,
	StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex];
	ComboBox1.Visible := False;
	StringGrid1.SetFocus;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol,
					ARow: Integer; var CanSelect: Boolean);
var
	R: TRect;
begin
	if ((ACol = 3) AND (ARow <> 0)) then
		begin
			{Ширина и положение ComboBox должно соответствовать
								ячейке StringGrid}
			R := StringGrid1.CellRect(ACol, ARow);
			R.Left := R.Left + StringGrid1.Left;
			R.Right := R.Right + StringGrid1.Left;
			R.Top := R.Top + StringGrid1.Top;
			R.Bottom := R.Bottom + StringGrid1.Top;
			ComboBox1.Left := R.Left + 1;
			ComboBox1.Top := R.Top + 1;
			ComboBox1.Width := (R.Right + 1) - R.Left;
			ComboBox1.Height := (R.Bottom + 1) - R.Top;
			{Покажем combobox}
			ComboBox1.Visible := True;
			ComboBox1.SetFocus;
		end;
	CanSelect := True;
end;


Наверх к содержанию



Вопрос:

Как узнать есть ли в заданном CD-ROM'е Audio CD?

Ответ:

Пример:

function IsAudioCD(Drive : char) : bool;
var
	DrivePath : string;
	MaximumComponentLength : DWORD;
	FileSystemFlags : DWORD;
	VolumeName : string;
Begin
	sult := false;
	DrivePath := Drive + ':\';
	if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then 
		exit;
	SetLength(VolumeName, 64);
	GetVolumeInformation(PChar(DrivePath),PChar(VolumeName),
	Length(VolumeName),nil,MaximumComponentLength,FileSystemFlags,nil,0);
	if lStrCmp(PChar(VolumeName),'Audio CD') = 0 then
		result := true;
end;

function PlayAudioCD(Drive : char) : bool;
var
	mp : TMediaPlayer;
begin
	result := false;
	Application.ProcessMessages;
	if not IsAudioCD(Drive) then
		exit;
	mp := TMediaPlayer.Create(nil);
	mp.Visible := false;
	mp.Parent := Application.MainForm;
	mp.Shareable := true;
	mp.DeviceType := dtCDAudio;
	mp.FileName := Drive + ':';
	mp.Shareable := true;
	mp.Open;
	Application.ProcessMessages;
	mp.Play;
	Application.ProcessMessages;
	mp.Close;
	Application.ProcessMessages;
	mp.free;
	result := true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
	if not PlayAudioCD('D') then
		ShowMessage('Not an Audio CD');
end;


Наверх к содержанию



Вопрос:

Как узнать есть ли у мыши колесико?

Ответ:
Свойство "WheelPresent" глобального обьекта "mouse".


Наверх к содержанию



Вопрос:

Ответ:

Пример:

type
	TForm1 = class(TForm)
	private
		procedure CMDialogKey( Var msg: TCMDialogKey );
		message CM_DIALOGKEY;
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.CMDialogKey(var msg: TCMDialogKey);
begin
	if msg.Charcode <> VK_TAB then
		inherited;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
	if Key = VK_TAB then
	Form1.Caption := 'Tab Key Down!';
end;


Наверх к содержанию



Вопрос:

В чем отличие между Create(Self) и Create(Application)?

Ответ:

Наверх к содержанию



Вопрос:

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

Ответ:
function HasProperty(Obj : TObject; Prop : string) : PPropInfo;
begin
	Result := GetPropInfo(Obj.ClassInfo, Prop);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
	p : pointer;
begin
	p :=  HasProperty(Button1, 'Color');
	if p <> nil then
		SetOrdProp(Button1, p, clRed)
	else
		ShowMessage('Button has no color property');
	p :=  HasProperty(Label1, 'Color');
	if p <> nil then
		SetOrdProp(Label1, p, clRed)
	else
		ShowMessage('Label has no color property');
	p :=  HasProperty(Label1.Font, 'Color');
	if p <> nil then
		SetOrdProp(Label1.Font.Color, p, clBlue)
	else
		ShowMessage('Label.Font has no color property');
end;


Наверх к содержанию



Вопрос:

Как при проигрывании музыки с Audio CD показывать сколько прошло минут и секунд?

Ответ:
В примере время выводится по таймеру.

Пример:

uses MMSystem;

procedure TForm1.Timer1Timer(Sender: TObject);
var
	Trk : Word;
	Min : Word;
	Sec : Word;
begin
	with MediaPlayer1 do
		begin
			Trk := MCI_TMSF_TRACK(Position);
			Min := MCI_TMSF_MINUTE(Position);
			Sec := MCI_TMSF_SECOND(Position);
			Label1.Caption := Format('%.2d',[Trk]);
			Label2.Caption := Format('%.2d:%.2d',[Min,Sec]);
		end;
end;


Наверх к содержанию



Вопрос:

Можно ли рисовать на рамке формы?

Ответ:
Обрабатывайте событие WM_NCPAINT. В примере рамка обводится красной линией
толщиной в 1 пиксел.

Пример:

type
	TForm1 = class(TForm)
	private
	{Private declarations}
		procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT;
	public
	{Public declarations}
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
	dc : hDc;
	Pen : hPen;
	OldPen : hPen;
	OldBrush : hBrush;
begin
	inherited;
	dc := GetWindowDC(Handle);
	msg.Result := 1;
	Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));
	OldPen := SelectObject(dc, Pen);
	OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
	Rectangle(dc, 0,0, Form1.Width, Form1.Height);
	SelectObject(dc, OldBrush);
	SelectObject(dc, OldPen);
	DeleteObject(Pen);
	ReleaseDC(Handle, Canvas.Handle);
end;


Наверх к содержанию



Вопрос:

Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением?

Ответ:
Создайте процедуру, которая будет вызываться при событии Application.OnIdle.

Обьявим процедуру:
{Private declarations}
procedure IdleEventHandler(Sender: TObject; var Done: Boolean);

В разделе implementation опишем поцедуру:

procedure TForm1.IdleEventHandler(Sender: TObject; var Done: Boolean);
begin
	{Do a small bit of work here}
	Done := false;
end;

В методе Form'ы OnCreate - укажем что наша процедура вызывается на событии 
Application.OnIdle.

Application.OnIdle := IdleEventHandler;

Наверх к содержанию



Вопрос:

Ответ:

Наверх к содержанию



Вопрос:

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

Ответ:

type
	TForm1 = class(TForm)
		PopupMenu1: TPopupMenu;
		Pop11: TMenuItem;
		Pop21: TMenuItem;
		Pop31: TMenuItem;
		procedure FormCreate(Sender: TObject);
		procedure FormDestroy(Sender: TObject);
		procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
							Shift: TShiftState; X, Y: Integer);
	private
		{Private declarations}
		bmUnChecked : TBitmap;
		bmChecked : TBitmap;
	public
		{Public declarations}
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
	bmUnChecked := TBitmap.Create;
	bmUnChecked.LoadFromFile('C:\Program Files\Borland\BitBtns\ALARMRNG.BMP');
	bmChecked := TBitmap.Create;
	bmChecked.LoadFromFile('C:\Program Files\Borland\BitBtns\CHECK.BMP');
	{Add the bitmaps to the item at index 1 in PopUpMenu}
	SetMenuItemBitmaps(PopUpMenu1.Handle,1,MF_BYPOSITION,BmUnChecked.Handle,
									BmChecked.Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
	bmUnChecked.Free;
	bmChecked.Free;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
						Shift: TShiftState; X, Y: Integer);
var
	pt : TPoint;
begin
	pt := ClientToScreen(Point(x, y));
	PopUpMenu1.Popup(pt.x, pt.y);
end;


Наверх к содержанию



Вопрос:

Как узнать число кадров AVI файла, и выяснить как долго будет проигрывться этот файл?

Ответ:
В приведенном примере указано как получить эту информацию.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
	MediaPlayer1.TimeFormat := tfFrames;
	ShowMessage('Number of frames = ' + IntToStr(MediaPlayer1.Length));
	MediaPlayer1.TimeFormat := tfMilliseconds;
	ShowMessage('Number of milliseconds = ' + IntToStr(MediaPlayer1.Length));
end;


Наверх к содержанию



Вопрос:

Как изменить число фиксированных колонок в TDbGrid?

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
	TStringGrid(DbGrid1).FixedCols := 2;
end;


Наверх к содержанию



Вопрос:

Ответ:

procedure TForm1.Button1Click(Sender: TObject);
begin
	DbGrid1.Enabled := false;
	DbGrid1.Font.Color := clGray;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
	DbGrid1.Enabled := true;
	DbGrid1.Font.Color := clBlack;
end;


Наверх к содержанию



Вопрос:

Как определить нажаты ли клавиши Shift, Alt, or Ctrl в какой-либо момент времени?

Ответ:

Пример:

function CtrlDown : Boolean;
var
	State : TKeyboardState;
begin
	GetKeyboardState(State);
	Result := ((State[vk_Control] And 128) <> 0);
end;

function ShiftDown : Boolean;
var
	State : TKeyboardState;
begin
	GetKeyboardState(State);
	Result := ((State[vk_Shift] and 128) <> 0);
end;

function AltDown : Boolean;
var
	State : TKeyboardState;
begin
	GetKeyboardState(State);
	Result := ((State[vk_Menu] and 128) <> 0);
end;
procedure TForm1.MenuItem12Click(Sender: TObject);
begin
	if ShiftDown then
		Form1.Caption := 'Shift'
	else	
		Form1.Caption := '';
end;

Наверх к содержанию



Вопрос:

Как изменить шрифта hint'а?

Ответ:
В примере перехватывается событие Application.OnShowHint и изменяется шрифт Hint'а.

Пример:

type
	TForm1 = class(TForm)
		procedure FormCreate(Sender: TObject);
	private
		{Private declarations}
	public
		procedure MyShowHint(var HintStr: string;
			var CanShow: Boolean;var HintInfo: THintInfo);
		{Public declarations}
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.MyShowHint(var HintStr: string; var CanShow: Boolean;
								var HintInfo: THintInfo);
var
	i : integer;
begin
	for i := 0 to Application.ComponentCount - 1 do
	if Application.Components[i] is THintWindow then
		with THintWindow(Application.Components[i]).Canvas do
			begin
				Font.Name:= 'Arial';
				Font.Size:= 18;
				Font.Style:= [fsBold];
				HintInfo.HintColor:= clWhite;
			end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
	Application.OnShowHint := MyShowHint;
end;


Наверх к содержанию



Вопрос:

Есть ли в Delphi эквивалент функции SendKeys Visual Basic'а?

Ответ:

Пример:

procedure SimulateKeyDown(Key : byte);
begin
	keybd_event(Key, 0, 0, 0);
end;

procedure SimulateKeyUp(Key : byte);
begin
	keybd_event(Key, 0, KEYEVENTF_KEYUP, 0);
end;

procedure SimulateKeystroke(Key : byte; extra : DWORD);
begin
	keybd_event(Key,extra,0,0);
	keybd_event(Key,extra,KEYEVENTF_KEYUP,0);
end;

procedure SendKeys(s : string);
var
	i : integer;
	flag : bool;
	w : word;
begin
	{Get the state of the caps lock key}
	flag := not GetKeyState(VK_CAPITAL) and 1 = 0;
	{If the caps lock key is on then turn it off}
	if flag then
		SimulateKeystroke(VK_CAPITAL, 0);
	for i := 1 to Length(s) do
		begin
			w := VkKeyScan(s[i]);
			{If there is not an error in the key translation}
			if ((HiByte(w) <> $FF) and (LoByte(w) <> $FF)) then
				begin
					{If the key requires the shift key down - hold it down}
					if HiByte(w) and 1 = 1 then
						SimulateKeyDown(VK_SHIFT);
						{Send the VK_KEY}
					SimulateKeystroke(LoByte(w), 0);
					{If the key required the shift key down - release it}
					if HiByte(w) and 1 = 1 then
						SimulateKeyUp(VK_SHIFT);
				end;
		end;
{if the caps lock key was on at start, turn it back on}
if flag then
	SimulateKeystroke(VK_CAPITAL, 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
	{Toggle the cap lock}
	SimulateKeystroke(VK_CAPITAL, 0);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
	{Capture the entire screen to the clipboard}
	{by simulating pressing the PrintScreen key}
	SimulateKeystroke(VK_SNAPSHOT, 0);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
	{Capture the active window to the clipboard}
	{by simulating pressing the PrintScreen key}
	SimulateKeystroke(VK_SNAPSHOT, 1);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
	{Set the focus to a window (edit control) and send it a string}
	Application.ProcessMessages;
	Edit1.SetFocus;
	SendKeys('Delphi Is RAD!');
end;


Наверх к содержанию



Вопрос:

Я загружаю TImageList динамически. Как сделать картинки из TImageList прозрачными?

Ответ:
См. ответ.
 
Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
	bm : TBitmap;
	il : TImageList;
begin
	bm := TBitmap.Create;
	bm.LoadFromFile('C:\DownLoad\TEST.BMP');
	il := TImageList.CreateSize(bm.Width,bm.Height);
	il.DrawingStyle := dsTransparent;
	il.Masked := true;
	il.AddMasked(bm, clRed);
	il.Draw(Form1.Canvas, 0, 0, 0);
	bm.Free;
	il.Free;
end;


Наверх к содержанию



Вопрос:

Как заставить TMediaPlayer проигрывать одно и тоже бесконечно? AVI например?

Ответ:
В примере AVI файл проигрывается снова и снова - используем событие MediaPlayer'а Notify

Пример:

procedure TForm1.MediaPlayer1Notify(Sender: TObject);
begin
	with MediaPlayer1 do
		if NotifyValue = nvSuccessful then
			begin
				Notify := True;
				Play;
			end;
end;


Наверх к содержанию



Вопрос:

Ответ:

Пример:

uses Printers, CommDlg;

procedure TForm1.Button1Click(Sender: TObject);
var
	cf : TChooseFont;
	lf : TLogFont;
	tf : TFont;
begin
	if PrintDialog1.Execute then
		begin
			GetObject(Form1.Canvas.Font.Handle, sizeof(lf),@lf);
			FillChar(cf, sizeof(cf), #0);
			cf.lStructSize := sizeof(cf);
			cf.hWndOwner := Form1.Handle;
			cf.hdc := Printer.Handle;
			cf.lpLogFont := @lf;
			cf.iPointSize := Form1.Canvas.Font.Size * 10;
			cf.Flags := CF_BOTH or CF_INITTOLOGFONTSTRUCT or
				CF_EFFECTS or CF_SCALABLEONLY or CF_WYSIWYG;
			cf.rgbColors := Form1.Canvas.Font.Color;
			if ChooseFont(cf) <> false then
				begin
					tf := TFont.Create;
					tf.Handle := CreateFontIndirect(lf);
					tf.COlor := cf.RgbColors;
					Form1.Canvas.Font.Assign(tf);
					tf.Free;
					Form1.Canvas.TextOut(10, 10, 'Test');
				end;
		end;
end;


Наверх к содержанию



Вопрос:

Как сменить дисковод, откуда  MediaPlayer проигрывает аудио CD?

Ответ:
См. пример.

Пример:

MediaPlayer1.FileName := 'E:';


Наверх к содержанию



Вопрос:

Как убрать кнопку с названием моей программы из Панели Задач(Taskbar)?

Ответ:

Ваш файл проекта должен выглядеть приблизительно так:

program Project1;

uses
	Windows,
	Forms,
	Unit1 in 'Unit1.pas' {Form1},
	Unit2 in 'Unit2.pas' {Form2};

{$R *.RES}

begin
	Application.Initialize;
	Application.ShowMainForm := False;
	Application.CreateForm(TForm1, Form1);
	Application.CreateForm(TForm2, Form2);
	ShowWindow(Application.Handle, SW_HIDE);
	Application.Run;
end.

В разделе "initialization" (в самом низу) каждого unit'а добавьте

begin
	ShowWindow(Application.Handle, SW_HIDE);
end.


Наверх к содержанию



Вопрос:

Как преобразовать цвета в строку - название цвета  VCL?

Ответ:

Пример: 

procedure TForm1.Button1Click(Sender: TObject);
begin
	Memo1.Lines.Add(ColorToString(clRed));
	Memo1.Lines.Add(IntToStr(StringToColor('clRed')));
end;


Наверх к содержанию



Вопрос:

При показе максимизированное формы она перекрывает task bar и не выравнивается
по верху экрана. В чем тут дело?

Ответ:
Это может произойти когда свойство position формы установленно в poScreenCenter.
Установите position = poDefault.


Наверх к содержанию



Вопрос:

Как заставить TEdit не 'пикать' при нажатии недопустимых клавиш?

Ответ:
Перехватите событие KeyPress и установите key = #0 для недопустимых клавиш.

Пример:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
	if ((UpCase(Key) < 'A') or (UpCase(Key) > 'Z')) then
		Key := #0;
end;


Наверх к содержанию



Вопрос:

Как получить число и список всех компонентов, расположенных на TNoteBook?

Ответ: 
В примере список выводится на Listbox.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
	n: integer;
	p: integer;
begin
	ListBox1.Clear;
	with Notebook1 do
	begin
		for n := 0 to ControlCount - 1 do
		begin
			with TPage(Controls[n]) do
			begin
				ListBox1.Items.Add('Notebook Page: ' +
				TPage(Notebook1.Controls[n]).Caption);
				for p := 0 to ControlCount - 1 do
				ListBox1.Items.Add(Controls[p].Name);
				ListBox1.Items.Add(EmptyStr);
			end;
		end;
	end;
end;


Наверх к содержанию



Вопрос:

Ответ:

Пример:

Buffer := Format('%s'#9'%s', [Str1, Str2]);
ShowMessage(Format('%s'#9'%s', ['Column1', 'Column2']));


Наверх к содержанию



Вопрос:

Как показать первый кадр AVI-файла?

Ответ:
См. пример. 
Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
	Application.ProcessMessages;
	MediaPlayer1.Open;
	Application.ProcessMessages;
	MediaPlayer1.Step;
	Application.ProcessMessages;
	MediaPlayer1.Previous;
end;


Наверх к содержанию



Вопрос:

Когда пользователь щелкает по listview, он переходит в режим редактирования.
Как перевисти его в редим редактирования по нажатию клавиши (например F2)?

Ответ:
Перехватите F2 на событии keydown.

Пример:

procedure TForm1.ListView1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
	if Ord(Key) = VK_F2 then
	ListView1.Selected.EditCaption;
end;


Наверх к содержанию



Вопрос:

Когда я добавляю обьект в список TStrings как мне его потом уничтожить?

Ответ:
Просто вызовите метод free этого обьекта.

Пример:

procedure TForm1.FormCreate(Sender: TObject);
var
	Icon: TIcon;
begin
	Icon := TIcon.Create;
	Icon.LoadFromFile('C:\Program Files\BorlandImages\CONSTRUC.ICO');
	ListBox1.Items.AddObject('Item 0', Icon);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
	ListBox1.Items.Objects[0].Free;
end;


Наверх к содержанию



Вопрос:

Вместо печати графики я хочу использовать резидентный шрифт принтера. Как?

Ответ:

Пример:

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
	tm : TTextMetric;
	i : integer;
begin
	if PrintDialog1.Execute then
	begin
		Printer.BeginDoc;
		Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT);
		GetTextMetrics(Printer.Canvas.Handle, tm);
		for i := 1 to 10 do
		begin
			Printer.Canvas.TextOut(100,i * tm.tmHeight +
				tm.tmExternalLeading,'Test');
		end;
		Printer.EndDoc;
	end;
end;


Наверх к содержанию



Вопрос:

Ответ:
Эту информацию можно получить из реестра.

Пример:
uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
	reg: TRegistry;
begin
	reg := TRegistry.Create;
	reg.RootKey := HKEY_LOCAL_MACHINE;
	reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\SETUP',false);
	ShowMessage(reg.ReadString('SourcePath'));
	reg.CloseKey;
	reg.free;
end;


Наверх к содержанию



Вопрос:

Как получить строку сообщения об ошибке Windows код которой получен функцией
GetLastError?

Ответ:
Функция RTL SysErrorMessage(GetLastError).

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
	{Cause a Windows system error message to be logged}
	ShowMessage(IntToStr(lStrLen(nil)));
	ShowMessage(SysErrorMessage(GetLastError));
end;


Наверх к содержанию



Вопрос:

Ответ:
См. ответ.  

Пример:

type TStrongType = type Double;
type TWeakType = Double;

procedure AddWeakType(var d : TWeakType);
begin
	d := d + 1;
end;

procedure AddStrongType(var d : TStrongType);
begin
	d := d + 1;
end;

procedure AddDoubleType(var d : Double);
begin
	d := d + 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
	d : Double;
	s : TStrongType;
	w : TWeakType;
begin
	AddDoubleType(d); {compiles fine}
	AddDoubleType(w); {compiles fine}
	AddDoubleType(s); {<- compile error}
	AddDoubleType(double(s)); {compiles fine}
	AddWeakType(d); {compiles fine}
	AddWeakType(w); {compiles fine}
	AddWeakType(s); {<- compile error}
	AddWeakType(TWeakType(s)); {compiles fine}
	AddStrongType(d); {<- compile error}
	AddStrongType(TStrongType(d)); {compiles fine}
	AddStrongType(w); {<- compile error}
	AddStrongType(TStrongType(w)); {compiles fine}
	AddStrongType(s); {compiles fine}
end;


Наверх к содержанию



Вопрос:

Где в Delphi обьявленны VK_Key для A-Z и 0-9?

Ответ:
Они не обьявлены в Delphi поскольку они просто могуть быть заменены буквами.
VK_0 до VK_9 то же что и  ASCII '0' до '9' ($30 - $39),
VK_A до VK_Z то же что и  ASCII 'A' до 'Z' ($41 - $5A).


Наверх к содержанию



Вопрос:
 
Как изменить оконную процедуру для TForm?

Ответ:

Пример:

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;


Наверх к содержанию



Вопрос:

Как узнать размеры TComboBox с показанным выпадающим списком до показа списка?

Ответ:

Пример:

var
	R : TRect;
procedure TForm1.FormShow(Sender: TObject);
var
	T : TPoint;
begin
	SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 1, 0);
	SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 0, 0);
	SendMessage(ComboBox1.Handle, CB_GETDROPPEDCONTROLRECT, 0, LongInt(@r));
	t := ScreenToClient(Point(r.Left, r.Top));
	r.Left := t.x;
	r.Top := t.y;
	t := ScreenToClient(Point(r.Right, r.Bottom));
	r.Right := t.x;
	r.Bottom := t.y;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
	Form1.Canvas.Rectangle(r.Left, r.Top, r.Right, r.Bottom );
end;


Наверх к содержанию



Вопрос:

Я хочу создать в своей программе меню "а ля Дельфи 4". Как это сделать?

Ответ:
1. Разместите на форме TControlBar. (закладка Additional) Установите Align = Client. 
2. Разместите TToolBar (закладка Win32) внутри TControlBar.
3. Установите в True свойства Flat и ShowCaptions этого TToolBar.
4. Создайте на TToolBar столько TToolButtons сколько Вам нужно. (щелкнув по TToolBar
	правой кнопкой и выбрав NewButton)
5. Установите свойство Grouped = True для всех TToolButtons. Это позволит меню выпадать
	при перемещении курсора между главными пунктами меню (если меню уже показано).
6. Разместите на фоме TMainMenu и убедитесь, что оно *НЕ присоденено* как меню главной
	формы. (посмотрите свойство Menu формы).
7. Создайте все пункты меню (щелкнув по TMainMenu кнопкой и выбрав Menu Designer)
8. Для каждой TToolButton установите ее MenuItem равным соответсвующему пункту TMainMenu.


Наверх к содержанию



Вопрос:

Как добится того чтобы TMemo и TEdit имели работали не только в режиме вставки символов,
но и в режиме замены?

Ответ:

Пример:

type
	TForm1 = class(TForm)
		Memo1: TMemo;
		procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
		procedure Memo1KeyPress(Sender: TObject; var Key: Char);
private
	{Private declarations}
		InsertOn : bool;
public
	{Public declarations}
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
	if (Key = VK_INSERT) and (Shift = []) then
		InsertOn := not InsertOn;
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
	if ((Memo1.SelLength = 0) and (not InsertOn)) then
		Memo1.SelLength := 1;
end;


Наверх к содержанию



Вопрос:

Как отправить сообщение сразу всем элементам управления формы?

Ответ:

Наверх к содержанию



Вопрос:

При попытке присвоить значение свойству "selected" ListBox'а вырабатывается exception
"Index is out of bounds". В чем тут дело и как присвоить значение свойству selected?

Ответ:
Свойство "selected" компонента ТListBox может быть использованно только если свойство
MultiSelect установленно в True. Если Вы работаете с ListBox'ом у которого
MultiSelect=false то используйте свойство ItemIndex.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
	ListBox1.Items.Add('1');
	ListBox1.Items.Add('2');
	{This will fail on a single selection ListBox}
//	ListBox1.Selected[1] := true;
	ListBox1.ItemIndex := 1; {This is ok}
end;


Наверх к содержанию



Вопрос:

Как ограничить длинну текста, вводимого в TEdit, так чтобы ширина текста не превышала
ширину TEdit'а?

Ответ:

Пример:

procedure TForm1.FormCreate(Sender: TObject);
var
	cRect : TRect;
	bm : TBitmap;
	s : string;
begin
	Windows.GetClientRect(Edit1.Handle, cRect);
	bm := TBitmap.Create;
	bm.Width := cRect.Right;
	bm.Height := cRect.Bottom;
	bm.Canvas.Font := Edit1.Font;
	s := 'W';
	while bm.Canvas.TextWidth(s) < CRect.Right do
	s := s + 'W';
	if length(s) > 1 then
	begin
		Delete(s, 1, 1);
		Edit1.MaxLength := Length(s);
	end;
end;

{Другой вариант}

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var
	cRect : TRect;
	bm : TBitmap;
begin
	if ((Ord(Key) <> VK_TAB) and (Ord(Key) <> VK_RETURN) and
		(Ord(Key) <> VK_LEFT) and (Ord(Key) <> VK_BACK)) then
	begin
		Windows.GetClientRect(Edit1.Handle, cRect);
		bm := TBitmap.Create;
		bm.Width := cRect.Right;
		bm.Height := cRect.Bottom;
		bm.Canvas.Font := Edit1.Font;
		if bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then
		begin
			Key := #0;
			MessageBeep(-1);
		end;
		bm.Free;
	end;
end;


Наверх к содержанию



Вопрос:

Как сохранить обьект TFont в реестре/ini/файле/таблице базы данных?

Ответ:

Uses    ... Registry;

procedure SaveFontToRegistry(Font : TFont; SubKey : String);
Var
	R : TRegistry;
	FontStyleInt : byte;
	FS : TFontStyles;
begin
	R:=TRegistry.Create;
	try
		FS:=Font.Style;
		Move(FS,FontStyleInt,1);
		R.OpenKey(SubKey,True);
		R.WriteString('Font Name',Font.Name);
		R.WriteInteger('Color',Font.Color);
		R.WriteInteger('CharSet',Font.Charset);
		R.WriteInteger('Size',Font.Size);
		R.WriteInteger('Style',FontStyleInt);
	finally
		R.Free;
	end;
end;

function ReadFontFromRegistry(Font : TFont; SubKey : String) : boolean;
Var
	R : TRegistry;
	FontStyleInt : byte;
	FS : TFontStyles;
begin
	R:=TRegistry.Create;
	try
		result:=R.OpenKey(SubKey,false); if not result then exit;
		Font.Name:=R.ReadString('Font Name');
		Font.Color:=R.ReadInteger('Color');
		Font.Charset:=R.ReadInteger('CharSet');
		Font.Size:=R.ReadInteger('Size');
		FontStyleInt:=R.ReadInteger('Style');
		Move(FontStyleInt,FS,1);
		Font.Style:=FS;
	finally
		R.Free;
	end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
	If FontDialog1.Execute then
	begin
		SaveFontToRegistry(FontDialog1.Font,'Delphi Kingdom\Fonts');
	end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
	NFont : TFont;
begin
	NFont:=TFont.Create;
	if ReadFontFromRegistry(NFont,'Delphi Kingdom\Fonts') then
	begin //здесь добавить проверку - существует ли шрифт
		Label1.Font.Assign(NFont);
		NFont.Free;
	end;
end;


Наверх к содержанию



Вопрос:

  Как перемещать компонент мышкой во время работы программы "runtime"?

Ответ:

Пример:

type
	TForm1 = class(TForm)
		Button1: TButton;
		procedure Button1MouseDown(Sender: TObject; Button: TMouseButton;
				Shift: TShiftState; X, Y: Integer);
		procedure Button1MouseMove(Sender: TObject; Shift: TShiftState; X,
				Y: Integer);
		procedure Button1MouseUp(Sender: TObject; Button: 
				TMouseButton; Shift: TShiftState; X, Y: Integer);
	private
		{Private declarations}
	public
		{Public declarations}
		MouseDownSpot : TPoint;
		Capturing : bool;
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton;
					Shift: TShiftState; X, Y: Integer);
begin
	if ssCtrl in Shift then
	begin 
		SetCapture(Button1.Handle);
		Capturing := true;
		MouseDownSpot.X := x;
		MouseDownSpot.Y := Y;
	end;
end;

procedure TForm1.Button1MouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);
begin
	if Capturing then
	begin
		Button1.Left := Button1.Left - (MouseDownSpot.x - x);
		Button1.Top := Button1.Top - (MouseDownSpot.y - y);
	end;
end;

procedure TForm1.Button1MouseUp(Sender: TObject; Button:
			TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
	if Capturing then
	begin
		ReleaseCapture;
		Capturing := false;
		Button1.Left := Button1.Left - (MouseDownSpot.x - x);
		Button1.Top := Button1.Top - (MouseDownSpot.y - y);
	end;
end;


Наверх к содержанию



Вопрос:

При попытке создать обьект класса TPrinter (TPrinter.Create) я получаю exception.
Почему?

Ответ:
В создании обьекта класса TPrinter с использованием TPrinter.Create нет необходимости,
так как обьект класса TPrinter (называемый Printer) автоматически создается при
использовании модуля Printers.

Пример:

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
begin
	Printer.BeginDoc;
	Printer.Canvas.TextOut(100, 100, 'Hello World!');
	Printer.EndDoc;
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.


Наверх к содержанию



Вопрос:

При попытке использовать метод TCanvas.StretchDraw чтобы нарисовать иконку
увеличенной ее размер не изменяется. Что делать?

Ответ: 
Иконки всегда рисуются размером принятым в системе по умолчанию. Чтобы показать
увеличенный вид иконки скоприуйте ее на bitmap, а зате используйте метод
TCanvas.StretchDraw.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
	TheBitmap : TBitmap;
begin
	TheBitmap := TBitmap.Create;
	TheBitmap.Width := Application.Icon.Width;
	TheBitmap.Height := Application.Icon.Height;
	TheBitmap.Canvas.Draw(0, 0, Application.Icon);
	Form1.Canvas.StretchDraw(Rect(0,0,TheBitmap.Width * 3,TheBitmap.Height * 3),
		   TheBitmap);
	TheBitmap.Free;
end;


Наверх к содержанию



Вопрос:

Можно ли сделать так чтобы TStringGrid автоматически изменял ширину колонок, чтобы
вместить самую длинную строчку в колонке?

Ответ:
См. пример.

Пример:

procedure AutoSizeGridColumn(Grid : TStringGrid; column : integer);
var
	i : integer;
	temp : integer;
	max : integer;
begin
	max := 0;
	for i := 0 to (Grid.RowCount - 1) do
	begin
		temp := Grid.Canvas.TextWidth(grid.cells[column, i]);
		if temp > max then max := temp;
	end;
	Grid.ColWidths[column] := Max + Grid.GridLineWidth + 3;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
	AutoSizeGridColumn(StringGrid1, 1);
end;


Наверх к содержанию



Вопрос:

TTimer работает не достаточно точно. Как получить более высокую точность?

Ответ:

Наверх к содержанию



Вопрос:

Как поместить JPEG-картинку в exe-файл и потом загрузить ее?

Ответ:
1) Создайте текстовый файл с расширением ".rc". Имя этого файла должно отличаться
от имени файла-пректа или любого модуля проекта.
Файл должен содержать строку вроде: MYJPEG JPEG C:\DownLoad\MY.JPG
где:
"MYJPEG" имя ресурса
"JPEG" пользовательский тип ресурса
"C:\DownLoad\MY.JPG" руть к  JPEG файлу.

Пусть например rc-файл называется "foo.rc"

Запустите BRCC32.exe (Borland Resource CommandLine Compiler) - программа находится
в каталоге Bin Delphi/C++ Builder'а - передав ей в качестве параметра полный путь
к rc-файлу.
В нашем примере:

C:\DelphiPath\BIN\BRCC32.EXE  C:\ProjectPath\FOO.RC
Вы получите откомпилированный ресурс - файл с расширением ".res".
(в нашем случает foo.res).
Далее добавте ресурс к своему приложению.

{Грузим ресурс}
{$R FOO.RES}

uses Jpeg;

procedure LoadJPEGFromRes(TheJPEG : string; ThePicture : TPicture);
var
	ResHandle : THandle;
	MemHandle : THandle;
	MemStream : TMemoryStream;
	ResPtr    : PByte;
	ResSize   : Longint;
	JPEGImage : TJPEGImage;
begin
	ResHandle := FindResource(hInstance, PChar(TheJPEG), 'JPEG');
	MemHandle := LoadResource(hInstance, ResHandle);
	ResPtr    := LockResource(MemHandle);
	MemStream := TMemoryStream.Create;
	JPEGImage := TJPEGImage.Create;
	ResSize := SizeOfResource(hInstance, ResHandle);
	MemStream.SetSize(ResSize);
	MemStream.Write(ResPtr^, ResSize);
	FreeResource(MemHandle);
	MemStream.Seek(0, 0);
	JPEGImage.LoadFromStream(MemStream);
	ThePicture.Assign(JPEGImage);
	JPEGImage.Free;
	MemStream.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
	LoadJPEGFromRes('MYJPEG', Image1.Picture);
end;


Наверх к содержанию



Вопрос:

Как перехватить сообщения прокрутки в TScrollBox?

Ответ:
Следующий пример перехватывает сообщения о прокрутке компонента TScrollBox и
синхронизирует обе линейки прокрутки. Сообщения прокрутки перехватываются с помощью
переопределения окнной процедуры (WinProc) ScrollBox'а.

Пример:

type
{$IFDEF WIN32}
	WParameter = LongInt;
{$ELSE}
	WParameter = Word;
{$ENDIF}
	LParameter = LongInt;

{Declare a variable to hold the window procedure we are replacing}
var
	OldWindowProc : Pointer;

function NewWindowProc(WindowHandle : hWnd;
	TheMessage   : WParameter;
	ParamW : WParameter;
	ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
var
	TheRangeMin : integer;
	TheRangeMax : integer;
	TheRange : integer;
begin
	if TheMessage = WM_VSCROLL then
	begin
		{Get the min and max range of the horizontal scroll box}
		GetScrollRange(WindowHandle, SB_HORZ, TheRangeMin, TheRangeMax);
		{Get the vertical scroll box position}
		TheRange := GetScrollPos(WindowHandle, SB_VERT);
		{Make sure we wont exceed the range}
		if TheRange < TheRangeMin then
		TheRange := TheRangeMin else
		if TheRange > TheRangeMax then
		TheRange := TheRangeMax;
		{Set the horizontal scroll bar}
		SetScrollPos(WindowHandle, SB_HORZ, TheRange, true);
	end;
	if TheMessage = WM_HSCROLL then
	begin
		{Get the min and max range of the horizontal scroll box}
		GetScrollRange(WindowHandle, SB_VERT, heRangeMin, TheRangeMax);
		{Get the horizontal scroll box position}
		TheRange := GetScrollPos(WindowHandle, SB_HORZ);
		{Make sure we wont exceed the range}
		if TheRange < TheRangeMin then
			TheRange := TheRangeMin
		else
			if TheRange > TheRangeMax then
				TheRange := TheRangeMax;
			{Set the vertical scroll bar}
			SetScrollPos(WindowHandle, SB_VERT, TheRange, true);
	end;

	{Call the old Window procedure to allow processing of the message.}
	NewWindowProc := CallWindowProc(OldWindowProc, WindowHandle, TheMessage,
					ParamW, ParamL);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
	{Set the new window procedure for the control and remember 
				the old window procedure.}
	OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC,
				LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
	{Set the window procedure back to the old window procedure.}
	SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(OldWindowProc));
end;


Наверх к содержанию



Вопрос:

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

Ответ:

Пример:

type
	TForm1 = class(TForm)
		procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
				Shift: TShiftState; X, Y: Integer);
		procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
				Y: Integer);
		procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
				Shift: TShiftState; X, Y: Integer);
	private
		{Private declarations}
		Capturing : bool;
		Captured : bool;
		StartPlace : TPoint;
		EndPlace : TPoint;
	public
		{Public declarations}
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

function MakeRect(Pt1 : TPoint; Pt2 : TPoint) : TRect;
begin
	if pt1.x < pt2.x then
		begin
			Result.Left := pt1.x;
			Result.Right := pt2.x;
		end
	else
		begin
			Result.Left := pt2.x;
			Result.Right := pt1.x;
		end;
	if pt1.y < pt2.y then
		begin
			Result.Top := pt1.y;
			Result.Bottom := pt2.y;
		end
	else
	begin
		Result.Top := pt2.y;
		Result.Bottom := pt1.y;
	end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
		Shift: TShiftState; X, Y: Integer);
begin
	if Captured then
		DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
	StartPlace.x := X;
	StartPlace.y := Y;
	EndPlace.x := X;
	EndPlace.y := Y;
	DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
	Capturing := true;
	Captured := true;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
		Y: Integer);
begin
	if Capturing then
	begin
		DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
		EndPlace.x := X;
		EndPlace.y := Y;
		DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
	end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
		Shift: TShiftState; X, Y: Integer);
begin
	Capturing := false;
end;


Наверх к содержанию



Вопрос:

Можно ли использовать иконку как картинку на кнопке TSpeedButton?

Ответ:
Можно. См. пример.

Пример:

uses ShellApi;

procedure TForm1.FormShow(Sender: TObject);
var
	Icon: TIcon;
begin
	Icon := TIcon.Create;
	Icon.Handle := ExtractIcon(0,'C:\WINDOWS\NOTEPAD.EXE',1);
	SpeedButton1.Glyph.Width := Icon.Width;
	SpeedButton1.Glyph.Height := Icon.Height;
	SpeedButton1.Glyph.Canvas.Draw(0, 0, Icon);
	Icon.Free;
end;


Наверх к содержанию



Вопрос:

Как поместить прозрачную фоновую каринку на компонент CoolBar?

Ответ:
procedure TForm1.Button1Click(Sender: TObject);
var
	Bm1 : TBitmap;
	Bm2 : TBitmap;
begin
	Bm1 := TBitmap.Create;
	Bm2 := TBitmap.Create;
	Bm1.LoadFromFile('c:\download\test.bmp');
	Bm2.Width := Bm1.Width;
	Bm2.Height := Bm1.Height;
	bm2.Canvas.Brush.Color := CoolBar1.Color;
	bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
			Rect(0, 0, Bm1.width, Bm1.Height), ClWhite);
	bm1.Free;
	CoolBar1.Bitmap.Assign(bm2);
	bm2.Free;
end;


Наверх к содержанию



Вопрос:

Ползунок компонента TScrollBar все время мигает. Как это отключить?

Ответ:
Установите свойтсво ScrollBar.TabStop в False.


Наверх к содержанию



Вопрос:

Как программно перевести DBgrid в реим редактирования и установить курсор в
окошке редактирования в требуемую позицию?

Ответ:

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
	h : THandle;
begin
	Application.ProcessMessages;
	DbGrid1.SetFocus;
	DbGrid1.EditorMode := true;
	Application.ProcessMessages;
	h:= Windows.GetFocus;
	SendMessage(h, EM_SETSEL, 2, 2);
end;


Наверх к содержанию



Вопрос:

Как поместить курсор в определенную позицию edit'а и подобных ему элементов управления?

Ответ:
Можно использовать методы Delphi SelStart() и SelectLength().

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
	Edit1.SetFocus;
	{переводим курсор во вторую позицию}
	Edit1.SelStart := 2;
	{не выделяем никакого текста}
	Edit1.SelLength := 0;
end;


Наверх к содержанию



Вопрос:

Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение
размера формы?

Ответ:
В примере перехватывается сообщение WM_SYSCOMMAND. Если это сообщение говорит о
минимизации или максимизации формы - пищит динамик.

Пример:

type
	TForm1 = class(TForm)
	private
		{Private declarations}
		procedure WMSysCommand(var Msg: TWMSysCommand);
		message WM_SYSCOMMAND;
	public
		{Public declarations}
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMSysCommand;
begin
	if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then
		MessageBeep(0)
	else
		inherited;
end;


Наверх к содержанию



Вопрос:

Можно ли сделать так - одна форма показывает другую и остается позади нее, но фокус
ввода не переходит к новой форме, а остается у старой?

Ответ:
В примере показывается не автосоздаваемая (non auto-created) форма, но фокус ввода ей
не передается.

Пример:

uses Unit2;

procedure TForm1.Button1Click(Sender: TObject);
begin
	Form2 := TForm2.Create(Application);
	Form2.Visible := FALSE;
	ShowWindow(Form2.Handle, SW_SHOWNA);
end;


Наверх к содержанию



Вопрос:

На некоторых laptop компьютерах может не быть флоппи дисковода. Можно ли удалять
из списка TDriveComboBox диски которые отключены?

Ответ:
В примере TDriveComboBox не показывает дисководы, которые не готовы. (not ready).
Учтите что на многих компьютерах будет ощутимая задержка при поверке plug&play
флоппи дисковода.

Пример:

procedure TForm1.FormCreate(Sender: TObject);
var
	i : integer;
	OldErrorMode : Word;
	OldDirectory : string;
begin
	OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
	GetDir(0, OldDirectory);
	i := 0;
	while i <= DriveComboBox1.Items.Count - 1 do begin
	{$I-}
	ChDir(DriveComboBox1.Items[i][1] + ':\');
	{$I+}
	if IoResult <> 0 then
		DriveComboBox1.Items.Delete(i)
	else
		inc(i);
	end;
	ChDir(OldDirectory);
	SetErrorMode(OldErrorMode);
end;


Наверх к содержанию



Вопрос:

Как сообщить всем формам моего приложения (в том числе и не видимым в данный момент)
об изминении каких-то глобальных значений?

Ответ:
Один из способов - создать пользовательское сообщение и использовать метод preform
чтобы разослать его всем формам из массива Screen.Forms.

Пример:

{Code for Unit1}

const
	UM_MyGlobalMessage = WM_USER + 1;

type
	TForm1 = class(TForm)
		Label1: TLabel;
		Button1: TButton;
		procedure FormShow(Sender: TObject);
		procedure Button1Click(Sender: TObject);
   private	
		{Private declarations}
		procedure UMMyGlobalMessage(var AMessage: TMessage); message
		UM_MyGlobalMessage;
	public
		{Public declarations}
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

uses Unit2;

procedure TForm1.FormShow(Sender: TObject);
begin
	Form2.Show;
end;

procedure TForm1.UMMyGlobalMessage(var AMessage: TMessage);
begin
	Label1.Left := AMessage.WParam;
	Label1.Top  := AMessage.LParam;
	Form1.Caption := 'Got It!';
end;

procedure TForm1.Button1Click(Sender: TObject);
var
	f: integer;
begin
	for f := 0 to Screen.FormCount - 1 do
	Screen.Forms[f].Perform(UM_MyGlobalMessage, 42, 42);
end;

{Code for Unit2}

const
	UM_MyGlobalMessage = WM_USER + 1;
type
	TForm2 = class(TForm)
		Label1: TLabel;
	private
		{Private declarations}
		procedure UMMyGlobalMessage(var AMessage: TMessage);
		message UM_MyGlobalMessage;
	public
		{Public declarations}
end;

var
	Form2: TForm2;

implementation

{$R *.DFM}

procedure TForm2.UMMyGlobalMessage(var AMessage: TMessage);
begin
	Label1.Left := AMessage.WParam;
	Label1.Top  := AMessage.LParam;
	Form2.Caption := 'Got It!';
end;


Наверх к содержанию



Вопрос:

Как обновить список дисков компонента TDriveComboBox, учитывая, что могуд быть
подключены/отключены сетевые диски и произведена "горячая замена" plug&play дисков?

Ответ:
Следующий пример вызывает защищенный (protected) метод класса TDriveComboBox
BuildList() для регеирации списка дисков. (использовая так наз. "class cracer")

Пример:

type
	TNewDriveComboBox = class(TDriveComboBox)  //это наш "class cracer"
end;

procedure TForm1.Button1Click(Sender: TObject);
var
	Drive : char;
begin
	Drive := DriveComboBox1.Drive;
	TNewDriveComboBox(DriveComboBox1).BuildList;  
			//вызываем защищенный метод родительского класса
	DriveComboBox1.Drive := Drive;
end;


Наверх к содержанию



Вопрос:

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

Ответ:

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
	//Allow button to finish painting in response to the click
	Application.ProcessMessages;
	{Alt Key Down}
	keybd_Event(VK_MENU, 0, 0, 0);
	{F Key Down - Drops the menu down}
	keybd_Event(ord('F'), 0, 0, 0);
	{F Key Up}
	keybd_Event(ord('F'), 0, KEYEVENTF_KEYUP, 0);
	{Alt Key Up}
	keybd_Event(VK_MENU, 0, KEYEVENTF_KEYUP, 0);
	{F Key Down}
	keybd_Event(ord('S'), 0, 0, 0);
	{F Key Up}
	keybd_Event(ord('S'), 0, KEYEVENTF_KEYUP, 0);
end;


Наверх к содержанию



Вопрос:

Как сделать клавишу-акселератор (keyboard shortcut) компонету у которого нет заголовка?

Ответ:

Пример:

procedure TForm1.FormCreate(Sender: TObject);
begin
	Label1.Visible := false;
	Label1.Caption := '&M';
	Label1.FocusControl := Memo1;
end;


Наверх к содержанию



Вопрос:

Можно ли как-то уменьшить мерцание при перерисовке компонента?

Ответ:
Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle компонента
- то фон компонента перерисовываться не будет.

Пример:

constructor TMyControl.Create;
begin
	inherited;
	ControlStyle := ControlStyle + [csOpaque];
end;


Наверх к содержанию



Вопрос:

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

Ответ:
Поместите в конструктор компонента код, устанавливающий размеры по умолчанию.
Переопределите метод SetBounds и проверяйте в нем "componentstate". Если компонет
находится режиме "design-time" (csDesigning in ComponentState) просто передавайте
значения ширины и высоты (width и heights) компонента по умолчанию (в нашем
примере 50) методу класса-предка.

Пример:

procedure TVu.SetBounds(ALeft : integer; ATop : integer; AWidth : integer;
			AHeight : integer);
begin
	if csdesigning in componentstate then
	begin
		AWidth := 50;
		AHeight := 50;
		inherited;  //вызываем унаследованный от предка метод
	end;
end;


Наверх к содержанию



Вопрос:

Можно ли уменьшить потребляемые компонентами TNotebook и TTabbedNotebook ресурсы?

Ответ:
Да. Можно уничтожать обьекты, расположенные не на текущей странице TNotebook или
TTabbedNotebook. В примере вызывается защищенный (Protected) метод путем создания
так называемый "class cracer'ов".

type TMyTabbedNotebook = class(TTabbedNotebook); //это наш "class cracer"
type TMyNotebook = class(TNotebook);

procedure TForm1.TabbedNotebook1Change(Sender: TObject; NewTab: Integer;
			var AllowChange: Boolean);
begin
	with TabbedNotebook1 do  //вызываем защищенный метод родительского класса
		TMyTabbedNotebook(TWinControl(Pages.Objects[PageIndex])).DestroyHandle;
end;

procedure TForm1.TabSet1Change(Sender: TObject; NewTab: Integer;
			var AllowChange: Boolean);
begin
	with Notebook1 do //вызываем защищенный метод родительского класса
		TMyNotebook(TWinControl(Pages.Objects[PageIndex])).DestroyHandle;
		NoteBook1.PageIndex := NewTab;
		AllowChange := true
end;


Наверх к содержанию



Вопрос:

Функция keybd_event() принимает значения до 244 - как мне отправить нажатие
клавиши с кодом #255 в элемент управления Windows?

Ответ:
Это может понадобится для иностранных языков или для специальных символов. (например,
в русских шрифтах символ с кодом #255 - я прописное). Приведенный в примере метод,
не стоит использовать в случае если символ может быть передан обычным способом
(функцией keybd_event()).
 
procedure TForm1.Button1Click(Sender: TObject);
var
	KeyData : packed record
		RepeatCount : word;
		ScanCode : byte;
		Bits : byte;
	end;
begin
	{Let the button repaint}
	Application.ProcessMessages;
	{Set the focus to the window}
	Edit1.SetFocus;
	{Send a right so the char is added to the end of the line}
	//  SimulateKeyStroke(VK_RIGHT, 0);
	keybd_event(VK_RIGHT, 0,0,0);
	{Let the app get the message}
	Application.ProcessMessages;
	FillChar(KeyData, sizeof(KeyData), #0);
	KeyData.ScanCode := 255;
	KeyData.RepeatCount := 1;
	SendMessage(Edit1.Handle, WM_KEYDOWN, 255,LongInt(KeyData));
	KeyData.Bits := KeyData.Bits or (1 shl 30);
	KeyData.Bits := KeyData.Bits or (1 shl 31);
	SendMessage(Edit1.Handle, WM_KEYUP, 255, LongInt(KeyData));
	KeyData.Bits := KeyData.Bits and not (1 shl 30);
	KeyData.Bits := KeyData.Bits and not (1 shl 31);
	SendMessage(Edit1.Handle, WM_CHAR, 255, LongInt(KeyData));
	Application.ProcessMessages;
end;


Наверх к содержанию



Вопрос:

Некоторые компоненты не меняют курсор мыши до тех пор пока пользователь не
сдвинет мышь. Как эмулировать движение мыши?

Ответ:
В примере мышка слегка "подталкивается" без участия пользователя.

procedure TForm1.Button1Click(Sender: TObject);
var
	pt : TPoint;
begin
	Application.ProcessMessages;
	Screen.Cursor := CrHourglass;
	GetCursorPos(pt);
	SetCursorPos(pt.x + 1, pt.y + 1);
	Application.ProcessMessages;
	SetCursorPos(pt.x - 1, pt.y - 1);
end;


Наверх к содержанию



Вопрос:

Как зарегистрировать расширение файла за своим приложением и контекстное меню,
связанное с этим типом?

Ответ:
Пример регистрирует расширение файла(.myext) - файлы этого типа будут открываться
приложением MyApp.Exe. Также регнстрируется одно действие (action) по умолчанию
для файлов этого типа и два дополнительных пункта контекстного меню, связанного с
этим типом файлов. Возможно, потребуется перезайти в систему чтобы изменения
вступили в силу.

Пример:

uses
	Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
	R : TRegIniFile;
begin
	R := TRegIniFile.Create('');
	with R do
		begin
			RootKey := HKEY_CLASSES_ROOT;
			WriteString('.myext','','MyExt');
			WriteString('MyExt','','Some description of MyExt files');
			WriteString('MyExt\DefaultIcon','','C:\MyApp.Exe,0');
			WriteString('MyExt\Shell','','This_Is_Our_Default_Action');
			WriteString('MyExt\Shell\First_Action',
						'','This is our first action');
			WriteString('MyExt\Shell\First_Action\command','',
						'C:\MyApp.Exe /LotsOfParamaters %1');
			WriteString('MyExt\Shell\This_Is_Our_Default_Action','',
						'This is our default action');
			WriteString('MyExt\Shell\This_Is_Our_Default_Action\command',
						'','C:\MyApp.Exe %1');
			WriteString('MyExt\Shell\Second_Action',
						'','This is our second action');
			WriteString('MyExt\Shell\Second_Action\command',
						'','C:\MyApp.Exe /TonsOfParameters %1');
			Free;
		end;
end;


Наверх к содержанию