DELPHI VCL FAQ





Вопрос:

Как разместить прозрачную надпись на 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; Наверх к содержанию
Вопрос: Как использовать анимированный курсор? Ответ:
Во первых необходимо получит handle курсора, а затем определить его в массиве курсоров компонента TScreen. Индексы предопределенных курсоров системы отрицательны, пользователь может определить курсор, индекс которого положителен.
Пример:

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. Наверх к содержанию
Вопрос: Как определить наличие сопроцессора? Ответ:
В отличие от общепринятого мнения не всее клоны 486/586/686/ и Pentium имеют сопроцессор для вычислений с плавающей запятой. В примере определяется наличие сопроцессора и под Win16 и под Win32.
Пример:

{$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? Ответ:
CD может иметь или не иметь серийный номер и/или универсальный код продукта (Universal Product Code). MCI-расширение Windows предоставляет эту информации с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает уникальную ID-строку.
Пример:

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) текст, содержащий амперсанд - & ? Ответ:
Используя два амперсанда подряд. Windows интерпритирует одиночный амперсанд как указание на то, что следующий символ - горячая клавиша (и поддчеркивает следующий символ вместо излбражения аперсанда).
Пример:

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? Ответ:
В приведенном примере отслеживается движение курсора мыши - при перемещении между ячейками StringGrid'а - появляется окно подсказки(hint), показываеющее номер текущей строки и колонки.
Пример:

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? Ответ:
Примечание: внесение изменений в VCL не поддерживается Borland или Borland Developer Support.
-Но если Вы решили сделать это...
Изменеия в код VCL никогда не должны вносится в секцию "interface" модуля - только в секцию "implimentation". Наиболее безопасный способ внести изменения в VCL - создать новый каталог названный "исправленный VCL". Скопируйте файл VCL который Вы хотите изменить в этот каталог. Внесите изменения (лучше прокомментировать их) в этот файл. Затем добавьте путь к Вашему каталогу "исправленный VCL" в самое начало "library path". Перезапустите Delphi/C++ Builder и перекомпилируйте Ваш проект. "library path" можно изменить в меню:

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? Ответ:
Считайте файл в TMemoryStream, затем ипользуйте метод TMemo SetSelTextBuf() для вставки текста;

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;


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


Вопрос:
Как в компоненте TMemo перехватить нажатие Ctrl-V и вставить специальный текст не из буфера обмена (clipboard)?
Ответ:
См. пример.

Пример:

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;


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


Вопрос:
Как создать эквивалент TEdit но только с выравниваением вводимого текста по центру или по правой стороне?
Ответ:
TEdit не поддерживает выравниваение текста по центру и по правой стороне - лучше использовать компонент TMemo. Вам понадобится запретить пользователю нажимать Enter, Ctrl-Enter и всевозможные комбинации клавиш со стрелками, чтобы избежать появления нескольких сторк в Memo. Этого можно добиться и просматривая содержимое текста в TMemo в поисках кода возврата каретки (13) и перевода строки(10) на событиях TMemo Change и KeyPress. Можно также заменять код возврата каретки на пробел - для того чтобы позволять вставку из буфера обмена многострочного текста в виде одной строки.
Пример:

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 он (шрифт) не меняется? Ответ:
Status bar (строка состояния) - стандартный элемент управления Windows и цвет его шрифта задается через Control Panel (константа clBtnText). Этот цвет по умолчанию черный и может меняться при выборе пользователем той или иной цветовой схемы. У компонента ТStatusBar и его панелей есть возможность "owner-draw" - программной перерисовки, которая позволяет выводить на панель текст любого цвета. Измените свойство Style компонента TStatusBar.Panels на OwnerDraw.
Пример:

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;


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


Вопрос:
Как бы мне создать эдакий trackbar в котором вместо широкой белой полоски с ползунком была бы тонкая линия?
Ответ:
В примере создается компонент, унаследованный от TTrackbar который переопределяет метод CreateParams и убират флаг TBS_ENABLESELRANGE из Style. Константа TBS_ENABLESELRANGE обьявленна в модуле CommCtrl.
Пример:

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;


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


Вопрос:
Мне нужен временный canvas, но когда я пытаюсь его создать получаю сообщения об ошибках. Как создать TCanvas?
Ответ:
Создайте Bitmap и используйте свойство canvas класса TBitmap. Пример создает Bitmap, рисует на его canvas'е, выводит этот canvas на форму и освобождает bitmap.
Пример:

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;


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


