Эльчин Азиз Али оглы Азизов
дата публикации 16-11-1999 00:00

---

Версия для печати

Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи.

Прозрачная надпись на  TBitmap.
Доступ к колонке-строке grid'а по заголовку.
Использование клавиши-акселератора в TTabsheets.
Доступ к HKEY_LOCAL_MACHINE под NT без прав администратора.
Изменение числа колонок и их ширины в TFileListBox.
Настройка табуляции в компоненте TMemo.
Перехват нажатия функциональных клавиш и стрелок.
Мерцание на DrawCell.
Bitmap и текст на TBitBtn.
Изменение вида текстового курсора.
Ошибка компиляции при вызове метода abort.
Цвет букв в стандартных элементах управления Windows.
Надпись на компоненте TBitBtn с переносом слов.
Изменение стилей шрифта RichEdit нажатиями комбинаций клавиш.
Изменение корневого ключа (root key) реестра.
Динамическое изменения свойства owner компонента в 'runtime'.
Очистка содержимого Canvas'а.
Динамическое измененение главной формы приложения в 'runtime' .
Программный 'Click' по 'speed button'.
Доступ к элементам компонента TRadioGroup.
Почему функции рисования Delphi рисуют на один пиксел короче.
Как показать подсказки (hints) для элементов меню.
Как выяснить состояние списка Combobox.
Как удалить каталог вместе с содержимым.
Програмное отключение системного меню формы.
Выделение RGB компонентов цвета.
Номер текущей строки в TMemo.
Как проигрывать MPEG файл.
Использование анимированного курсора.
Как узнать о нажатии клавиши в момент когда показано меню .
Как определить наличие сопроцессора.
Серийный номер аудио CD.
Амперсанд в Windows .
Как поместить bitmap в Metafile.
Как узнать, что курсор мыши над моей формой.
Запущенно ли приложение под Windows NT.
Как создать bitmap из пиктогрммы (icon).
Отедельный hint для каждой ячейки StringGrid'а.
Как внести изменения в код VCL.
Эквивалент TwipsPerPixel из VB.
Содержимое файла в текущую позицию курсора в TMemo.
Перехват нажатия Ctrl-V в TMemo.
TEdit с выравниваением текста по правой стороне.
Undo в Edit.
Переопределение конструктора формы.
Цветной текст в TStatusBar.
Переделываем TTrackBar.
Создание временного canvas'а.
Проблема с прозраным glyph'ом.
Создание PolyPolygon используя массив точек.
Создание невизуальных компонентов без иконок.
Нестандартный редактор (например combobox) в ячейке StringGrid .
Есть ли в CD-ROM Audio CD.
Есть ли у мыши колесико.
Определение нажатия клавиши tab.
Отличие между Create(Self) и Create(Application).
Определение поддерживает ли обьект заданное свойство.
Показываем секунды и минуты Audio CD.
Рисуем на рамке.
Работаем когда приложение бездельничает.
Radiogroup и фокус ввода.
Картинки в TPopUpMenu.
Как узнать число кадров AVI файла.
Фиксированные колонки в TDbGrid.
Показ dbgrid в режиме disabled.
Как узнать нажаты ли клавиши Shift, Ctrl, Alt .
Как изменить шрифт подсказки (hint'а).
Эквивалент функции SendKeys Visual Basic'а.
Динамическое рисование прозрачных картинок TImageList.
Бесконечная музыка из TMediaPlayer.
Ошибка 'There are no fonts installed'.
Смена дисковода, откуда MediaPlayer проигрывает аудио CD.
Как убрать кнопку с названием моей программы из Панели Задач.
Преобразование цвета в строку - название цвета VCL .
Выравнивание максимизированное формы.
Как заставить TEdit не 'пикать'.
Получение списка всех компонентов, расположенных на TNoteBook.
Эквивалент escape codes из С.
Как показать первый кадр AVI-файла.
Переключить TListView в режим редактирования нажатием клавиш.
Уничтожение обьекта, сохраненного в списке TStrings.
Using Resident Font.
Путь к каталогу откуда была установленна Windows.
Строка сообщения об ошибке Windows.
Еще более строгая проверка типов.
VK_Key для A-Z и 0-9.
Изменение оконной процедуры TForm.
Размеры TComboBox с показанным выпадающим списком.
Меню в стиле Delphi 4.
Режим вставка-замена в TMemo и TEdit.
Сообщение сразу всем элементам управления формы.
Свойство selected Listbox'а.
Ограничение длинны текста, вводимого в TEdit.
Сохранение обьекта TFont в реестре.
Перемещать компонент мышкой в 'runtime'.
Ошибка при создании обьекта класса TPrinter.
Перехват событий в неклиентской области формы.
Как нарисовать пиктограмму (icon) с увеличением.
Автоматическая ширина колонок в StringGrid.
TTimer работает не достаточно точно.
Как поместить JPEG-картинку в exe-файл.
Перехват сообщений прокрутки в TScrollBox.
Прямоугольник для выделения части рисунка.
Использование пиктограммы (Icon) как картинки на TSpeedButton.
Прозрачная фоновая каринкя на компоненте CoolBar.
Отключение мигания ползунока компонента TScrollBar.
Установить курсор в нужную позицию ячейки DBGrid.
Как поместить курсор в определенную позицию edit'а.
Реагируем на минимизацию-максимизацию формы.
Показ формы без передачи ей фокуса ввода.
Удаление дисков из списка TDriveComboBox.
Сообщение всем формам приложения о глобальных изменениях.
Обновить список дисков компонента TDriveComboBox.
Как программно заставить выпасть меню.
Клавиша-акселератор для компонета у которого нет заголовка.
Уменьшение мерцания при перерисовке компонента.
Как запретить изменение размера моего компонента в design-time.
Уменьшение ресурсов потребляемых TNotebook и TTabbedNotebook.
Эмуляция нажатия клавиши с кодом #255.
Как программно эмулировать движение мыши.
Как зарегистрировать новый тип файла за своим приложением.

Вопрос:

Как разместить прозрачную надпись на 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'а по заголовку?

Ответ:

Пример:

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;


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



Вопрос:

Ответ:
Можно перехватить сообщение 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;


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



Вопрос:

Ответ:

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



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

Ответ:

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


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



Вопрос:
Как настроить табуляцию в компоненте TMemo?

Ответ:

Пример:

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;


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



Вопрос:
Как перехватить нажатия функциональных клавиш и стрелок?

Ответ:

Пример:

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;


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



Вопрос:

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

Пример:

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


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



Вопрос:

При использовании BitBtn Caption(текст) и картинка(bitmap) из файла не видны 
одновременно. Почему?

Ответ:

Пример:
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?

Ответ:

Пример:

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;


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



Вопрос:

Ответ:

Пример:

SysUtils.Abort;


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



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

Ответ:

Пример:

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;


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



Вопрос:

Ответ:
В примере стили шрифта меняются по нажатию след. комбинаций клавиш
	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;


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



Вопрос:

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

Пример:

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" компонента во время выполнения программы?

Ответ:

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



Вопрос:

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

Ответ:

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

Пример:

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


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



Вопрос:

Ответ:

Примечание: Вам придется редактировать этот код, если Вы добавите в приложение новые формы.

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;


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



Вопрос:

Ответ:
В примере используется метод 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) рисуют на один пиксел короче?

