Статьи Королевства Дельфи


DelphiVCLFAQ


Сокровищница
источник информации:
DELPHI VCL FAQ Перевод с английского

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

Скачать (38 K) для просмотра в off-line.

Вернуться к разделу

Вопрос: Как разместить прозрачную надпись на 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".

Наверх к содержанию Вопрос: Можно ли отключить определенный элемент в 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); { Вопрос: Где в 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 // Вопрос: Как узнать размеры 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 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;

© 1999 Inprise Corp.
Last Modified Friday, 06-Aug-99 11:12:04 PST.
Translated & Adapted by
19-Sep-1999




Начало  Назад  Вперед



Книжный магазин