Вопрос:
В некоторых видео режимах прозрачная часть glyph'а стандартного TBitBtn становится видной. Как этого избежать?
Ответ:
В примере используется техника закраски прозрачной части glyph'а цветом кнопки на которой он находится - таким образом glyph кажется прозрачным.
Пример:

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 используя массив точек? Ответ:
Polygon - метод компонента TCanvas получает в качестве параметра динамический массив точек. Функция PolyPolygon() из Windows GDI получает указатель на массив точек.
Пример:

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;


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


Вопрос:
Как создать невизуальный компонент без иконоки, которая изображается в палитре компонентов в "design-time" (вроде TField)?
Ответ:
Невизуальные компоненты без иконоки удобны для субкомпонентов, связанных с какими-то другими компонентами. Создайте компонент как обычно, но используйте RegisterNoIcon вместо RegisterComponent.

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


Вопрос:
Как показывать нестандартный встроенный редактор (inplace editor) в ячейке stringgrid (например combobox).
Ответ:
См. пример

Пример:

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? Ответ:
Можно использовать функцию Windows API GetDriveType() чтобы определить является ли дисковод CD-ROM'мом. И функцию API GetVolumeInformation() чтобы проверить VolumeName на равенство '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". Наверх к содержанию
Вопрос:
События KeyPress и KeyDown не вызываются для клавиши Tab - как определить, что она была нажата?
Ответ:
На уровне формы клавиша tab обычно обрабатывается Windows. В примере создается обработчик события CM_Dialog для перехвата Dialog keys.
Пример:

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)? Ответ:
Self может быть использовано только в методе класса, и ссылается на текущий экземпляр класса. Таким образом "Self" в методе класса TForm1 ссылается на текущий экземпляр TForm1. При создании компонента Вы передаете его владельца (owner) в конструктор. При уничтожении формы или компонента автоматически уничтожаются и все компоненты владельцем которого она является. Таким образом если при создании формы передать в качестве владельца Application эта форма будет автоматически уничтожена при уничтожении 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;
Событие OnIdle возникает один раз - когда приложение переходит в режим "безделья" (idle). Если в обработчике переменной Done присвоить False событие будет вызываться вновь и вновь, до тех пор пока приложение "бездельничает" и переменной Done не присвоенно значение True.
Наверх к содержанию


Вопрос:
При перемещении фокуса ввода клавишей Tab чтобы переместить его в RadioGroup нужно нажать клавишу Tab дважды если какой нибудь пункт RadioGroup уже выбран, но только один раз если не выбран. Можно ли сделать поведение RadioGroup логичным?
Ответ:
Установка свойства RadioGroup'ы TabStop в false должна решить эту проблему - поскольку клавиша tab будет продолжать работать - перемещаясь сразу на выделенный пункт RadioGroup.

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