Ответ:

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



Вопрос:
Как показать подсказки "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;


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



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

Ответ:

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;


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



Вопрос:

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

Пример:

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?

Ответ:

Пример:

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


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



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

Ответ:

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

Пример:

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


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



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

Ответ:

Пример:

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


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



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

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

Пример:

unit Unit1;

interface

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

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

var
	Form1: TForm1;

implementation

{$R *.DFM}

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


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



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

Ответ:

Пример:

{$IFDEF WIN32}

uses Registry;

{$ENDIF}

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

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


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



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

Ответ:

Пример:

uses MMSystem, MPlayer;

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


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



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

Ответ:

Пример:

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

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



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

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

Пример:

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


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



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

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

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

Пример:

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

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


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



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

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

Пример:

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

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


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



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

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

Пример:

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


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



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

Ответ:

Пример:

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

var
	Form1: TForm1;

implementation

{$R *.DFM}

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

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


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



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

Ответ:

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


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



Вопрос:

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

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

Пример:

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

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

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


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



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

Ответ:

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


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



Вопрос:

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

Пример:

uses ClipBrd;

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


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



Вопрос:

Ответ:

Пример:

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

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

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

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


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



Вопрос:

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

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

Memo1.Perform(EM_UNDO, 0, 0);

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

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

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


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



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

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

Пример:

unit Unit2;

interface

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

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

var
	Form2: TForm2;

implementation

{$R *.DFM}

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

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


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



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

Ответ:

Пример:

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


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



Вопрос:

Ответ:

Пример:

uses CommCtrl, ComCtrls;

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

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

var
	MyTrackbar : TMyTrackbar;

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


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



Вопрос:

Ответ:

Пример:

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


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



Вопрос:

Ответ:

Пример:

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

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


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



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

Ответ:

Пример:

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


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



Вопрос:

Ответ:

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



Вопрос:

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

Пример:

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

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

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

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


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



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

Ответ:

Пример:

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

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

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


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



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

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


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



Вопрос:

Ответ:

Пример:

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

var
	Form1: TForm1;

implementation

{$R *.DFM}

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

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


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



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

Ответ:

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



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

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

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


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



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

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

Пример:

uses MMSystem;

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


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



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

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

Пример:

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

var
	Form1: TForm1;

implementation

{$R *.DFM}

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


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



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

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

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

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

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

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

Application.OnIdle := IdleEventHandler;

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



Вопрос:

Ответ:

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



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

Ответ:

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

var
	Form1: TForm1;

implementation

{$R *.DFM}

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

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

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


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



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

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

Пример:

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


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



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

Пример:

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


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



Вопрос:

Ответ:

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

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


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



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

Ответ:

Пример:

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

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

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

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



Вопрос:
Как изменить шрифта hint'а?

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

Пример:

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

var
	Form1: TForm1;

implementation

{$R *.DFM}

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

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


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



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

Ответ:

Пример:

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

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

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

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

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

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

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

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


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



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

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

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


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



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

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

Пример:

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


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



Вопрос:

Ответ:

Пример:

uses Printers, CommDlg;

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


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



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

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

Пример:

MediaPlayer1.FileName := 'E:';


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



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

Ответ:

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

program Project1;

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

{$R *.RES}

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

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

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


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



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

Ответ:

Пример: 

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


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



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

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


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



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

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

Пример:

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


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



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

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

Пример:

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


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



Вопрос:

Ответ:

Пример:

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


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



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

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

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


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



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

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

Пример:

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


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



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

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

Пример:

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

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


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



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

Ответ:

Пример:

uses Printers;

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


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



Вопрос:

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

Пример:
uses Registry;

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


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



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

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

Пример:

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


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



Вопрос:

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

Пример:

type TStrongType = type Double;
type TWeakType = Double;

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

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

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

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


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



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

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


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



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

Ответ:

Пример:

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

var
	Form1: TForm1;

implementation

{$R *.DFM}

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

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


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



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

Ответ:

Пример:

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

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


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



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

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


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



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

Ответ:

Пример:

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

var
	Form1: TForm1;

implementation

{$R *.DFM}

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

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


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



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

Ответ:

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



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

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

Пример:

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


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



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

Ответ:

Пример:

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

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

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


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



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

Ответ:

Uses    ... Registry;

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

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

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

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


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



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

Ответ:

Пример:

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