Вопрос: Как разместить маленькие картинки в компоненте TPopUpMenu? Ответ:
В приведенном примере показано как это сделать с использованием функции Windows API SetMenuItemBitmaps(). Эта функция получает handle popup menu, позицию строчки меню куда будет помещена картинка, и два дескриптора(handles) на две картинки (одна из них - картинка которая будет показана когда строка меню доступна, вторая - когда строка меню недоступна).

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

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 в какой-либо момент времени? Ответ:
В приведенном примере показано как определить нажата ли клавиша Shift при выборе строчки меню. Пример также содержит функции проверки состояния клавиш Alt, 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'а? Ответ:
Ниже приведена процедура, позволяющаю отправлять нажатия в любой элемент управления (window control), способный принимать ввод с клавиатуры. Вы можете использовать эту технику чтобы включать клавиши NumLock, CapsLock и ScrollLock под Windows NT. Та же техника работает и под Windows 95 для CapsLock и ScrollLock но не работает для клавиши NumLock.
Обратите внимание, что приведены четыре поцедуры: SimulateKeyDown() - эмулировать нажатие клавиши (без отпускания) SimulateKeyUp() - эмулировать отпускание клавиши SimulateKeystroke() - эмулировать удар по клавише (нажатие и отпускание) и SendKeys(), позволяющие Вам гибко контролировать посылаемые сообщения клавиатуры.
SimulateKeyDown(), SimulateKeyUp() и SimulateKeystroke() получают коды виртуальных клавиш (virtural key) (вроде VK_F1). Процедура SimulateKeystroke() получает дополнительный параметр, полезный при эмуляции нажатия PrintScreen. Когда этот параметр равен нулю весь экран будет скопирован в буфер обмена (clipboard). Если дополнительный параметр равен 1 будет скопированно только активное окно.
Четыре метода "button click" демонстрируют использование: ButtonClick1 - включает capslock ButtonClick2 - перехватывает весь экран в буфер обмена (clipboard). ButtonClick3 - перехватывает активное окно в буфер обмена (clipboard). ButtonClick4 - устанавливает фокус в Edit и отправляет в него строку.
Пример:

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; Наверх к содержанию
Вопрос:
При выполнении диалога FontDialog со свойством Device равным fdBoth or fdPrinter, появляется ошибка "There are no fonts installed".
Ответ:
Эти установки должны показать шрифты совместимые либо с принтером либо с экраном. В примере диалог Windows ChooseFont вызывается напрямую чтобы показать список шрифтов, совместимых одновременно и с экраном и с принтером.
Пример:

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)? Ответ:
Отредактируйте файл-проекта (View -> Project Source) Добавьте модуль Windows в раздел uses. Application.ShowMainForm := False; в строку после "Application.Initialize;". Добавьте ShowWindow(Application.Handle, SW_HIDE); в строку перед "Application.Run;"

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

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? Ответ:
Модуль graphics.pas содержит функцию ColorToString() которое преобразует допустимое значение TColor в его строковое представление используя либо константу-название цвета (по возможности) либо шестнадцатиричную строку. Обратная функция - StringToColor()
Пример: 

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; Наверх к содержанию
Вопрос:
Я хочу вставить escape code в строку при использовании функции Format(). Например, я хочу создать строку, содержащую символ табуляции. В "C" я бы написал что-то вроде sprintf(buffer, "%s\t%s", str);. А как это будет на Pascal'e?
Ответ:
Функция Format Pascal'я не использует escape codes. Вместо этого нужно вставить в строку действительное значение символа в кодировке ASCII.
Пример:

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; Наверх к содержанию
Вопрос: Вместо печати графики я хочу использовать резидентный шрифт принтера. Как? Ответ:
Используте функцию Windows API - GetStockObject() чтобы получить дескриптор (handle) шрифта по умолчанию устройства (DEVICE_DEFAULT_FONT) и передайте его Printer.Font.Handle.
Пример:

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;


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


Вопрос:
Мне нужно программно установить некоторые файлы с установочного диска Windows. На многих компьютерах CAB-файлы установки Windows находятся в каком-то каталоге на жестком диске, на других - Windows был установлен с CD. Как узнать откуда была установленна Windows?
Ответ:
Эту информацию можно получить из реестра.

Пример:
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; Наверх к содержанию
Вопрос:
Как заставить Delphi выполнять еще более строгую проверка типов? Напрмер - я создаю пользовательский тип, унаследованный от double и могу передавать его любым функциям, принимающим параметр типа double. Как заставить компилятор проводить более строгую проверку типов и выдавать предупреждение в таких случаях?
Ответ:
См. ответ.  

Пример:

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

type
	TForm1 = class(TForm)
		Button1: TButton;
		procedure WndProc (var Message: TMessage); override;
		procedure Button1Click(Sender: TObject);
	private
		{Private declarations}
	public
		{Public declarations}
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WndProc (var Message: TMessage);
begin
	if Message.Msg = WM_CANCELMODE then
		begin
			Form1.Caption := 'A dialog or message box has popped up';
		end
	else
		inherited  // <- остальное сделает родительская процедура
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
	ShowMessage('Test Message');
end;


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


Вопрос: Как узнать размеры TComboBox с показанным выпадающим списком до показа списка? Ответ:
На событии FormShow пошлите сообщение CB_SHOWDROPDOWN в ComboBox дважды - один раз чтобы заставить список выпасть, второй - чтобы убрать его. Затем пошлите сообщение CB_GETDROPPEDCONTROLRECT, передав в качестве параметра адрес TRect. TRect будет содержать экранные кординаты прямоугольника описывающего ComboBox вместе с выпавшим списком. Затем Вы можете вызвать ScreenToClient чтобы преобразовать экранные кординаты в координаты клиентской области окна.
Пример:

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 имели работали не только в режиме вставки символов, но и в режиме замены? Ответ:
Элементы управления Windows TEdit и TMemo не имеют режима замены. Однако этот режим можно эмулировать установив свойство SelLength edit'а или memo в 1 при обработке события KeyPress. Это заставит его перезаписывать символ в текущей позиции курсора. В примере этот способ используется для TMemo. Режим вставка/замена переключается клавишей "Insert".
Пример:

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;


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


Вопрос: Как отправить сообщение сразу всем элементам управления формы? Ответ:
Можно использовать Screen.Forms[i].BroadCast(msg); где [i] - индекс той формы, которой Вы хотите переслать сообщение. BroadCast работает со всеми компонентами, потомками TWinControls и отправляет сообщение всем дочерним компонентам из массива Controls. Если один из дочерних компонентов обрабатывает это сообщение и устанавливает Msg.Result в ненулевое значение - дальнейшая рассылка сообщения останавливается.

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


Вопрос: При попытке присвоить значение свойству "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'а? Ответ:
В примере приведено два способа ограничить длинну текста в TEdit так чтобы она не превышала ширину клиентской области окна TEdit'а и не появлялась прокрутка текста. Первый способ устанавливает свойство TEdit'а MaxLength равным числу букв "W", которые поместятся в TEdit. "W" выбрана потому, что является, наверное, самой широкой буквой в любом шрифте. Этот метод сносно работает для шрифтов с фиксированной шириной букв, но для шрифтов с переменной шириной букв вряд ли сгодится. Второй способ перхватывает событие KeyPress TEdit'а и измеряет ширину уже введенного текста и ширину нового символа. Если ширина больше чем клиентская область TEdit'а новый символ отбрасывается и вызывается MessageBeep.
Пример:

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/файле/таблице базы данных? Ответ:
Нужно сохранять атрибуты шрифта (имя, размер и т.п.) а не сам обьект TFont. После считывания этой информации следует проверить существует ли такой шрифт, прежде чем его использовать. Чтобы не показаться голословным дополню ответ Borland'а своим примером сохранения/чтения шрифта в/из реестра

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"? Ответ:
Перехватить событие OnMouseDown, запомнить x и y координты курсора мыши. Отслеживать движение мыши по событию OnMouseMove и перемещать компонент вслед за курсором мыши до тех пор пока не произойдет событие OnMouseUp. В примере показано перемещение компонента TButton. Перемещение начинается, когда пользователь "берет" TButton мышью, удерживая нажатой клавишу "Сontrol".
Пример:

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 работает не достаточно точно. Как получить более высокую точность? Ответ:
Таймер Windows не был создан с целью получения сверхточного хронометра. :-( Другими словами, когда Вы устанавливаете таймер на срабатывания каждые 1000 миллисекунд, он может срабатывать через интервал несколько больший чем 1000 миллисекунд. Значения меньше 55 миллисекунд никогда не будут срабатывать вовремя в Windows, поскольку это минимальная точность таймера. Можно проверять системное время и сравнивать его со временем предыдущего события таймера чтобы повысить точность.

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


Вопрос: Как поместить 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; Наверх к содержанию
Вопрос: Как сделать прямоугольник для выделения части картинки для редактирования? Ответ:
Самый простой способ - воспользоваться функцией Windows API DrawFocusRect. Функция DrawFocusRect использует операцию XOR при рисовании - таким образом вывод прямоугольника дважды с одними и теми же координатами стирает прямоугольник, и прямоугольник всегда будет виден, на фоне какого бы цвета он не выводился.
Пример:

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 в реим редактирования и установить курсор в окошке редактирования в требуемую позицию? Ответ:
Переведите таблицу в режим редактирования, затем получите дескриптор (handle) окна редактирования и перешлите ей сообщение EM_SETSEL. В качестве параметров вы должны переслать начальную позицию курсора, и конечную позицию, определяющую конец выделения текста цветом. В приведенном примере курсор помещается во вторую позицию, текст внутри ячейки не выделяется.
Пример:

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; Наверх к содержанию
Вопрос: Как программно заставить выпасть меню? Ответ:
В примере показано как показать меню и выбрать в нем какой-то пункт, эмулируя нажатие "быстрой кдавиши" пункта меню. Если у Вашего пункта меню нет "быстрой клавиши" Вы можете посылать комбинации VK_MENU, VK_LEFT, VK_DOWN, и VK_RETURN, чтобы программно "путешествовать" по меню.
Пример:

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) компонету у которого нет заголовка? Ответ:
Возможный вариант - присвоить ссылку на этот компонент свойству FocusControl TLabel'а. В примере используется невидимый Label для создания "быстрой" клавиши (Alt+M) компонента Memo. Чтобы использовать пример, разместите на форме компонет TMemo, Label и несколько других компонентов, которые могут принимать фокус ввода. Запустите программу, перевидите фокус ввода куда-нибудь вне Memo и нажмите Alt+M - фокус ввода вернется в Memo.
Пример:

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; Наверх к содержанию