var
	Form1: TForm1;

implementation

{$R *.DFM}

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

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

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


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



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

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

Пример:

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
begin
	Printer.BeginDoc;
	Printer.Canvas.TextOut(100, 100, 'Hello World!');
	Printer.EndDoc;
end;



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



Вопрос:
Как перехватить события в неклиентской области формы, в заголовке окна, например?

Ответ:
Создайте обработчик одного из сообщений WM_NC (non client - не клиентских) (посмотрите
WM_NC в Windows API help). Пример показывает как перехватить вижение мыши во всей
неклиенстской области окна (рамка и заголовок).

Пример:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
private
	{Private declarations}
	procedure WMNCMOUSEMOVE(var Message: TMessage);
	message WM_NCMOUSEMOVE;
public
	{Public declarations}
end;

var
	Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage);
var
	s : string;
begin
	case Message.wParam of
		HTERROR: 	
			s:= 'HTERROR';
		HTTRANSPARENT:
			s:= 'HTTRANSPARENT';
		HTNOWHERE:	
			s:= 'HTNOWHERE';
		HTCLIENT:
			s:= 'HTCLIENT';
		HTCAPTION:
			s:= 'HTCAPTION';
		HTSYSMENU:
			s:= 'HTSYSMENU';
		HTSIZE:
			s:= 'HTSIZE';
		HTMENU:
			s:= 'HTMENU';
		HTHSCROLL:
			s:= 'HTHSCROLL';
		HTVSCROLL:
			s:= 'HTVSCROLL';
		HTMINBUTTON:
			s:= 'HTMINBUTTON';
		HTMAXBUTTON:
			s:= 'HTMAXBUTTON';
		HTLEFT:
			s:= 'HTLEFT';
		HTRIGHT:
			s:= 'HTRIGHT';
		HTTOP:
			s := 'HTTOP';
		HTTOPLEFT:
			s:= 'HTTOPLEFT';
		HTTOPRIGHT:
			s:= 'HTTOPRIGHT';
		HTBOTTOM:
			s:= 'HTBOTTOM';
		HTBOTTOMLEFT:
			s:= 'HTBOTTOMLEFT';
		HTBOTTOMRIGHT:
			s:= 'HTBOTTOMRIGHT';
		HTBORDER:
			s:= 'HTBORDER';
		HTOBJECT:
			s:= 'HTOBJECT';
		HTCLOSE:
			s:= 'HTCLOSE';
		HTHELP:
			s:= 'HTHELP';
		else s:= '';
	end;
	Form1.Caption := s;
	Message.Result := 0;
end;

end.


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



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

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

Пример:

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


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



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

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

Пример:

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

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


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



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

Ответ:

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



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

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

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

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

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

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

uses Jpeg;

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


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



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

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

Пример:

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

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

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

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

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

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


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



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

Ответ:

Пример:

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

var
	Form1: TForm1;

implementation

{$R *.DFM}

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

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

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

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


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



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

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

Пример:

uses ShellApi;

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


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



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

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


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



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

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


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



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

Ответ:

Пример:

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


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



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

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

Пример:

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


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



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

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

Пример:

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

var
	Form1: TForm1;

implementation

{$R *.DFM}

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


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



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

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

Пример:

uses Unit2;

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


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



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

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

Пример:

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


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



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

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

Пример:

{Code for Unit1}

const
	UM_MyGlobalMessage = WM_USER + 1;

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

var
	Form1: TForm1;

implementation

{$R *.DFM}

uses Unit2;

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

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

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

{Code for Unit2}

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

var
	Form2: TForm2;

implementation

{$R *.DFM}

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


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



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

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

Пример:

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

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


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



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

Ответ:

Пример:

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


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



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

Ответ:

Пример:

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


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



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

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

Пример:

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


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



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

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

Пример:

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


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



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

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

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

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

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


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



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

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


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



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

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

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


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



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

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

Пример:

uses
	Registry;

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


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