DELPHISOURCE

Домой | Статьи | Книги | FAQ | Компоненты | Программы
Архив сайта | Реклама на сайте | Ссылки | Связь

DELPHI VCL FAQ

Вопрос: Как разместить прозрачную надпись на TBitmap?
Пример:
procedure TForm1.Button1Click(Sender: TObject);

var
OldBkMode : integer;

begin
Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;

OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,TRANSPARENT);

Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');

SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,OldBkMode);
end;

Наверх к содержанию
Вопрос: Можно ли обратиться к колонке или строке grid'а по заголовку? Ответ: В следующем примере приведены две функции: GetGridColumnByName() и GetGridRowByName(), которые возвращают колонку или строку, имеющую заданный заголовок (caption).
Пример:
procedure TForm1.FormCreate(Sender: TObject);

begin
StringGrid1.Rows[1].Strings[0] := 'This Row';

StringGrid1.Cols[1].Strings[0] := 'This Column';

end;

Function GetGridColumnByName(Grid : TStringGrid;
ColName : string): integer;

var
i : integer;

begin
for i := 0 to Grid.ColCount - 1 do
begin
Result := i;

exit;

end;

Result := -1;

end;

Function GetGridRowByName(Grid : TStringGrid;
RowName : string): integer;

var
i : integer;

begin
for i := 0 to Grid.RowCount - 1 do
if Grid.Cols[0].Strings[i] = RowName then
begin
Result := i;

exit;

end;

Result := -1;

end;

procedure TForm1.Button1Click(Sender: TObject);

var
Column : integer;

Row : integer;

begin
Column := GetGridColumnByName(StringGrid1, 'This Column');

if Column = -1 then
ShowMessage('Column not found')
else
ShowMessage('Column found at ' + IntToStr(Column));

Row := GetGridRowByName(StringGrid1, 'This Row');

if Row = -1 then
ShowMessage('Row not found')
else
ShowMessage('Row found at ' + IntToStr(Row));

end;

Наверх к содержанию
Вопрос: Как использовать клавишу-акселератор в TTabsheets? Я добавляю клавишу-акселератор в заголовок каждого Tabsheet моего PageControl, но при попытке переключать страницы этой клавишей программа пикает и ничего не происходит.
Ответ: Можно перехватить сообщение CM_DIALOGCHAR.
Пример:
type
TForm1 = class(TForm)
PageControl1: TPageControl;

TabSheet1: TTabSheet;

TabSheet2: TTabSheet;

TabSheet3: TTabSheet;

private
{Private declarations}
procedure CMDialogChar(var Msg:TCMDialogChar);

message CM_DIALOGCHAR;

public
{Public declarations}
end;

var
Form1: TForm1;

implementation
{$R *.DFM}
procedure TForm1.CMDialogChar(var Msg:TCMDialogChar);

var
i : integer;

begin
with PageControl1 do
begin
if Enabled then
for i := 0 to PageControl1.PageCount - 1 do
if ((IsAccel(Msg.CharCode, Pages[i].Caption)) and
(Pages[i].TabVisible)) then
begin
Msg.Result:=1;

ActivePage := Pages[i];

exit;

end;

end;

inherited;

end;

Наверх к содержанию
Вопрос: При использованиии компонента TRegistry под NT пользователь с права доступа ниже чем "
администратор"
не может получить доступа к информации реестра в ключе HKEY_LOCAL_MACHINE. Как это обойти?
Ответ: Проблема вызвана тем, что TRegistry всегда открывает реестр с параметром KEY_ALL_ACCESS (полный доступ), даже если необходим доступ KEY_READ (только чтение). Избежать этого можно используя функции API для работы с реестром (RegOpenKey и т.п.), или создать новый класс из компонента TRegestry, и изменить его так чтобы можно было задавать режим открытия реестра.
Наверх к содержанию
Вопрос: Можно ли изменить число колонок и их ширину в компоненте TFileListBox?
Ответ: В приведенном примере FileListBox приводится к типу TDirectoryListBox - таким образом можно добавиь дополнительные колонки.
Пример:
with TDirectoryListBox(FileListBox1) do
begin
Columns := 2;

SendMessage(Handle, LB_SETCOLUMNWIDTH, Canvas.TextWidth('WWWWWWWW.WWW'),0);

end;

Наверх к содержанию
Вопрос: Как настроить табуляцию в компоненте TMemo?
Ответ: Пошлите в Memo сообщение EM_SETTABSTOPS. Например установим первую позицию табуляции на 20-й пиксел.
Пример: procedure TForm1.FormCreate(Sender: TObject);

var
DialogUnitsX : LongInt;

PixelsX : LongInt;

i : integer;

TabArray : array[0..4] of integer;

begin
Memo1.WantTabs := true;

DialogUnitsX := LoWord(GetDialogBaseUnits);

PixelsX := 20;

for i := 1 to 5 do
begin
TabArray[i - 1] :=((PixelsX * i ) * 4) div DialogUnitsX;

end;

SendMessage(Memo1.Handle,
EM_SETTABSTOPS,5,LongInt(@TabArray));

Memo1.Refresh;

end;

Наверх к содержанию
Вопрос: Как перехватить нажатия функциональных клавиш и стрелок?
ответ: Проверяйте значение переменной key на равенство VK_RIGHT, VK_LEFT, VK_F1 и т.д. на событии KeyDown формы. Пример: procedure TForm1.FormKeyDown(Sender: TObject;
var key: Word;
Shift: TShiftState);
begin if key = VK_RIGHT then Form1.Caption := 'Right';
if key = VK_F1 then Form1.Caption := 'F1';
end;
Наверх к содержанию
Вопрос: При обработке события DrawCell компонента DrawGrid я пишу Font.Color := clRed;
и получаю бесконечный цикл мерцаний. Почему?
ответ: Правильно укажите границы используемого канваса.
Пример: if (Row = 0) then begin DrawGrid1.Canvas.Font.Color := clRed;
DrawGrid1.Canvas.TextOut(Rect.Left,Rect.Top, IntToStr(Col));
end;
Наверх к содержанию
Вопрос: При использовании BitBtn Caption(текст) и картинка(bitmap) из файла не видны одновременно. Почему?
ответ: Это может происходить если картинка слишком велика. Класс TBitBtn сначала рисует картинку, а затем выводит текст над, под, слева или справа от картинки (в завивимости от свойства Layout). Если размер картинки такой же как у всей кнопки для вывода текста просто не остается места. Если Вам нужно получить кнопку такого же размера как Ваша картинка и видеть при этом надпись на кнопке Вам придется выводить текст надписи непосредственно на канву картинки.
Пример: var bm : TBitmap;
OldBkMode : integer;
begin bm := TBitmap.Create;
bm.Width := BitBtn1.Glyph.Width;
bm.Height := BitBtn1.Glyph.Height;
bm.Canvas.Draw(0, 0, BitBtn1.Glyph);
OldBkMode := SetBkMode(bm.Canvas.Handle, Transparent);
bm.Canvas.TextOut(0, 0, 'The Caption');
SetBkMode(bm.Canvas.Handle, OldBkMode);
BitBtn1.Glyph.Assign(bm);
end;
Наверх к содержанию
Вопрос: Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента управления Windows?
ответ: Можно! В примере показано как создать два цветных "
bitmap'а"
: "
улыбчивый"
и "
хмурый"
и присвоить их курсору edit'а. Для этого нужно перехватить оконную процедуру edit'а. Чтобы сделать это заменим адрес оконной процедуры Edit'а нашим собственным, а старую оконную процедуру будем вызывать по необходимости. Пример показывает "
улыбчивый"
курсор при наборе текста и "
хмурый"
при забое клавишей backspace.
Пример: unit caret1;
interface {$IFDEF WIN32} uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
{$else} uses WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
{$endif} type TForm1 = class(TForm) Edit1: TEdit;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private {Private declarations} public {Public declarations} CaretBm : TBitmap;
CaretBmBk : TBitmap;
OldEditsWindowProc : Pointer;
end;
var Form1: TForm1;
implementation {$R *.DFM} type {$IFDEF WIN32} WParameter = LongInt;
{$else} WParameter = Word;
{$endif} LParameter = LongInt;
{new windows procedure for the edit control} Function NewWindowProc(WindowHandle : hWnd;
TheMessage : WParameter;
ParamW : WParameter;
ParamL : LParameter) : LongInt {$IFDEF WIN32} stdcall;
{$else} ;
export;
{$endif} begin {Call the old edit controls windows procedure} NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle, TheMessage, ParamW, ParamL);
if TheMessage = WM_SETFOCUS then begin CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
ShowCaret(WindowHandle);
end;
if TheMessage = WM_KILLFOCUS then begin HideCaret(WindowHandle);
DestroyCaret;
end;
if TheMessage = WM_KEYDOWN then begin if ParamW = VK_BACK then CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0) else CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
ShowCaret(WindowHandle);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin {Create a smiling bitmap using the wingdings font} CaretBm := TBitmap.Create;
CaretBm.Canvas.Font.Name := 'WingDings';
CaretBm.Canvas.Font.Height := Edit1.Font.Height;
CaretBm.Canvas.Font.Color := clWhite;
CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;
CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;
CaretBm.Canvas.Brush.Color := clBlue;
CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height));
CaretBm.Canvas.TextOut(1, 1, 'J');
{Create a frowming bitmap using the wingdings font} CaretBmBk := TBitmap.Create;
CaretBmBk.Canvas.Font.Name := 'WingDings';
CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;
CaretBmBk.Canvas.Font.Color := clWhite;
CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;
CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;
CaretBmBk.Canvas.Brush.Color := clBlue;
CaretBmBk.Canvas.FillRect(Rect(0,0, CaretBmBk.Width, CaretBmBk.Height));
CaretBmBk.Canvas.TextOut(1, 1, 'L');
{Hook the edit controls window procedure} OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle,GWL_WNDPROC, LongInt(@NewWindowProc)));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin {Unhook the edit controls window procedure and clean up} SetWindowLong(Edit1.Handle,GWL_WNDPROC, LongInt(OldEditsWindowProc));
CaretBm.Free;
CaretBmBk.Free;
end;
Наверх к содержанию
Вопрос: При использовании модулей доступа к BDE (DbiTypes, DbiProcs, DbiErrs), любая попытка вызвать процедуру abort выдает ошибку при компиляции при вызове метода abort "
Statement expected, but expression of type 'integer' found"
. Я пытался найти DbiTypes.pas, DbiProcs.pas и DbiErrs.pas чтобы разобраться но не нашел этих файлов. Где расположены эти файлы и как обойти ошибку?
ответ: Модули DbiTypes, DbiProcs, DbiErrs это псевдонимы модуля "
BDE"
, обьявлены в Projects->
Options->
Directories/Conditionals->
Unit Aliases. Исходник модуля DBE находится в каталоге "
doc"
и называется "
BDE.int"
. В этом файле обьявленна константа ABORT со значением -2. Так как Вы хотите использовать процедуру Abort(), которая обьявлена в модуле SysUtils, Вам нужно добавить префикс SysUtils перед вызовом процедуры Abort.
Пример: SysUtils.Abort;
Наверх к содержанию
Вопрос: Почему при изменении цвета букв StatusBar'а ничего не происходит?
ответ: Status bar - стандартный элемент управления Windows, и со
ответственно цвет его букв - значение clBtnText которое изменяется с помощью настроек в Control Panel. Этот цвет черный по умолчанию и может изменяться в зависимости от выбранной цветовой схемы. Другие стандартные элемент управления Windows, например кнопки, также имеют цвет букв, настраиваемый из ControlPanel. StatusBar и его панели имеют свойство "
owner-draw"
, позволяющее Вам использовать любой цвет букв.
Пример: procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel;
const Rect: TRect);
begin if Panel = StatusBar.Panels[0] then begin StatusBar.Canvas.Font.Color := clRed;
StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0') end else begin StatusBar.Canvas.Font.Color := clGreen;
StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
end;
end;
Наверх к содержанию
Вопрос: Как сделать многострочную надпись на TBitBtn?
ответ: Выводите текст надписи непосредственно на "
glyph"
TBitBtn'а. См. пример.
Пример: procedure TForm1.FormCreate(Sender: TObject);
var R : TRect;
N : integer;
Buff : array[0..255] of Char;
begin with BitBtn1 do begin Caption := 'A really really long caption';
Glyph.Canvas.Font := Self.Font;
Glyph.Width := Width - 6;
Glyph.Height := Height - 6;
R := Bounds(0, 0, Glyph.Width, 0);
StrPCopy(Buff, Caption);
Caption := '';
DrawText(Glyph.Canvas.Handle,Buff,strlen(Buff),R, DT_CENTER or DT_WORDBREAK or DT_CALCRECT);
OffsetRect(R,(Glyph.Width - R.Right) div 2, (Glyph.Height - R.Bottom) div 2);
DrawText(Glyph.Canvas.Handle,Buff,strlen(Buff),R, DT_CENTER or DT_WORDBREAK);
end;
end;
Наверх к содержанию
Вопрос: Как изменить стиль шрифта RichEdit нажатиями соответствующих комбинаций клавиш? (например включить курсив по нажатию Ctrl + I)
ответ: В примере стили шрифта меняются по нажатию след. комбинаций клавиш Ctrl + B - вкл/выкл жирного шрифта Ctrl + I - вкл/выкл наклонного шрифта Ctrl + S - вкл/выкл зачеркнутого шрифта Ctrl + U - вкл/выкл подчеркнутого шрифта
Пример: const KEY_CTRL_B = 02;
KEY_CTRL_I = 9;
KEY_CTRL_S = 19;
KEY_CTRL_U = 21;
procedure TForm1.RichEdit1KeyPress(Sender: TObject;
var key: Char);
begin case ord(key) of KEY_CTRL_B: begin key := #0;
if fsBold in (Sender as TRichEdit).SelAttributes.Style then (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style - [fsBold] else (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style + [fsBold];
end;
KEY_CTRL_I: begin key := #0;
if fsItalic in (Sender as TRichEdit).SelAttributes.Style then (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style - [fsItalic] else (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style + [fsItalic];
end;
KEY_CTRL_S: begin key := #0;
if fsStrikeout in (Sender as TRichEdit).SelAttributes.Style then (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style-[fsStrikeout] else (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style+[fsStrikeout];
end;
KEY_CTRL_U: begin key := #0;
if fsUnderline in (Sender as TRichEdit).SelAttributes.Style then (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style-[fsUnderline] else (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style+[fsUnderline];
end;
end;
end;
Наверх к содержанию
Вопрос: В документации компонента TRegIniFile говорится, что можно изменять корневой ключ (root key). Я пытаюсь это сделать но ничего не получается.
ответ: См. пример.
Пример: uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var WinIni : TRegIniFile;
begin WinIni := TRegIniFile.Create('');
WinIni.RootKey := HKEY_LOCAL_MACHINE;
WinIni.WriteString('Frank','Borland','Writes Fast Code!');
WinIni.Free;
end;
Наверх к содержанию
Вопрос: Можно ли динамически изменять свойство "
owner"
компонента во время выполнения программы?
ответ: Вы можете менять свойство "
owner"
и после создания компонента с помощью методов InsertComponent() и RemoveComponent(). Наверх к содержанию
Вопрос: Как очистить содержимое Canvas'а?
ответ: Просто нарисуйте прямоугольник любого цвета.
Пример: Canvas.Brush.Color := ClWhite;
Canvas.FillRect(Canvas.ClipRect);
Наверх к содержанию
Вопрос: Можно ли динамически менять какая форма считается главной в приложении во время работы программы?
ответ: Можно, но только во время загрузки приложения. Чтобы сделать это выберите "
View->
Project Source"
и измените код инициализации приложения, так что порядок создания форм зависил от какого-то условия. Примечание: Вам придется редактировать этот код, если Вы добавите в приложение новые формы. begin Application.Initialize;
if <
какое-то условие>
then begin Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);
end else begin Application.CreateForm(TForm2, Form2);
Application.CreateForm(TForm1, Form1);
end;
end. Application.Run;
Наверх к содержанию
Вопрос: Как программно "
щелкнуть"
по компоненту speed button? Я пытался использовать SendMessage но у Speedbuttons нет "
handle"
.
ответ: В примере используется метод Perform класса TControl для отправки сообщения.
Пример: procedure TForm1.SpeedButton1Click(Sender: TObject);
begin ShowMessage('clicked');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin SpeedButton1.Perform(WM_LBUTTONDOWN, 0, 0);
SpeedButton1.Perform(WM_LBUTTONUP, 0, 0);
end;
Наверх к содержанию
Вопрос: Можно ли отключить определенный элемент в RadioGroup?
ответ: В примере показано как получить доступ к отдельным элементам компонента TRadioGroup.
Пример: procedure TForm1.Button1Click(Sender: TObject);
begin TRadioButton(RadioGroup1.Controls[1]). Enabled := false;
end;
Наверх к содержанию
Вопрос: Почему методы рисования Delphi (например MoveTo и LineTo) рисуют на один пиксел короче?
ответ: Так работает большинство графических систем, включая Windows. Библиотека VCL просто передает вызовы в функции GDI. Если Вы хотите нарисовать линию с последним пикселом включительно просто добавте единицу к координатам. Наверх к содержанию
Вопрос: Как показать подсказки "
hints"
для элементов меню?
ответ: В примере создается обработчик события Application.Hint - подсказки меню изображаются на status panel.
Пример: type TForm1 = class(TForm) Panel1: TPanel;
MainMenu1: TMainMenu;
MenuItemFile: TMenuItem;
MenuItemOpen: TMenuItem;
MenuItemClose: TMenuItem;
OpenDialog1: TOpenDialog;
procedure FormCreate(Sender: TObject);
procedure MenuItemCloseClick(Sender: TObject);
procedure MenuItemOpenClick(Sender: TObject);
private {Private declarations} procedure HintHandler(Sender: TObject);
public {Public declarations} end;
var Form1: TForm1;
implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject);
begin Panel1.Align := alBottom;
MenuItemFile.Hint := 'file Menu';
MenuItemOpen.Hint := 'Opens A file';
MenuItemClose.Hint := 'Closes the Application';
Application.OnHint := HintHandler;
end;
procedure TForm1.HintHandler(Sender: TObject);
begin Panel1.Caption := Application.Hint;
end;
procedure TForm1.MenuItemCloseClick(Sender: TObject);
begin Application.Terminate;
end;
procedure TForm1.MenuItemOpenClick(Sender: TObject);
begin if OpenDialog1.Execute then Form1.Caption := OpenDialog1.FileName;
end;
Наверх к содержанию
Вопрос: Как опеделить состояние списка ComboBox, выпал/скрыт?
ответ: Пошлите ComboBox сообщение CB_GETDROPPEDSTATE.
Пример: if SendMessage(ComboBox1.Handle, CB_GETDROPPEDSTATE,0,0) = 1 then begin {список ComboBox выпал} end;
Наверх к содержанию
Вопрос: Как удалить каталог вместе со всеми содержащимися в нем файлами?
ответ: В примере стираются все файлы в каталоге и сам каталог. Чтобы удалить файл, помечанные только для чтения (read only) и занятые другими программами в момент удаления - напишите дополнительную процедуру. procedure TForm1.Button1Click(Sender: TObject);
var DirInfo: TSearchRec;
r: integer;
begin r := FindFirst('C:\Download\*.*', FaAnyfile, DirInfo);
while r = 0 do begin if ((DirInfo.Attr and FaDirectory <
>
FaDirectory) and (DirInfo.Attr and FaVolumeId <
>
FaVolumeID)) then if DeleteFile(pChar('C:\Download\' + DirInfo.Name))= false then ShowMessage('Unable to delete: C:\Download\'+DirInfo.Name);
r := FindNext(DirInfo);
end;
SysUtils.FindClose(DirInfo);
if RemoveDirectory('C:\Download\') = false then ShowMessage('Unable to delete directory: C:\Download\');
end;
Наверх к содержанию
Вопрос: Как отключить системное меню формы и кнопки Minimize, Maximize, and close во время выполнения(Runtime)?
ответ: В приведенном примере показано как это сделать
Пример: procedure TForm1.Button1Click(Sender: TObject);
begin {Disable} Form1.BorderIcons := Form1.BorderIcons - [biSystemMenu, biMinimize, biMaximize];
end;
procedure TForm1.Button2Click(Sender: TObject);
begin {Enable} Form1.BorderIcons := Form1.BorderIcons + [biSystemMenu, biMinimize, biMaximize];
end;
Наверх к содержанию
Вопрос: Как извлечь Red, Green, и Blue компонент из определенного цвета?
ответ: Используйте функции Window API Get RValue(), GetGValue(), и GetBValue().
Пример: procedure TForm1.Button1Click(Sender: TObject);
begin Form1.Canvas.Pen.Color := clRed;
Memo1.Lines.Add('Red := ' + IntToStr(GetRValue(Form1.Canvas.Pen.Color)));
Memo1.Lines.Add('Red := ' + IntToStr(GetGValue(Form1.Canvas.Pen.Color)));
Memo1.Lines.Add('Blue:= ' + IntToStr(GetBValue(Form1.Canvas.Pen.Color)));
end;
Наверх к содержанию
Вопрос: Как определить номер текущей строки в TMemo?
ответ: Чтобы определить номер текущей строки любого объекта управления edit - пошлите ей сообщение EM_LINEFROMCHAR
Пример: procedure TForm1.Button1Click(Sender: TObject);
var LineNumber : integer;
begin LineNumber := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, word(-1), 0);
ShowMessage(IntToStr(LineNumber));
end;
Наверх к содержанию
Вопрос: Как проигрываеть MPEG файл в Delphi-программе?
ответ: Если в системе Windows MMSystem установлен декодер MPEG - используя компонент TMediaPlayer
Пример: procedure TForm1.Button1Click(Sender: TObject);
begin MediaPlayer1.Filename := 'C:\DownLoad\rsgrow.mpg';
MediaPlayer1.Open;
MediaPlayer1.Display := Panel1;
MediaPlayer1.DisplayRect := Panel1.ClientRect;
MediaPlayer1.Play;
end;
Наверх к содержанию
Вопрос: Как использовать анимированный курсор?
ответ: Во первых необходимо получит handle курсора, а затем определить его в массиве курсоров компонента TScreen. Индексы предопределенных курсоров системы отрицательны, пользователь может определить курсор, индекс которого положителен.
Пример: procedure TForm1.Button1Click(Sender: TObject);
var h : THandle;
begin h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or LR_LOADFROMFILE);
if h = 0 then ShowMessage('Cursor not loaded') else begin Screen.Cursors[1] := h;
Form1.Cursor := 1;
end;
end;
Наверх к содержанию
Вопрос: Как узнать о нажатии "
non-menu"
клавиши в момент когда меню показано?
ответ: Создайте обработчик сообщения WM_MENUCHAR.
Пример: unit Unit1;
interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus;
type TForm1 = class(TForm) MainMenu1: TMainMenu;
One1: TMenuItem;
Two1: TMenuItem;
THree1: TMenuItem;
private {Private declarations} procedure WmMenuChar(var m : TMessage);
message WM_MENUCHAR;
public {Public declarations} end;
var Form1: TForm1;
implementation {$R *.DFM} procedure TForm1.WmMenuChar(var m : TMessage);
begin Form1.Caption := 'Non standard menu key pressed';
m.Result := 1;
end;
end. Наверх к содержанию
Вопрос: Как определить наличие сопроцессора?
ответ: В отличие от общепринятого мнения не всее клоны 486/586/686/ и Pentium имеют сопроцессор для вычислений с плавающей запятой. В примере определяется наличие сопроцессора и под Win16 и под Win32.
Пример: {$IFDEF WIN32} uses Registry;
{$endif} Function HasCoProcesser : bool;
{$IFDEF WIN32} var TheKey : hKey;
{$endif} begin Result := true;
{$IFNDEF WIN32} if GetWinFlags and Wf_80x87 = 0 then Result := false;
{$else} if RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'HARDWARE\DESCRIPTION\System\FloatingPointProcessor',0, KEY_EXECUTE, TheKey) <
>
ERROR_SUCCESS then result := false;
RegCloseKey(TheKey);
{$endif} end;
procedure TForm1.Button1Click(Sender: TObject);
begin if HasCoProcesser then ShowMessage('Has CoProcessor') else ShowMessage('No CoProcessor - Windows Emulation Mode');
end;
Наверх к содержанию
Вопрос: Как узнать серийный номер аудио CD?
ответ: CD может иметь или не иметь серийный номер и/или универсальный код продукта (Universal Product Code). MCI-расширение Windows предоставляет эту информации с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает уникальную ID-строку.
Пример: uses MMSystem, MPlayer;
procedure TForm1.Button1Click(Sender: TObject);
var mp : TMediaPlayer;
msp : TMCI_INFO_PARMS;
MediaString : array[0..255] of char;
ret : longint;
begin mp := TMediaPlayer.Create(nil);
mp.Visible := false;
mp.Parent := Application.MainForm;
mp.Shareable := true;
mp.DeviceType := dtCDAudio;
mp.FileName := 'D:';
mp.Open;
Application.ProcessMessages;
FillChar(MediaString, sizeof(MediaString), #0);
FillChar(msp, sizeof(msp), #0);
msp.lpstrReturn := @MediaString;
msp.dwRetSize := 255;
ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY, longint(@msp));
if Ret <
>
0 then begin MciGetErrorString(ret, @MediaString, sizeof(MediaString));
Memo1.Lines.Add(StrPas(MediaString));
end else Memo1.Lines.Add(StrPas(MediaString));
mp.close;
Application.ProcessMessages;
mp.free;
end;
end. Наверх к содержанию
Вопрос: Как вывести на элемент управления (Window control) текст, содержащий амперсанд - &
?
ответ: Используя два амперсанда подряд. Windows интерпритирует одиночный амперсанд как указание на то, что следующий символ - горячая клавиша (и поддчеркивает следующий символ вместо излбражения аперсанда).
Пример: Button1.Caption := 'Черное &
&
Белое';
Наверх к содержанию
Вопрос: Как поместить bitmap в Metafile?
ответ: см. пример
Пример: procedure TForm1.Button1Click(Sender: TObject);
var m : TmetaFile;
mc : TmetaFileCanvas;
b : tbitmap;
begin m := TMetaFile.Create;
b := TBitmap.create;
b.LoadFromFile('C:\SomePath\SomeBitmap.BMP');
m.Height := b.Height;
m.Width := b.Width;
mc := TMetafileCanvas.Create(m, 0);
mc.Draw(0, 0, b);
mc.Free;
b.Free;
m.SaveToFile('C:\SomePath\Test.emf');
m.Free;
Image1.Picture.LoadFromFile('C:\SomePath\Test.emf');
end;
Наверх к содержанию
Вопрос: Как узнать, что курсор мыши над моей формой?
ответ: Можно использовать функцию GetCapture() из Windows API. Примечание: Cм. документацию Windows для информации об ограничениях функции GetCapture.
Пример: procedure TForm1.FormDeactivate(Sender: TObject);
begin ReleaseCapture;
end;
procedure TForm1.FormMouseMove(Sender: TObject;
Shift: TShiftState;
X, Y: integer);
begin if GetCapture = 0 then SetCapture(Form1.Handle);
if PtInRect(Rect(Form1.Left,Form1.Top,Form1.Left + Form1.Width, Form1.Top + Form1.Height), ClientToScreen(Point(x, y))) then Form1.Caption := 'Мышка над формой!' else Form1.Caption := 'Мышка вне формы...';
end;
Наверх к содержанию
Вопрос: Как программно определить, что приложение работает под Windows NT?
ответ:см. пример
Пример: Function IsNT : bool;
var osv : TOSVERSIONINFO;
begin result := true;
GetVersionEx(osv);
if osv.dwPlatformId = VER_PLATFORM_WIN32_NT then exit;
result := false;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin if IsNt then ShowMessage('Running on NT') else ShowMessage('Not Running on NT');
end;
Наверх к содержанию
Вопрос: Как создать bitmap из пиктогрммы (icon)?
ответ: Используя Bitmap.Canvas.Draw нарисуйте пиктограмму на Bitmap'е.
Пример: procedure TForm1.Button1Click(Sender: TObject);
var TheIcon : TIcon;
TheBitmap : TBitmap;
begin TheIcon := TIcon.Create;
TheIcon.LoadFromFile('C:\Program Files\Borland\IcoCur32\EARTH.ICO');
TheBitmap := TBitmap.Create;
TheBitmap.Height := TheIcon.Height;
TheBitmap.Width := TheIcon.Width;
TheBitmap.Canvas.Draw(0, 0, TheIcon);
Form1.Canvas.Draw(10, 10, TheBitmap);
TheBitmap.Free;
TheIcon.Free;
end;
Наверх к содержанию
Вопрос: Как создать отдельную подсказку (hint) для каждой ячейки StringGrid?
ответ: В приведенном примере отслеживается движение курсора мыши - при перемещении между ячейками StringGrid'а - появляется окно подсказки(hint), показываеющее номер текущей строки и колонки.
Пример: type TForm1 = class(TForm) StringGrid1: TStringGrid;
procedure StringGrid1MouseMove(Sender: TObject;
Shift: TShiftState;
X, Y: integer);
procedure FormCreate(Sender: TObject);
private {Private declarations} Col : integer;
Row : integer;
public {Public declarations} end;
var Form1: TForm1;
implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject);
begin StringGrid1.Hint := '0 0';
StringGrid1.ShowHint := true;
end;
procedure TForm1.StringGrid1MouseMove(Sender: TObject;
Shift: TShiftState;
X, Y: integer);
var r : integer;
c : integer;
begin StringGrid1.MouseToCell(X, Y, C, R);
with StringGrid1 do begin if ((Row <
>
r) or(Col <
>
c)) then begin Row := r;
Col := c;
Application.CancelHint;
StringGrid1.Hint :=IntToStr(r)+#32+IntToStr(c);
end;
end;
end;
Наверх к содержанию
Вопрос: Как внести изменения в код VCL?
ответ: Примечание: внесение изменений в VCL не поддерживается Borland или Borland Developer Support. -Но если Вы решили сделать это... Изменеия в код VCL никогда не должны вносится в секцию "
interface"
модуля - только в секцию "
implimentation"
. Наиболее безопасный способ внести изменения в VCL - создать новый каталог названный "
исправленный VCL"
. Скопируйте файл VCL который Вы хотите изменить в этот каталог. Внесите изменения (лучше прокомментировать их) в этот файл. Затем добавьте путь к Вашему каталогу "
исправленный VCL"
в самое начало "
library path"
. Перезапустите Delphi/C++ Builder и перекомпилируйте Ваш проект. "
library path"
можно изменить в меню: Delphi 1 : Options | Environment | Library Delphi 2 : Tools | Options | Library Delphi 3 : Tools | Environment Options | Library Delphi 4 : Tools | Environment Options | Library C++ Builder : Options | Environment | Library Наверх к содержанию
Вопрос: Как в Delphi реализовать функцию - эквивалент TwipsPerPixel из VisualBasic?
ответ: Функции TwipsPerPixelX и TwipsPerPixelY, приведенные в примере реализуют ту же функциональность в Delphi.
Пример: Function TwipsPerPixelX(Canvas : TCanvas) : Extended;
begin result := 1440 / GetDeviceCaps(Canvas.Handle, LOGPIXELSX);
end;
Function TwipsPerPixelY(Canvas : TCanvas) : Extended;
begin result := 1440 / GetDeviceCaps(Canvas.Handle, LOGPIXELSY);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin ShowMessage(FloatToStr(TwipsPerPixelX(Form1.Canvas)));
ShowMessage(FloatToStr(TwipsPerPixelY(Form1.Canvas)));
end;
Наверх к содержанию
Вопрос: Как вставить содержимое файла в текущую позицию курсора в компонете TMemo?
ответ: Считайте файл в TMemoryStream, затем ипользуйте метод TMemo SetSelTextBuf() для вставки текста;
var TheMStream : TMemoryStream;
Zero : char;
begin TheMStream := TMemoryStream.Create;
TheMStream.LoadFromFile('C:\AUTOEXEC.BAT');
TheMStream.Seek(0, soFromEnd);
//Null terminate the buffer! Zero := #0;
TheMStream.write(Zero, 1);
TheMStream.Seek(0, soFromBeginning);
Memo1.SetSelTextBuf(TheMStream.Memory);
TheMStream.Free;
end;
Наверх к содержанию
Вопрос: Как в компоненте TMemo перехватить нажатие Ctrl-V и вставить специальный текст не из буфера обмена (clipboard)?
ответ: См. пример.
Пример: uses ClipBrd;
procedure TForm1.Memo1KeyDown(Sender: TObject;
var key: Word;
Shift: TShiftState);
begin if ((key = ord('V')) and (ssCtrl in Shift)) then begin if Clipboard.HasFormat(CF_TEXT) then ClipBoard.Clear;
Memo1.SelText := 'Delphi is RAD!';
key := 0;
end;
end;
Наверх к содержанию
Вопрос: Как создать эквивалент TEdit но только с выравниваением вводимого текста по центру или по правой стороне?
ответ: TEdit не поддерживает выравниваение текста по центру и по правой стороне - лучше использовать компонент TMemo. Вам понадобится запретить пользователю нажимать Enter, Ctrl-Enter и всевозможные комбинации клавиш со стрелками, чтобы избежать появления нескольких сторк в Memo. Этого можно добиться и просматривая содержимое текста в TMemo в поисках кода возврата каретки (13) и перевода строки(10) на событиях TMemo Change и KeyPress. Можно также заменять код возврата каретки на пробел - для того чтобы позволять вставку из буфера обмена многострочного текста в виде одной строки.
Пример: procedure TForm1.FormCreate(Sender: TObject);
begin Memo1.Alignment := taRightJustify;
Memo1.MaxLength := 24;
Memo1.WantReturns := false;
Memo1.wordwrap := false;
end;
procedure MultiLineMemoToSingleLine(Memo : TMemo);
var t : string;
begin t := Memo.Text;
if pos(#13, t) >
0 then begin while pos(#13, t) >
0 do delete(t, pos(#13, t), 1);
while pos(#10, t) >
0 do delete(t, pos(#10, t), 1);
Memo.Text := t;
end;
end;
procedure TForm1.Memo1Change(Sender: TObject);
begin MultiLineMemoToSingleLine(Memo1);
end;
procedure TForm1.Memo1KeyPress(Sender: TObject;
var key: Char);
begin MultiLineMemoToSingleLine(Memo1);
end;
Наверх к содержанию
Вопрос: Как запрограммировать undo?
ответ:См. пример Memo1.Perform(EM_UNDO, 0, 0);
Если Вы хотите узнать, возможно ли выполнить операцию "
Undo"
, проверьте "
Undo status"
: if Memo1.Perform(EM_CANUNDO, 0, 0) <
>
0 then begin {Undo is possible} end;
Для выполнения "
Redo"
выполните "
Undo"
еще раз. Наверх к содержанию
Вопрос: Можно ли создать форму, которая получает дополнительные параметры в методе Сreate?
ответ: Просто замените конструктор Create класса Вашей формы.
Пример: unit Unit2;
interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type TForm2 = class(TForm) private {Private declarations} public constructor CreateWithCaption(aOwner: TComponent;
aCaption: string);
{Public declarations} end;
var Form2: TForm2;
implementation {$R *.DFM} constructor TForm2.CreateWithCaption(aOwner: TComponent;
aCaption: string);
begin Create(aOwner);
Caption := aCaption;
end;
uses Unit2;
procedure TForm1.Button1Click(Sender: TObject);
begin Unit2.Form2 :=Unit2.TForm2.CreateWithCaption(Application, 'My Caption');
Unit2.Form2.Show;
end;
Наверх к содержанию
Вопрос: Почему при изменении цвета шрифта в StatusBar's он (шрифт) не меняется?
ответ: Status bar (строка состояния) - стандартный элемент управления Windows и цвет его шрифта задается через Control Panel (константа clBtnText). Этот цвет по умолчанию черный и может меняться при выборе пользователем той или иной цветовой схемы. У компонента ТStatusBar и его панелей есть возможность "
owner-draw"
- программной перерисовки, которая позволяет выводить на панель текст любого цвета. Измените свойство Style компонента TStatusBar.Panels на OwnerDraw.
Пример: procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel;
const Rect: TRect);
begin if Panel = StatusBar.Panels[0] then begin StatusBar.Canvas.Font.Color := clRed;
StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0') end else begin StatusBar.Canvas.Font.Color := clGreen;
StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
end;
end;
Наверх к содержанию
Вопрос: Как бы мне создать эдакий trackbar в котором вместо широкой белой полоски с ползунком была бы тонкая линия?
ответ: В примере создается компонент, унаследованный от TTrackbar который переопределяет метод CreateParams и убират флаг TBS_ENABLESELRANGE из Style. Константа TBS_ENABLESELRANGE обьявленна в модуле CommCtrl.
Пример: uses CommCtrl, ComCtrls;
type TMyTrackBar = class(TTrackBar) procedure CreateParams(var Params: TCreateParams);
override;
end;
procedure TMyTrackBar.CreateParams(var Params: TCreateParams);
begin inherited;
Params.Style := Params.Style and not TBS_ENABLESELRANGE;
end;
var MyTrackbar : TMyTrackbar;
procedure TForm1.Button1Click(Sender: TObject);
begin MyTrackBar := TMyTrackbar.Create(Form1);
MyTrackbar.Parent := Form1;
MyTrackbar.Left := 100;
MyTrackbar.Top := 100;
MyTrackbar.Width := 150;
MyTrackbar.Height := 45;
MyTrackBar.Visible := true;
end;
Наверх к содержанию
Вопрос: Мне нужен временный canvas, но когда я пытаюсь его создать получаю сообщения об ошибках. Как создать TCanvas?
ответ: Создайте Bitmap и используйте свойство canvas класса TBitmap. Пример создает Bitmap, рисует на его canvas'е, выводит этот canvas на форму и освобождает bitmap.
Пример: procedure TForm1.Button1Click(Sender: TObject);
var bm : TBitmap;
begin bm := TBitmap.Create;
bm.Width := 100;
bm.Height := 100;
bm.Canvas.Brush.Color := clRed;
bm.Canvas.FillRect(Rect(0, 0, 100, 100));
bm.Canvas.MoveTo(0, 0);
bm.Canvas.LineTo(100, 100);
Form1.Canvas.StretchDraw(Form1.ClientRect,Bm);
bm.Free;
end;
Наверх к содержанию
Вопрос: В некоторых видео режимах прозрачная часть glyph'а стандартного TBitBtn становится видной. Как этого избежать?
ответ: В примере используется техника закраски прозрачной части glyph'а цветом кнопки на которой он находится - таким образом glyph кажется прозрачным.
Пример: Function InitStdBitBtn(BitBtn : TBitBtn;
kind : TBitBtnKind) : bool;
var Bm1 : TBitmap;
Bm2 : TBitmap;
begin Result := false;
if Kind = bkCustom then exit;
Bm1 := TBitmap.Create;
case Kind of bkOK : Bm1.Handle := LoadBitmap(hInstance, 'BBOK');
bkCancel : Bm1.Handle := LoadBitmap(hInstance, 'BBCANCEL');
bkHelp : Bm1.Handle := LoadBitmap(hInstance, 'BBHELP');
bkYes : Bm1.Handle := LoadBitmap(hInstance, 'BBYES');
bkNo : Bm1.Handle := LoadBitmap(hInstance, 'BBNO');
bkClose : Bm1.Handle := LoadBitmap(hInstance, 'BBCLOSE');
bkAbort : Bm1.Handle := LoadBitmap(hInstance, 'BBABORT');
bkRetry : Bm1.Handle := LoadBitmap(hInstance, 'BBRETRY');
bkIgnore : Bm1.Handle := LoadBitmap(hInstance, 'BBIGNORE');
bkAll : Bm1.Handle := LoadBitmap(hInstance, 'BBALL');
end;
Bm2 := TBitmap.Create;
Bm2.Width := Bm1.Width;
Bm2.Height := Bm1.Height;
Bm2.Canvas.Brush.Color := ClBtnFace;
Bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1, Rect(0, 0, Bm1.width, Bm1.Height), Bm1.canvas.pixels[0,0]);
Bm1.Free;
LockWindowUpdate(BitBtn.Parent.Handle);
BitBtn.Kind := kind;
BitBtn.Glyph.Assign(bm2);
LockWindowUpdate(0);
Bm2.Free;
Result := true;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin InitStdBitBtn(BitBtn1, bkOk);
end;
Наверх к содержанию
Вопрос: Создание PolyPolygon используя массив точек?
ответ: Polygon - метод компонента TCanvas получает в качестве параметра динамический массив точек. Функция PolyPolygon() из Windows GDI получает указатель на массив точек.
Пример: procedure TForm1.Button1Click(Sender: TObject);
var ptArray : array[0..9] of TPOINT;
PtCounts : array[0..1] of integer;
begin PtArray[0] := Point(0, 0);
PtArray[1] := Point(0, 100);
PtArray[2] := Point(100, 100);
PtArray[3] := Point(100, 0);
PtArray[4] := Point(0, 0);
PtCounts[0] := 5;
PtArray[5] := Point(25, 25);
PtArray[6] := Point(25, 75);
PtArray[7] := Point(75, 75);
PtArray[8] := Point(75, 25);
PtArray[9] := Point(25, 25);
PtCounts[1] := 5;
PolyPolygon(Form1.Canvas.Handle, PtArray,PtCounts,2);
end;
Наверх к содержанию
Вопрос: Как создать невизуальный компонент без иконоки, которая изображается в палитре компонентов в "
design-time"
(вроде TField)?
ответ: Невизуальные компоненты без иконоки удобны для субкомпонентов, связанных с какими-то другими компонентами. Создайте компонент как обычно, но используйте RegisterNoIcon вместо RegisterComponent. Наверх к содержанию
Вопрос: Как показывать нестандартный встроенный редактор (inplace editor) в ячейке stringgrid (например combobox).
ответ: См. пример
Пример: procedure TForm1.FormCreate(Sender: TObject);
begin {Высоту combobox'а не изменишь, так что вместо combobox'а будем изменять высоту строки grid'а !} StringGrid1.DefaultRowHeight := ComboBox1.Height;
{Спрятать combobox} ComboBox1.Visible := false;
ComboBox1.Items.Add('Delphi Kingdom');
ComboBox1.Items.Add('Королевство Дельфи');
end;
procedure TForm1.ComboBox1Change(Sender: TObject);
begin {Перебросим выбранное в значение из ComboBox в grid} StringGrid1.Cells[StringGrid1.Col, StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := false;
StringGrid1.SetFocus;
end;
procedure TForm1.ComboBox1Exit(Sender: TObject);
begin {Перебросим выбранное в значение из ComboBox в grid} StringGrid1.Cells[StringGrid1.Col, StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := false;
StringGrid1.SetFocus;
end;
procedure TForm1.StringGrid1SelectCell(Sender: TObject;
ACol, ARow: integer;
var CanSelect: Boolean);
var R: TRect;
begin if ((ACol = 3) AND (ARow <
>
0)) then begin {Ширина и положение ComboBox должно соответствовать ячейке StringGrid} R := StringGrid1.CellRect(ACol, ARow);
R.Left := R.Left + StringGrid1.Left;
R.Right := R.Right + StringGrid1.Left;
R.Top := R.Top + StringGrid1.Top;
R.Bottom := R.Bottom + StringGrid1.Top;
ComboBox1.Left := R.Left + 1;
ComboBox1.Top := R.Top + 1;
ComboBox1.Width := (R.Right + 1) - R.Left;
ComboBox1.Height := (R.Bottom + 1) - R.Top;
{Покажем combobox} ComboBox1.Visible := true;
ComboBox1.SetFocus;
end;
CanSelect := true;
end;
Наверх к содержанию
Вопрос: Как узнать есть ли в заданном CD-ROM'е Audio CD?
ответ: Можно использовать функцию Windows API GetDriveType() чтобы определить является ли дисковод CD-ROM'мом. И функцию API GetVolumeInformation() чтобы проверить VolumeName на равенство 'Audio CD'.
Пример: Function IsAudioCD(Drive : char) : bool;
var DrivePath : string;
MaximumComponentLength : DWORD;
FileSystemFlags : DWORD;
VolumeName : string;
Begin sult := false;
DrivePath := Drive + ':\';
if GetDriveType(PChar(DrivePath)) <
>
DRIVE_CDROM then exit;
SetLength(VolumeName, 64);
GetVolumeInformation(PChar(DrivePath),PChar(VolumeName), Length(VolumeName),nil,MaximumComponentLength,FileSystemFlags,nil,0);
if lStrCmp(PChar(VolumeName),'Audio CD') = 0 then result := true;
end;
Function PlayAudioCD(Drive : char) : bool;
var mp : TMediaPlayer;
begin result := false;
Application.ProcessMessages;
if not IsAudioCD(Drive) then exit;
mp := TMediaPlayer.Create(nil);
mp.Visible := false;
mp.Parent := Application.MainForm;
mp.Shareable := true;
mp.DeviceType := dtCDAudio;
mp.FileName := Drive + ':';
mp.Shareable := true;
mp.Open;
Application.ProcessMessages;
mp.Play;
Application.ProcessMessages;
mp.close;
Application.ProcessMessages;
mp.free;
result := true;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin if not PlayAudioCD('D') then ShowMessage('Not an Audio CD');
end;
Наверх к содержанию
Вопрос: Как узнать есть ли у мыши колесико?
ответ: Свойство "
WheelPresent"
глобального обьекта "
mouse"
. Наверх к содержанию
Вопрос: События KeyPress и KeyDown не вызываются для клавиши Tab - как определить, что она была нажата?
ответ: На уровне формы клавиша tab обычно обрабатывается Windows. В примере создается обработчик события CM_Dialog для перехвата Dialog keys.
Пример: type TForm1 = class(TForm) private procedure CMDialogKey( var msg: TCMDialogKey );
message CM_DIALOGKEY;
end;
var Form1: TForm1;
implementation {$R *.DFM} procedure TForm1.CMDialogKey(var msg: TCMDialogKey);
begin if msg.Charcode <
>
VK_TAB then inherited;
end;
procedure TForm1.FormKeyDown(Sender: TObject;
var key: Word;
Shift: TShiftState);
begin if key = VK_TAB then Form1.Caption := 'Tab key Down!';
end;
Наверх к содержанию
Вопрос: В чем отличие между Create(Self) и Create(Application)?
ответ: Self может быть использовано только в методе класса, и ссылается на текущий экземпляр класса. Таким образом "
Self"
в методе класса TForm1 ссылается на текущий экземпляр TForm1. При создании компонента Вы передаете его владельца (owner) в конструктор. При уничтожении формы или компонента автоматически уничтожаются и все компоненты владельцем которого она является. Таким образом если при создании формы передать в качестве владельца Application эта форма будет автоматически уничтожена при уничтожении Application. Если же при создании формы передать в качестве владельца другую форму, вновь созданная форма будет автоматически уничтоженна при уничтожении формы-владельца. Наверх к содержанию
Вопрос: Как во время выполнения определить поддерживает ли обьект заданное свойство?
ответ: Function HasProperty(Obj : TObject;
Prop : string) : PPropInfo;
begin Result := GetPropInfo(Obj.ClassInfo, Prop);
end;
procedure TForm1.Button1Click(Sender: TObject);
var p : pointer;
begin p := HasProperty(Button1, 'Color');
if p <
>
nil then SetOrdProp(Button1, p, clRed) else ShowMessage('Button has no color property');
p := HasProperty(Label1, 'Color');
if p <
>
nil then SetOrdProp(Label1, p, clRed) else ShowMessage('Label has no color property');
p := HasProperty(Label1.Font, 'Color');
if p <
>
nil then SetOrdProp(Label1.Font.Color, p, clBlue) else ShowMessage('Label.Font has no color property');
end;
Наверх к содержанию
Вопрос: Как при проигрывании музыки с Audio CD показывать сколько прошло минут и секунд?
ответ: В примере время выводится по таймеру.
Пример: uses MMSystem;
procedure TForm1.Timer1Timer(Sender: TObject);
var Trk : Word;
min : Word;
Sec : Word;
begin with MediaPlayer1 do begin Trk := MCI_TMSF_TRACK(Position);
min := MCI_TMSF_MINUTE(Position);
Sec := MCI_TMSF_SECOND(Position);
Label1.Caption := Format('%.2d',[Trk]);
Label2.Caption := Format('%.2d:%.2d',[min,Sec]);
end;
end;
Наверх к содержанию
Вопрос: Можно ли рисовать на рамке формы?
ответ: Обрабатывайте событие WM_NCPAINT. В примере рамка обводится красной линией толщиной в 1 пиксел.
Пример: type TForm1 = class(TForm) private {Private declarations} procedure WMNCPaint(var Msg : TWMNCPaint);
message WM_NCPAINT;
public {Public declarations} end;
var Form1: TForm1;
implementation {$R *.DFM} procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var dc : hDc;
Pen : hPen;
OldPen : hPen;
OldBrush : hBrush;
begin inherited;
dc := GetWindowDC(Handle);
msg.Result := 1;
Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));
OldPen := SelectObject(dc, Pen);
OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
Rectangle(dc, 0,0, Form1.Width, Form1.Height);
SelectObject(dc, OldBrush);
SelectObject(dc, OldPen);
DeleteObject(Pen);
ReleaseDC(Handle, Canvas.Handle);
end;
Наверх к содержанию
Вопрос: Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением?
ответ: Создайте процедуру, которая будет вызываться при событии Application.OnIdle. Обьявим процедуру: {Private declarations} procedure IdleEventHandler(Sender: TObject;
var Done: Boolean);
В разделе implementation опишем поцедуру: procedure TForm1.IdleEventHandler(Sender: TObject;
var Done: Boolean);
begin {do a small bit of work here} Done := false;
end;
В методе Form'ы OnCreate - укажем что наша процедура вызывается на событии Application.OnIdle. Application.OnIdle := IdleEventHandler;
Событие OnIdle возникает один раз - когда приложение переходит в режим "
безделья"
(idle). Если в обработчике переменной Done присвоить false событие будет вызываться вновь и вновь, до тех пор пока приложение "
бездельничает"
и переменной Done не присвоенно значение true. Наверх к содержанию
Вопрос: При перемещении фокуса ввода клавишей Tab чтобы переместить его в RadioGroup нужно нажать клавишу Tab дважды если какой нибудь пункт RadioGroup уже выбран, но только один раз если не выбран. Можно ли сделать поведение RadioGroup логичным?
ответ: Установка свойства RadioGroup'ы TabStop в false должна решить эту проблему - поскольку клавиша tab будет продолжать работать - перемещаясь сразу на выделенный пункт RadioGroup. Наверх к содержанию
Вопрос: Как разместить маленькие картинки в компоненте TPopUpMenu?
ответ: В приведенном примере показано как это сделать с использованием функции Windows API SetMenuItemBitmaps(). Эта функция получает handle popup menu, позицию строчки меню куда будет помещена картинка, и два дескриптора(handles) на две картинки (одна из них - картинка которая будет показана когда строка меню доступна, вторая - когда строка меню недоступна). type TForm1 = class(TForm) PopupMenu1: TPopupMenu;
Pop11: TMenuItem;
Pop21: TMenuItem;
Pop31: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormMouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: integer);
private {Private declarations} bmUnChecked : TBitmap;
bmChecked : TBitmap;
public {Public declarations} end;
var Form1: TForm1;
implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject);
begin bmUnChecked := TBitmap.Create;
bmUnChecked.LoadFromFile('C:\Program Files\Borland\BitBtns\ALARMRNG.BMP');
bmChecked := TBitmap.Create;
bmChecked.LoadFromFile('C:\Program Files\Borland\BitBtns\CHECK.BMP');
{Add the bitmaps to the item at index 1 in PopUpMenu} SetMenuItemBitmaps(PopUpMenu1.Handle,1,MF_BYPOSITION,BmUnChecked.Handle, BmChecked.Handle);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin bmUnChecked.Free;
bmChecked.Free;
end;
procedure TForm1.FormMouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: integer);
var pt : TPoint;
begin pt := ClientToScreen(Point(x, y));
PopUpMenu1.Popup(pt.x, pt.y);
end;
Наверх к содержанию
Вопрос: Как узнать число кадров AVI файла, и выяснить как долго будет проигрывться этот файл?
ответ: В приведенном примере указано как получить эту информацию.
Пример: procedure TForm1.Button1Click(Sender: TObject);
begin MediaPlayer1.TimeFormat := tfFrames;
ShowMessage('Number of frames = ' + IntToStr(MediaPlayer1.Length));
MediaPlayer1.TimeFormat := tfMilliseconds;
ShowMessage('Number of milliseconds = ' + IntToStr(MediaPlayer1.Length));
end;
Наверх к содержанию
Вопрос: Как изменить число фиксированных колонок в TDbGrid?
Пример: procedure TForm1.Button1Click(Sender: TObject);
begin TStringGrid(DbGrid1).FixedCols := 2;
end;
Наверх к содержанию
Вопрос: Некоторые компоненты баз данных (и среди них TDBGrid) никак не меняют визуальных свойств, когда к ним отключен доступ (disabled). Как это изменить програмно?
ответ: Ниже приведен пример, меняющий цвет шрифта на clGray, когда доступ к элементу управления (в данном случае TDBGrid) запрещен (disabled). procedure TForm1.Button1Click(Sender: TObject);
begin DbGrid1.Enabled := false;
DbGrid1.Font.Color := clGray;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin DbGrid1.Enabled := true;
DbGrid1.Font.Color := clBlack;
end;
Наверх к содержанию
Вопрос: Как определить нажаты ли клавиши Shift, Alt, or Ctrl в какой-либо момент времени?
ответ: В приведенном примере показано как определить нажата ли клавиша Shift при выборе строчки меню. Пример также содержит функции проверки состояния клавиш Alt, Ctrl.
Пример: Function CtrlDown : Boolean;
var State : TKeyboardState;
begin GetKeyboardState(State);
Result := ((State[vk_Control] And 128) <
>
0);
end;
Function ShiftDown : Boolean;
var State : TKeyboardState;
begin GetKeyboardState(State);
Result := ((State[vk_Shift] and 128) <
>
0);
end;
Function AltDown : Boolean;
var State : TKeyboardState;
begin GetKeyboardState(State);
Result := ((State[vk_Menu] and 128) <
>
0);
end;
procedure TForm1.MenuItem12Click(Sender: TObject);
begin if ShiftDown then Form1.Caption := 'Shift' else Form1.Caption := '';
end;
Наверх к содержанию
Вопрос: Как изменить шрифта hint'а?
ответ: В примере перехватывается событие Application.OnShowHint и изменяется шрифт Hint'а.
Пример: type TForm1 = class(TForm) procedure FormCreate(Sender: TObject);
private {Private declarations} public procedure MyShowHint(var HintStr: string;
var CanShow: Boolean;
var HintInfo: THintInfo);
{Public declarations} end;
var Form1: TForm1;
implementation {$R *.DFM} procedure TForm1.MyShowHint(var HintStr: string;
var CanShow: Boolean;
var HintInfo: THintInfo);
var i : integer;
begin for i := 0 to Application.ComponentCount - 1 do if Application.Components[i] is THintWindow then with THintWindow(Application.Components[i]).Canvas do begin Font.Name:= 'Arial';
Font.size:= 18;
Font.Style:= [fsBold];
HintInfo.HintColor:= clWhite;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin Application.OnShowHint := MyShowHint;
end;
Наверх к содержанию
Вопрос: Есть ли в Delphi эквивалент функции SendKeys Visual Basic'а?
ответ: Ниже приведена процедура, позволяющаю отправлять нажатия в любой элемент управления (window control), способный принимать ввод с клавиатуры. Вы можете использовать эту технику чтобы включать клавиши NumLock, CapsLock и ScrollLock под Windows NT. Та же техника работает и под Windows 95 для CapsLock и ScrollLock но не работает для клавиши NumLock. Обратите внимание, что приведены четыре поцедуры: SimulateKeyDown() - эмулировать нажатие клавиши (без отпускания) SimulateKeyUp() - эмулировать отпускание клавиши SimulateKeystroke() - эмулировать удар по клавише (нажатие и отпускание) и SendKeys(), позволяющие Вам гибко контролировать посылаемые сообщения клавиатуры. SimulateKeyDown(), SimulateKeyUp() и SimulateKeystroke() получают коды виртуальных клавиш (virtural key) (вроде VK_F1). Процедура SimulateKeystroke() получает дополнительный параметр, полезный при эмуляции нажатия PrintScreen. Когда этот параметр равен нулю весь экран будет скопирован в буфер обмена (clipboard). Если дополнительный параметр равен 1 будет скопированно только активное окно. Четыре метода "
button click"
демонстрируют использование: ButtonClick1 - включает capslock ButtonClick2 - перехватывает весь экран в буфер обмена (clipboard). ButtonClick3 - перехватывает активное окно в буфер обмена (clipboard). ButtonClick4 - устанавливает фокус в Edit и отправляет в него строку.
Пример: procedure SimulateKeyDown(key : byte);
begin keybd_event(key, 0, 0, 0);
end;
procedure SimulateKeyUp(key : byte);
begin keybd_event(key, 0, KEYEVENTF_KEYUP, 0);
end;
procedure SimulateKeystroke(key : byte;
extra : DWORD);
begin keybd_event(key,extra,0,0);
keybd_event(key,extra,KEYEVENTF_KEYUP,0);
end;
procedure SendKeys(s : string);
var i : integer;
flag : bool;
w : word;
begin {Get the state of the caps lock key} flag := not GetKeyState(VK_CAPITAL) and 1 = 0;
{if the caps lock key is on then turn it off} if flag then SimulateKeystroke(VK_CAPITAL, 0);
for i := 1 to Length(s) do begin w := VkKeyScan(s[i]);
{if there is not an error in the key translation} if ((HiByte(w) <
>
$FF) and (LoByte(w) <
>
$FF)) then begin {if the key requires the shift key down - hold it down} if HiByte(w) and 1 = 1 then SimulateKeyDown(VK_SHIFT);
{Send the VK_KEY} SimulateKeystroke(LoByte(w), 0);
{if the key required the shift key down - release it} if HiByte(w) and 1 = 1 then SimulateKeyUp(VK_SHIFT);
end;
end;
{if the caps lock key was on at start, turn it back on} if flag then SimulateKeystroke(VK_CAPITAL, 0);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin {Toggle the cap lock} SimulateKeystroke(VK_CAPITAL, 0);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin {Capture the entire screen to the clipboard} {by simulating pressing the PrintScreen key} SimulateKeystroke(VK_SNAPSHOT, 0);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin {Capture the active window to the clipboard} {by simulating pressing the PrintScreen key} SimulateKeystroke(VK_SNAPSHOT, 1);
end;
procedure TForm1.Button4Click(Sender: TObject);
begin {Set the focus to a window (edit control) and send it a string} Application.ProcessMessages;
Edit1.SetFocus;
SendKeys('Delphi Is RAD!');
end;
Наверх к содержанию
Вопрос: Я загружаю TImageList динамически. Как сделать картинки из TImageList прозрачными?
ответ: См. ответ.
Пример: procedure TForm1.Button1Click(Sender: TObject);
var bm : TBitmap;
il : TImageList;
begin bm := TBitmap.Create;
bm.LoadFromFile('C:\DownLoad\TEST.BMP');
il := TImageList.CreateSize(bm.Width,bm.Height);
il.DrawingStyle := dsTransparent;
il.Masked := true;
il.AddMasked(bm, clRed);
il.Draw(Form1.Canvas, 0, 0, 0);
bm.Free;
il.Free;
end;
Наверх к содержанию
Вопрос: Как заставить TMediaPlayer проигрывать одно и тоже бесконечно? AVI например?
ответ: В примере AVI файл проигрывается снова и снова - используем событие MediaPlayer'а Notify
Пример: procedure TForm1.MediaPlayer1Notify(Sender: TObject);
begin with MediaPlayer1 do if NotifyValue = nvSuccessful then begin Notify := true;
Play;
end;
end;
Наверх к содержанию
Вопрос: При выполнении диалога FontDialog со свойством Device равным fdBoth or fdPrinter, появляется ошибка "
There are no fonts installed"
.
ответ: Эти установки должны показать шрифты совместимые либо с принтером либо с экраном. В примере диалог Windows ChooseFont вызывается напрямую чтобы показать список шрифтов, совместимых одновременно и с экраном и с принтером.
Пример: uses Printers, CommDlg;
procedure TForm1.Button1Click(Sender: TObject);
var cf : TChooseFont;
lf : TLogFont;
tf : TFont;
begin if PrintDialog1.Execute then begin GetObject(Form1.Canvas.Font.Handle, sizeof(lf),@lf);
FillChar(cf, sizeof(cf), #0);
cf.lStructSize := sizeof(cf);
cf.hWndOwner := Form1.Handle;
cf.hdc := Printer.Handle;
cf.lpLogFont := @lf;
cf.iPointSize := Form1.Canvas.Font.size * 10;
cf.Flags := CF_BOTH or CF_INITTOLOGFONTSTRUCT or CF_EFFECTS or CF_SCALABLEONLY or CF_WYSIWYG;
cf.rgbColors := Form1.Canvas.Font.Color;
if ChooseFont(cf) <
>
false then begin tf := TFont.Create;
tf.Handle := CreateFontIndirect(lf);
tf.COlor := cf.RgbColors;
Form1.Canvas.Font.Assign(tf);
tf.Free;
Form1.Canvas.TextOut(10, 10, 'Test');
end;
end;
end;
Наверх к содержанию
Вопрос: Как сменить дисковод, откуда MediaPlayer проигрывает аудио CD?
ответ: См. пример.
Пример: MediaPlayer1.FileName := 'E:';
Наверх к содержанию
Вопрос: Как убрать кнопку с названием моей программы из Панели Задач(Taskbar)?
ответ: Отредактируйте файл-проекта (View ->
Project Source) Добавьте модуль Windows в раздел uses. Application.ShowMainForm := false;
в строку после "
Application.Initialize;
"
. Добавьте ShowWindow(Application.Handle, SW_HIDE);
в строку перед "
Application.Run;
"
Ваш файл проекта должен выглядеть приблизительно так: program Project1;
uses Windows, Forms, Unit1 in 'Unit1.pas' {Form1}, Unit2 in 'Unit2.pas' {Form2};
{$R *.RES} begin Application.Initialize;
Application.ShowMainForm := false;
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);
ShowWindow(Application.Handle, SW_HIDE);
Application.Run;
end. В разделе "
initialization"
(в самом низу) каждого unit'а добавьте begin ShowWindow(Application.Handle, SW_HIDE);
end. Наверх к содержанию
Вопрос: Как преобразовать цвета в строку - название цвета VCL?
ответ: Модуль graphics.pas содержит функцию ColorToString() которое преобразует допустимое значение TColor в его строковое представление используя либо константу-название цвета (по возможности) либо шестнадцатиричную строку. Обратная функция - StringToColor()
Пример: procedure TForm1.Button1Click(Sender: TObject);
begin Memo1.Lines.Add(ColorToString(clRed));
Memo1.Lines.Add(IntToStr(StringToColor('clRed')));
end;
Наверх к содержанию
Вопрос: При показе максимизированное формы она перекрывает task bar и не выравнивается по верху экрана. В чем тут дело?
ответ: Это может произойти когда свойство position формы установленно в poScreenCenter. Установите position = poDefault. Наверх к содержанию
Вопрос: Как заставить TEdit не 'пикать' при нажатии недопустимых клавиш?
ответ: Перехватите событие KeyPress и установите key = #0 для недопустимых клавиш.
Пример: procedure TForm1.Edit1KeyPress(Sender: TObject;
var key: Char);
begin if ((UpCase(key) <
'A') or (UpCase(key) >
'Z')) then key := #0;
end;
Наверх к содержанию
Вопрос: Как получить число и список всех компонентов, расположенных на TNoteBook?
ответ: В примере список выводится на Listbox.
Пример: procedure TForm1.Button1Click(Sender: TObject);
var n: integer;
p: integer;
begin ListBox1.Clear;
with Notebook1 do begin for n := 0 to ControlCount - 1 do begin with TPage(Controls[n]) do begin ListBox1.Items.Add('Notebook Page: ' + TPage(Notebook1.Controls[n]).Caption);
for p := 0 to ControlCount - 1 do ListBox1.Items.Add(Controls[p].Name);
ListBox1.Items.Add(EmptyStr);
end;
end;
end;
end;
Наверх к содержанию
Вопрос: Я хочу вставить escape code в строку при использовании функции Format(). Например, я хочу создать строку, содержащую символ табуляции. В "
C"
я бы написал что-то вроде sprintf(buffer, "
%s\t%s"
, str);
. А как это будет на Pascal'e?
ответ: Функция Format Pascal'я не использует escape codes. Вместо этого нужно вставить в строку действительное значение символа в кодировке ASCII.
Пример: Buffer := Format('%s'#9'%s', [Str1, Str2]);
ShowMessage(Format('%s'#9'%s', ['Column1', 'Column2']));
Наверх к содержанию
Вопрос: Как показать первый кадр AVI-файла?
ответ: См. пример.
Пример: procedure TForm1.Button1Click(Sender: TObject);
begin Application.ProcessMessages;
MediaPlayer1.Open;
Application.ProcessMessages;
MediaPlayer1.Step;
Application.ProcessMessages;
MediaPlayer1.Previous;
end;
Наверх к содержанию
Вопрос: Когда пользователь щелкает по listview, он переходит в режим редактирования. Как перевисти его в редим редактирования по нажатию клавиши (например F2)?
ответ: Перехватите F2 на событии keydown.
Пример: procedure TForm1.ListView1KeyDown(Sender: TObject;
var key: Word;
Shift: TShiftState);
begin if ord(key) = VK_F2 then ListView1.Selected.EditCaption;
end;
Наверх к содержанию
Вопрос: Когда я добавляю обьект в список TStrings как мне его потом уничтожить?
ответ: Просто вызовите метод free этого обьекта.
Пример: procedure TForm1.FormCreate(Sender: TObject);
var Icon: TIcon;
begin Icon := TIcon.Create;
Icon.LoadFromFile('C:\Program Files\BorlandImages\CONSTRUC.ICO');
ListBox1.Items.AddObject('Item 0', Icon);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin ListBox1.Items.Objects[0].Free;
end;
Наверх к содержанию
Вопрос: Вместо печати графики я хочу использовать резидентный шрифт принтера. Как?
ответ: Используте функцию Windows API - GetStockObject() чтобы получить дескриптор (handle) шрифта по умолчанию устройства (DEVICE_DEFAULT_FONT) и передайте его Printer.Font.Handle.
Пример: uses Printers;
procedure TForm1.Button1Click(Sender: TObject);
var tm : TTextMetric;
i : integer;
begin if PrintDialog1.Execute then begin Printer.BeginDoc;
Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT);
GetTextMetrics(Printer.Canvas.Handle, tm);
for i := 1 to 10 do begin Printer.Canvas.TextOut(100,i * tm.tmHeight + tm.tmExternalLeading,'Test');
end;
Printer.EndDoc;
end;
end;
Наверх к содержанию
Вопрос: Мне нужно программно установить некоторые файлы с установочного диска Windows. На многих компьютерах CAB-файлы установки Windows находятся в каком-то каталоге на жестком диске, на других - Windows был установлен с CD. Как узнать откуда была установленна Windows?
ответ: Эту информацию можно получить из реестра.
Пример: uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var reg: TRegistry;
begin reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\SETUP',false);
ShowMessage(reg.ReadString('SourcePath'));
reg.CloseKey;
reg.free;
end;
Наверх к содержанию
Вопрос: Как получить строку сообщения об ошибке Windows код которой получен функцией GetLastError?
ответ: Функция RTL SysErrorMessage(GetLastError).
Пример: procedure TForm1.Button1Click(Sender: TObject);
begin {Cause a Windows system error message to be logged} ShowMessage(IntToStr(lStrLen(nil)));
ShowMessage(SysErrorMessage(GetLastError));
end;
Наверх к содержанию
Вопрос: Как заставить Delphi выполнять еще более строгую проверка типов? Напрмер - я создаю пользовательский тип, унаследованный от double и могу передавать его любым функциям, принимающим параметр типа double. Как заставить компилятор проводить более строгую проверку типов и выдавать предупреждение в таких случаях?
ответ: См.
ответ.
Пример: type TStrongType = type double;
type TWeakType = double;
procedure AddWeakType(var d : TWeakType);
begin d := d + 1;
end;
procedure AddStrongType(var d : TStrongType);
begin d := d + 1;
end;
procedure AddDoubleType(var d : double);
begin d := d + 1;
end;
procedure TForm1.Button1Click(Sender: TObject);
var d : double;
s : TStrongType;
w : TWeakType;
begin AddDoubleType(d);
{compiles fine} AddDoubleType(w);
{compiles fine} AddDoubleType(s);
{<
- compile error} AddDoubleType(double(s));
{compiles fine} AddWeakType(d);
{compiles fine} AddWeakType(w);
{compiles fine} AddWeakType(s);
{<
- compile error} AddWeakType(TWeakType(s));
{compiles fine} AddStrongType(d);
{<
- compile error} AddStrongType(TStrongType(d));
{compiles fine} AddStrongType(w);
{<
- compile error} AddStrongType(TStrongType(w));
{compiles fine} AddStrongType(s);
{compiles fine} end;
Наверх к содержанию
Вопрос: Где в Delphi обьявленны VK_Key для A-Z и 0-9?
ответ: Они не обьявлены в Delphi поскольку они просто могуть быть заменены буквами. VK_0 до VK_9 то же что и ASCII '0' до '9' ($30 - $39), VK_A до VK_Z то же что и ASCII 'A' до 'Z' ($41 - $5A). Наверх к содержанию
Вопрос: Как изменить оконную процедуру для TForm?
ответ: Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере оконная процедура переопределяется для того чтобы реагировать на сообщение WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо еще диалог.
Пример: type TForm1 = class(TForm) Button1: TButton;
procedure WndProc (var Message: TMessage);
override;
procedure Button1Click(Sender: TObject);
private {Private declarations} public {Public declarations} end;
var Form1: TForm1;
implementation {$R *.DFM} procedure TForm1.WndProc (var Message: TMessage);
begin if Message.Msg = WM_CANCELMODE then begin Form1.Caption := 'A dialog or message box has popped up';
end else inherited // <
- остальное сделает родительская процедура end;
procedure TForm1.Button1Click(Sender: TObject);
begin ShowMessage('Test Message');
end;
Наверх к содержанию
Вопрос: Как узнать размеры TComboBox с показанным выпадающим списком до показа списка?
ответ: На событии FormShow пошлите сообщение CB_SHOWDROPDOWN в ComboBox дважды - один раз чтобы заставить список выпасть, второй - чтобы убрать его. Затем пошлите сообщение CB_GETDROPPEDCONTROLRECT, передав в качестве параметра адрес TRect. TRect будет содержать экранные кординаты прямоугольника описывающего ComboBox вместе с выпавшим списком. Затем Вы можете вызвать ScreenToClient чтобы преобразовать экранные кординаты в координаты клиентской области окна.
Пример: var R : TRect;
procedure TForm1.FormShow(Sender: TObject);
var T : TPoint;
begin SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 1, 0);
SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 0, 0);
SendMessage(ComboBox1.Handle, CB_GETDROPPEDCONTROLRECT, 0, LongInt(@r));
t := ScreenToClient(Point(r.Left, r.Top));
r.Left := t.x;
r.Top := t.y;
t := ScreenToClient(Point(r.Right, r.Bottom));
r.Right := t.x;
r.Bottom := t.y;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin Form1.Canvas.Rectangle(r.Left, r.Top, r.Right, r.Bottom );
end;
Наверх к содержанию
Вопрос: Я хочу создать в своей программе меню "
а ля Дельфи 4"
. Как это сделать?
ответ: 1. Разместите на форме TControlBar. (закладка Additional) Установите Align = Client. 2. Разместите TToolBar (закладка Win32) внутри TControlBar. 3. Установите в true свойства Flat и ShowCaptions этого TToolBar. 4. Создайте на TToolBar столько TToolButtons сколько Вам нужно. (щелкнув по TToolBar правой кнопкой и выбрав NewButton) 5. Установите свойство Grouped = true для всех TToolButtons. Это позволит меню выпадать при перемещении курсора между главными пунктами меню (если меню уже показано). 6. Разместите на фоме TMainMenu и убедитесь, что оно *НЕ присоденено* как меню главной формы. (посмотрите свойство Menu формы). 7. Создайте все пункты меню (щелкнув по TMainMenu кнопкой и выбрав Menu Designer) 8. Для каждой TToolButton установите ее MenuItem равным со
ответсвующему пункту TMainMenu. Наверх к содержанию
Вопрос: Как добится того чтобы TMemo и TEdit имели работали не только в режиме вставки символов, но и в режиме замены?
ответ: Элементы управления Windows TEdit и TMemo не имеют режима замены. Однако этот режим можно эмулировать установив свойство SelLength edit'а или memo в 1 при обработке события KeyPress. Это заставит его перезаписывать символ в текущей позиции курсора. В примере этот способ используется для TMemo. Режим вставка/замена переключается клавишей "
Insert"
.
Пример: type TForm1 = class(TForm) Memo1: TMemo;
procedure Memo1KeyDown(Sender: TObject;
var key: Word;
Shift: TShiftState);
procedure Memo1KeyPress(Sender: TObject;
var key: Char);
private {Private declarations} InsertOn : bool;
public {Public declarations} end;
var Form1: TForm1;
implementation {$R *.DFM} procedure TForm1.Memo1KeyDown(Sender: TObject;
var key: Word;
Shift: TShiftState);
begin if (key = VK_INSERT) and (Shift = []) then InsertOn := not InsertOn;
end;
procedure TForm1.Memo1KeyPress(Sender: TObject;
var key: Char);
begin if ((Memo1.SelLength = 0) and (not InsertOn)) then Memo1.SelLength := 1;
end;
Наверх к содержанию
Вопрос: Как отправить сообщение сразу всем элементам управления формы?
ответ: Можно использовать Screen.Forms[i].BroadCast(msg);
где [i] - индекс той формы, которой Вы хотите переслать сообщение. BroadCast работает со всеми компонентами, потомками TWinControls и отправляет сообщение всем дочерним компонентам из массива Controls. Если один из дочерних компонентов обрабатывает это сообщение и устанавливает Msg.Result в ненулевое значение - дальнейшая рассылка сообщения останавливается. Наверх к содержанию
Вопрос: При попытке присвоить значение свойству "
selected"
ListBox'а вырабатывается exception "
Index is out of bounds"
. В чем тут дело и как присвоить значение свойству selected?
ответ: Свойство "
selected"
компонента ТListBox может быть использованно только если свойство MultiSelect установленно в true. Если Вы работаете с ListBox'ом у которого MultiSelect=false то используйте свойство ItemIndex.
Пример: procedure TForm1.Button1Click(Sender: TObject);
begin ListBox1.Items.Add('1');
ListBox1.Items.Add('2');
{This will fail on a single selection ListBox} // ListBox1.Selected[1] := true;
ListBox1.ItemIndex := 1;
{This is ok} end;
Наверх к содержанию
Вопрос: Как ограничить длинну текста, вводимого в TEdit, так чтобы ширина текста не превышала ширину TEdit'а?
ответ: В примере приведено два способа ограничить длинну текста в TEdit так чтобы она не превышала ширину клиентской области окна TEdit'а и не появлялась прокрутка текста. Первый способ устанавливает свойство TEdit'а MaxLength равным числу букв "
W"
, которые поместятся в TEdit. "
W"
выбрана потому, что является, наверное, самой широкой буквой в любом шрифте. Этот метод сносно работает для шрифтов с фиксированной шириной букв, но для шрифтов с переменной шириной букв вряд ли сгодится. Второй способ перхватывает событие KeyPress TEdit'а и измеряет ширину уже введенного текста и ширину нового символа. Если ширина больше чем клиентская область TEdit'а новый символ отбрасывается и вызывается MessageBeep.
Пример: procedure TForm1.FormCreate(Sender: TObject);
var cRect : TRect;
bm : TBitmap;
s : string;
begin Windows.GetClientRect(Edit1.Handle, cRect);
bm := TBitmap.Create;
bm.Width := cRect.Right;
bm.Height := cRect.Bottom;
bm.Canvas.Font := Edit1.Font;
s := 'W';
while bm.Canvas.TextWidth(s) <
CRect.Right do s := s + 'W';
if length(s) >
1 then begin delete(s, 1, 1);
Edit1.MaxLength := Length(s);
end;
end;
{Другой вариант} procedure TForm1.Edit1KeyPress(Sender: TObject;
var key: Char);
var cRect : TRect;
bm : TBitmap;
begin if ((ord(key) <
>
VK_TAB) and (ord(key) <
>
VK_RETURN) and (ord(key) <
>
VK_LEFT) and (ord(key) <
>
VK_BACK)) then begin Windows.GetClientRect(Edit1.Handle, cRect);
bm := TBitmap.Create;
bm.Width := cRect.Right;
bm.Height := cRect.Bottom;
bm.Canvas.Font := Edit1.Font;
if bm.Canvas.TextWidth(Edit1.Text + key) >
CRect.Right then begin key := #0;
MessageBeep(-1);
end;
bm.Free;
end;
end;
Наверх к содержанию
Вопрос: Как сохранить обьект TFont в реестре/ini/файле/таблице базы данных?
ответ: Нужно сохранять атрибуты шрифта (имя, размер и т.п.) а не сам обьект TFont. После считывания этой информации следует проверить существует ли такой шрифт, прежде чем его использовать. Чтобы не показаться голословным дополню
ответ Borland'а своим примером сохранения/чтения шрифта в/из реестра Uses ... Registry;
procedure SaveFontToRegistry(Font : TFont;
SubKey : string);
var R : TRegistry;
FontStyleInt : byte;
FS : TFontStyles;
begin R:=TRegistry.Create;
try FS:=Font.Style;
Move(FS,FontStyleInt,1);
R.OpenKey(SubKey,true);
R.WriteString('Font Name',Font.Name);
R.WriteInteger('Color',Font.Color);
R.WriteInteger('CharSet',Font.Charset);
R.WriteInteger('size',Font.size);
R.WriteInteger('Style',FontStyleInt);
finally R.Free;
end;
end;
Function ReadFontFromRegistry(Font : TFont;
SubKey : string) : boolean;
var R : TRegistry;
FontStyleInt : byte;
FS : TFontStyles;
begin R:=TRegistry.Create;
try result:=R.OpenKey(SubKey,false);
if not result then exit;
Font.Name:=R.ReadString('Font Name');
Font.Color:=R.ReadInteger('Color');
Font.Charset:=R.ReadInteger('CharSet');
Font.size:=R.ReadInteger('size');
FontStyleInt:=R.ReadInteger('Style');
Move(FontStyleInt,FS,1);
Font.Style:=FS;
finally R.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin if FontDialog1.Execute then begin SaveFontToRegistry(FontDialog1.Font,'Delphi Kingdom\Fonts');
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var NFont : TFont;
begin NFont:=TFont.Create;
if ReadFontFromRegistry(NFont,'Delphi Kingdom\Fonts') then begin //здесь добавить проверку - существует ли шрифт Label1.Font.Assign(NFont);
NFont.Free;
end;
end;
Наверх к содержанию
Вопрос: Как перемещать компонент мышкой во время работы программы "
runtime"
?
ответ: Перехватить событие OnMouseDown, запомнить x и y координты курсора мыши. Отслеживать движение мыши по событию OnMouseMove и перемещать компонент вслед за курсором мыши до тех пор пока не произойдет событие OnMouseUp. В примере показано перемещение компонента TButton. Перемещение начинается, когда пользователь "
берет"
TButton мышью, удерживая нажатой клавишу "
Сontrol"
.
Пример: type TForm1 = class(TForm) Button1: TButton;
procedure Button1MouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: integer);
procedure Button1MouseMove(Sender: TObject;
Shift: TShiftState;
X, Y: integer);
procedure Button1MouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: integer);
private {Private declarations} public {Public declarations} MouseDownSpot : TPoint;
Capturing : bool;
end;
var Form1: TForm1;
implementation {$R *.DFM} procedure TForm1.Button1MouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: integer);
begin if ssCtrl in Shift then begin SetCapture(Button1.Handle);
Capturing := true;
MouseDownSpot.X := x;
MouseDownSpot.Y := Y;
end;
end;
procedure TForm1.Button1MouseMove(Sender: TObject;
Shift: TShiftState;
X, Y: integer);
begin if Capturing then begin Button1.Left := Button1.Left - (MouseDownSpot.x - x);
Button1.Top := Button1.Top - (MouseDownSpot.y - y);
end;
end;
procedure TForm1.Button1MouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: integer);
begin if Capturing then begin ReleaseCapture;
Capturing := false;
Button1.Left := Button1.Left - (MouseDownSpot.x - x);
Button1.Top := Button1.Top - (MouseDownSpot.y - y);
end;
end;
Наверх к содержанию
Вопрос: При попытке создать обьект класса TPrinter (TPrinter.Create) я получаю exception. Почему?
ответ: В создании обьекта класса TPrinter с использованием TPrinter.Create нет необходимости, так как обьект класса TPrinter (называемый Printer) автоматически создается при использовании модуля Printers.
Пример: uses Printers;
procedure TForm1.Button1Click(Sender: TObject);
begin Printer.BeginDoc;
Printer.Canvas.TextOut(100, 100, 'Hello World!');
Printer.EndDoc;
end;
Наверх к содержанию
Вопрос: Как перехватить события в неклиентской области формы, в заголовке окна, например?
ответ: Создайте обработчик одного из сообщений WM_NC (non client - не клиентских) (посмотрите WM_NC в Windows API help). Пример показывает как перехватить вижение мыши во всей неклиенстской области окна (рамка и заголовок).
Пример: unit Unit1;
interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type TForm1 = class(TForm) private {Private declarations} procedure WMNCMOUSEMOVE(var Message: TMessage);
message WM_NCMOUSEMOVE;
public {Public declarations} end;
var Form1: TForm1;
implementation {$R *.DFM} procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage);
var s : string;
begin case Message.wParam of HTERROR: s:= 'HTERROR';
HTTRANSPARENT: s:= 'HTTRANSPARENT';
HTNOWHERE: s:= 'HTNOWHERE';
HTCLIENT: s:= 'HTCLIENT';
HTCAPTION: s:= 'HTCAPTION';
HTSYSMENU: s:= 'HTSYSMENU';
HTSIZE: s:= 'HTSIZE';
HTMENU: s:= 'HTMENU';
HTHSCROLL: s:= 'HTHSCROLL';
HTVSCROLL: s:= 'HTVSCROLL';
HTMINBUTTON: s:= 'HTMINBUTTON';
HTMAXBUTTON: s:= 'HTMAXBUTTON';
HTLEFT: s:= 'HTLEFT';
HTRIGHT: s:= 'HTRIGHT';
HTTOP: s := 'HTTOP';
HTTOPLEFT: s:= 'HTTOPLEFT';
HTTOPRIGHT: s:= 'HTTOPRIGHT';
HTBOTTOM: s:= 'HTBOTTOM';
HTBOTTOMLEFT: s:= 'HTBOTTOMLEFT';
HTBOTTOMRIGHT: s:= 'HTBOTTOMRIGHT';
HTBORDER: s:= 'HTBORDER';
HTOBJECT: s:= 'HTOBJECT';
HTCLOSE: s:= 'HTCLOSE';
HTHELP: s:= 'HTHELP';
else s:= '';
end;
Form1.Caption := s;
Message.Result := 0;
end;
end. Наверх к содержанию
Вопрос: При попытке использовать метод TCanvas.StretchDraw чтобы нарисовать иконку увеличенной ее размер не изменяется. Что делать?
ответ: Иконки всегда рисуются размером принятым в системе по умолчанию. Чтобы показать увеличенный вид иконки скоприуйте ее на bitmap, а зате используйте метод TCanvas.StretchDraw.
Пример: procedure TForm1.Button1Click(Sender: TObject);
var TheBitmap : TBitmap;
begin TheBitmap := TBitmap.Create;
TheBitmap.Width := Application.Icon.Width;
TheBitmap.Height := Application.Icon.Height;
TheBitmap.Canvas.Draw(0, 0, Application.Icon);
Form1.Canvas.StretchDraw(Rect(0,0,TheBitmap.Width * 3,TheBitmap.Height * 3), TheBitmap);
TheBitmap.Free;
end;
Наверх к содержанию
Вопрос: Можно ли сделать так чтобы TStringGrid автоматически изменял ширину колонок, чтобы вместить самую длинную строчку в колонке?
ответ: См. пример.
Пример: procedure AutoSizeGridColumn(Grid : TStringGrid;
column : integer);
var i : integer;
temp : integer;
max : integer;
begin max := 0;
for i := 0 to (Grid.RowCount - 1) do begin temp := Grid.Canvas.TextWidth(grid.cells[column, i]);
if temp >
max then max := temp;
end;
Grid.ColWidths[column] := max + Grid.GridLineWidth + 3;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin AutoSizeGridColumn(StringGrid1, 1);
end;
Наверх к содержанию
Вопрос: TTimer работает не достаточно точно. Как получить более высокую точность?
ответ: Таймер Windows не был создан с целью получения сверхточного хронометра. :-( Другими словами, когда Вы устанавливаете таймер на срабатывания каждые 1000 миллисекунд, он может срабатывать через интервал несколько больший чем 1000 миллисекунд. Значения меньше 55 миллисекунд никогда не будут срабатывать вовремя в Windows, поскольку это минимальная точность таймера. Можно проверять системное время и сравнивать его со временем предыдущего события таймера чтобы повысить точность. Наверх к содержанию
Вопрос: Как поместить JPEG-картинку в exe-файл и потом загрузить ее?
ответ: 1) Создайте текстовый файл с расширением "
.rc"
. Имя этого файла должно отличаться от имени файла-пректа или любого модуля проекта. Файл должен содержать строку вроде: MYJPEG JPEG C:\DownLoad\MY.JPG где: "
MYJPEG"
имя ресурса "
JPEG"
пользовательский тип ресурса "
C:\DownLoad\MY.JPG"
руть к JPEG файлу. Пусть например rc-файл называется "
foo.rc"
Запустите BRCC32.exe (Borland Resource CommandLine Compiler) - программа находится в каталоге Bin Delphi/C++ Builder'а - передав ей в качестве параметра полный путь к rc-файлу. В нашем примере: C:\DelphiPath\BIN\BRCC32.EXE C:\ProjectPath\FOO.RC Вы получите откомпилированный ресурс - файл с расширением "
.res"
. (в нашем случает foo.res). Далее добавте ресурс к своему приложению. {Грузим ресурс} {$R FOO.RES} uses Jpeg;
procedure LoadJPEGFromRes(TheJPEG : string;
ThePicture : TPicture);
var ResHandle : THandle;
MemHandle : THandle;
MemStream : TMemoryStream;
ResPtr : PByte;
ResSize : Longint;
JPEGImage : TJPEGImage;
begin ResHandle := FindResource(hInstance, PChar(TheJPEG), 'JPEG');
MemHandle := LoadResource(hInstance, ResHandle);
ResPtr := LockResource(MemHandle);
MemStream := TMemoryStream.Create;
JPEGImage := TJPEGImage.Create;
ResSize := SizeOfResource(hInstance, ResHandle);
MemStream.SetSize(ResSize);
MemStream.write(ResPtr^, ResSize);
FreeResource(MemHandle);
MemStream.Seek(0, 0);
JPEGImage.LoadFromStream(MemStream);
ThePicture.Assign(JPEGImage);
JPEGImage.Free;
MemStream.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin LoadJPEGFromRes('MYJPEG', Image1.Picture);
end;
Наверх к содержанию
Вопрос: Как перехватить сообщения прокрутки в TScrollBox?
ответ: Следующий пример перехватывает сообщения о прокрутке компонента TScrollBox и синхронизирует обе линейки прокрутки. Сообщения прокрутки перехватываются с помощью переопределения окнной процедуры (WinProc) ScrollBox'а.
Пример: type {$IFDEF WIN32} WParameter = LongInt;
{$else} WParameter = Word;
{$endif} LParameter = LongInt;
{Declare a variable to hold the window procedure we are replacing} var OldWindowProc : Pointer;
Function NewWindowProc(WindowHandle : hWnd;
TheMessage : WParameter;
ParamW : WParameter;
ParamL : LParameter) : LongInt {$IFDEF WIN32} stdcall;
{$else} ;
export;
{$endif} var TheRangeMin : integer;
TheRangeMax : integer;
TheRange : integer;
begin if TheMessage = WM_VSCROLL then begin {Get the min and max range of the horizontal scroll box} GetScrollRange(WindowHandle, SB_HORZ, TheRangeMin, TheRangeMax);
{Get the vertical scroll box position} TheRange := GetScrollPos(WindowHandle, SB_VERT);
{Make sure we wont exceed the range} if TheRange <
TheRangeMin then TheRange := TheRangeMin else if TheRange >
TheRangeMax then TheRange := TheRangeMax;
{Set the horizontal scroll bar} SetScrollPos(WindowHandle, SB_HORZ, TheRange, true);
end;
if TheMessage = WM_HSCROLL then begin {Get the min and max range of the horizontal scroll box} GetScrollRange(WindowHandle, SB_VERT, heRangeMin, TheRangeMax);
{Get the horizontal scroll box position} TheRange := GetScrollPos(WindowHandle, SB_HORZ);
{Make sure we wont exceed the range} if TheRange <
TheRangeMin then TheRange := TheRangeMin else if TheRange >
TheRangeMax then TheRange := TheRangeMax;
{Set the vertical scroll bar} SetScrollPos(WindowHandle, SB_VERT, TheRange, true);
end;
{Call the old Window procedure to allow processing of the message.} NewWindowProc := CallWindowProc(OldWindowProc, WindowHandle, TheMessage, ParamW, ParamL);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin {Set the new window procedure for the control and remember the old window procedure.} OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(@NewWindowProc)));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin {Set the window procedure back to the old window procedure.} SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(OldWindowProc));
end;
Наверх к содержанию
Вопрос: Как сделать прямоугольник для выделения части картинки для редактирования?
ответ: Самый простой способ - воспользоваться функцией Windows API DrawFocusRect. Функция DrawFocusRect использует операцию XOR при рисовании - таким образом вывод прямоугольника дважды с одними и теми же координатами стирает прямоугольник, и прямоугольник всегда будет виден, на фоне какого бы цвета он не выводился.
Пример: type TForm1 = class(TForm) procedure FormMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: integer);
procedure FormMouseMove(Sender: TObject;
Shift: TShiftState;
X, Y: integer);
procedure FormMouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: integer);
private {Private declarations} Capturing : bool;
Captured : bool;
StartPlace : TPoint;
EndPlace : TPoint;
public {Public declarations} end;
var Form1: TForm1;
implementation {$R *.DFM} Function MakeRect(Pt1 : TPoint;
Pt2 : TPoint) : TRect;
begin if pt1.x <
pt2.x then begin Result.Left := pt1.x;
Result.Right := pt2.x;
end else begin Result.Left := pt2.x;
Result.Right := pt1.x;
end;
if pt1.y <
pt2.y then begin Result.Top := pt1.y;
Result.Bottom := pt2.y;
end else begin Result.Top := pt2.y;
Result.Bottom := pt1.y;
end;
end;
procedure TForm1.FormMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: integer);
begin if Captured then DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
StartPlace.x := X;
StartPlace.y := Y;
EndPlace.x := X;
EndPlace.y := Y;
DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
Capturing := true;
Captured := true;
end;
procedure TForm1.FormMouseMove(Sender: TObject;
Shift: TShiftState;
X, Y: integer);
begin if Capturing then begin DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
EndPlace.x := X;
EndPlace.y := Y;
DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
end;
end;
procedure TForm1.FormMouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: integer);
begin Capturing := false;
end;
Наверх к содержанию
Вопрос: Можно ли использовать иконку как картинку на кнопке TSpeedButton?
ответ: Можно. См. пример.
Пример: uses ShellApi;
procedure TForm1.FormShow(Sender: TObject);
var Icon: TIcon;
begin Icon := TIcon.Create;
Icon.Handle := ExtractIcon(0,'C:\WINDOWS\NOTEPAD.EXE',1);
SpeedButton1.Glyph.Width := Icon.Width;
SpeedButton1.Glyph.Height := Icon.Height;
SpeedButton1.Glyph.Canvas.Draw(0, 0, Icon);
Icon.Free;
end;
Наверх к содержанию
Вопрос: Как поместить прозрачную фоновую каринку на компонент CoolBar?
ответ: procedure TForm1.Button1Click(Sender: TObject);
var Bm1 : TBitmap;
Bm2 : TBitmap;
begin Bm1 := TBitmap.Create;
Bm2 := TBitmap.Create;
Bm1.LoadFromFile('c:\download\test.bmp');
Bm2.Width := Bm1.Width;
Bm2.Height := Bm1.Height;
bm2.Canvas.Brush.Color := CoolBar1.Color;
bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1, Rect(0, 0, Bm1.width, Bm1.Height), ClWhite);
bm1.Free;
CoolBar1.Bitmap.Assign(bm2);
bm2.Free;
end;
Наверх к содержанию
Вопрос: Ползунок компонента TScrollBar все время мигает. Как это отключить?
ответ: Установите свойтсво ScrollBar.TabStop в false. Наверх к содержанию
Вопрос: Как программно перевести DBgrid в реим редактирования и установить курсор в окошке редактирования в требуемую позицию?
ответ: Переведите таблицу в режим редактирования, затем получите дескриптор (handle) окна редактирования и перешлите ей сообщение EM_SETSEL. В качестве параметров вы должны переслать начальную позицию курсора, и конечную позицию, определяющую конец выделения текста цветом. В приведенном примере курсор помещается во вторую позицию, текст внутри ячейки не выделяется.
Пример: procedure TForm1.Button1Click(Sender: TObject);
var h : THandle;
begin Application.ProcessMessages;
DbGrid1.SetFocus;
DbGrid1.EditorMode := true;
Application.ProcessMessages;
h:= Windows.GetFocus;
SendMessage(h, EM_SETSEL, 2, 2);
end;
Наверх к содержанию
Вопрос: Как поместить курсор в определенную позицию edit'а и подобных ему элементов управления?
ответ: Можно использовать методы Delphi SelStart() и SelectLength().
Пример: procedure TForm1.Button1Click(Sender: TObject);
begin Edit1.SetFocus;
{переводим курсор во вторую позицию} Edit1.SelStart := 2;
{не выделяем никакого текста} Edit1.SelLength := 0;
end;
Наверх к содержанию
Вопрос: Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение размера формы?
ответ: В примере перехватывается сообщение WM_SYSCOMMAND. Если это сообщение говорит о минимизации или максимизации формы - пищит динамик.
Пример: type TForm1 = class(TForm) private {Private declarations} procedure WMSysCommand(var Msg: TWMSysCommand);
message WM_SYSCOMMAND;
public {Public declarations} end;
var Form1: TForm1;
implementation {$R *.DFM} procedure TForm1.WMSysCommand;
begin if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then MessageBeep(0) else inherited;
end;
Наверх к содержанию
Вопрос: Можно ли сделать так - одна форма показывает другую и остается позади нее, но фокус ввода не переходит к новой форме, а остается у старой?
ответ: В примере показывается не автосоздаваемая (non auto-created) форма, но фокус ввода ей не передается.
Пример: uses Unit2;
procedure TForm1.Button1Click(Sender: TObject);
begin Form2 := TForm2.Create(Application);
Form2.Visible := false;
ShowWindow(Form2.Handle, SW_SHOWNA);
end;
Наверх к содержанию
Вопрос: На некоторых laptop компьютерах может не быть флоппи дисковода. Можно ли удалять из списка TDriveComboBox диски которые отключены?
ответ: В примере TDriveComboBox не показывает дисководы, которые не готовы. (not ready). Учтите что на многих компьютерах будет ощутимая задержка при поверке plug&
play флоппи дисковода.
Пример: procedure TForm1.FormCreate(Sender: TObject);
var i : integer;
OldErrorMode : Word;
OldDirectory : string;
begin OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
GetDir(0, OldDirectory);
i := 0;
while i <
= DriveComboBox1.Items.count - 1 do begin {$I-} chdir(DriveComboBox1.Items[i][1] + ':\');
{$I+} if IoResult <
>
0 then DriveComboBox1.Items.delete(i) else inc(i);
end;
chdir(OldDirectory);
SetErrorMode(OldErrorMode);
end;
Наверх к содержанию
Вопрос: Как сообщить всем формам моего приложения (в том числе и не видимым в данный момент) об изминении каких-то глобальных значений?
ответ: Один из способов - создать пользовательское сообщение и использовать метод preform чтобы разослать его всем формам из массива Screen.Forms.
Пример: {Code for Unit1} const UM_MyGlobalMessage = WM_USER + 1;
type TForm1 = class(TForm) Label1: TLabel;
Button1: TButton;
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
private {Private declarations} procedure UMMyGlobalMessage(var AMessage: TMessage);
message UM_MyGlobalMessage;
public {Public declarations} end;
var Form1: TForm1;
implementation {$R *.DFM} uses Unit2;
procedure TForm1.FormShow(Sender: TObject);
begin Form2.Show;
end;
procedure TForm1.UMMyGlobalMessage(var AMessage: TMessage);
begin Label1.Left := AMessage.WParam;
Label1.Top := AMessage.LParam;
Form1.Caption := 'Got It!';
end;
procedure TForm1.Button1Click(Sender: TObject);
var f: integer;
begin for f := 0 to Screen.FormCount - 1 do Screen.Forms[f].Perform(UM_MyGlobalMessage, 42, 42);
end;
{Code for Unit2} const UM_MyGlobalMessage = WM_USER + 1;
type TForm2 = class(TForm) Label1: TLabel;
private {Private declarations} procedure UMMyGlobalMessage(var AMessage: TMessage);
message UM_MyGlobalMessage;
public {Public declarations} end;
var Form2: TForm2;
implementation {$R *.DFM} procedure TForm2.UMMyGlobalMessage(var AMessage: TMessage);
begin Label1.Left := AMessage.WParam;
Label1.Top := AMessage.LParam;
Form2.Caption := 'Got It!';
end;
Наверх к содержанию
Вопрос: Как обновить список дисков компонента TDriveComboBox, учитывая, что могуд быть подключены/отключены сетевые диски и произведена "
горячая замена"
plug&
play дисков?
ответ: Следующий пример вызывает защищенный (protected) метод класса TDriveComboBox BuildList() для регеирации списка дисков. (использовая так наз. "
class cracer"
)
Пример: type TNewDriveComboBox = class(TDriveComboBox) //это наш "
class cracer"
end;
procedure TForm1.Button1Click(Sender: TObject);
var Drive : char;
begin Drive := DriveComboBox1.Drive;
TNewDriveComboBox(DriveComboBox1).BuildList;
//вызываем защищенный метод родительского класса DriveComboBox1.Drive := Drive;
end;
Наверх к содержанию
Вопрос: Как программно заставить выпасть меню?
ответ: В примере показано как показать меню и выбрать в нем какой-то пункт, эмулируя нажатие "
быстрой кдавиши"
пункта меню. Если у Вашего пункта меню нет "
быстрой клавиши"
Вы можете посылать комбинации VK_MENU, VK_LEFT, VK_DOWN, и VK_RETURN, чтобы программно "
путешествовать"
по меню.
Пример: procedure TForm1.Button1Click(Sender: TObject);
begin //Allow button to finish painting in response to the click Application.ProcessMessages;
{Alt key Down} keybd_Event(VK_MENU, 0, 0, 0);
{F key Down - Drops the menu down} keybd_Event(ord('F'), 0, 0, 0);
{F key Up} keybd_Event(ord('F'), 0, KEYEVENTF_KEYUP, 0);
{Alt key Up} keybd_Event(VK_MENU, 0, KEYEVENTF_KEYUP, 0);
{F key Down} keybd_Event(ord('S'), 0, 0, 0);
{F key Up} keybd_Event(ord('S'), 0, KEYEVENTF_KEYUP, 0);
end;
Наверх к содержанию
Вопрос: Как сделать клавишу-акселератор (keyboard shortcut) компонету у которого нет заголовка?
ответ: Возможный вариант - присвоить ссылку на этот компонент свойству FocusControl TLabel'а. В примере используется невидимый Label для создания "
быстрой"
клавиши (Alt+M) компонента Memo. Чтобы использовать пример, разместите на форме компонет TMemo, Label и несколько других компонентов, которые могут принимать фокус ввода. Запустите программу, перевидите фокус ввода куда-нибудь вне Memo и нажмите Alt+M - фокус ввода вернется в Memo.
Пример: procedure TForm1.FormCreate(Sender: TObject);
begin Label1.Visible := false;
Label1.Caption := '&
M';
Label1.FocusControl := Memo1;
end;
Наверх к содержанию
Вопрос: Можно ли как-то уменьшить мерцание при перерисовке компонента?
ответ: Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle компонента - то фон компонента перерисовываться не будет.
Пример: constructor TMyControl.Create;
begin inherited;
ControlStyle := ControlStyle + [csOpaque];
end;
Наверх к содержанию
Вопрос: Как запретить изменение размера моего компонента в design-time?
ответ: Поместите в конструктор компонента код, устанавливающий размеры по умолчанию. Переопределите метод SetBounds и проверяйте в нем "
componentstate"
. Если компонет находится режиме "
design-time"
(csDesigning in ComponentState) просто передавайте значения ширины и высоты (width и heights) компонента по умолчанию (в нашем примере 50) методу класса-предка.
Пример: procedure TVu.SetBounds(ALeft : integer;
ATop : integer;
AWidth : integer;
AHeight : integer);
begin if csdesigning in componentstate then begin AWidth := 50;
AHeight := 50;
inherited;
//вызываем унаследованный от предка метод end;
end;
Наверх к содержанию
Вопрос: Можно ли уменьшить потребляемые компонентами TNotebook и TTabbedNotebook ресурсы?
ответ: Да. Можно уничтожать обьекты, расположенные не на текущей странице TNotebook или TTabbedNotebook. В примере вызывается защищенный (Protected) метод путем создания так называемый "
class cracer'ов"
. type TMyTabbedNotebook = class(TTabbedNotebook);
//это наш "
class cracer"
type TMyNotebook = class(TNotebook);
procedure TForm1.TabbedNotebook1Change(Sender: TObject;
NewTab: integer;
var AllowChange: Boolean);
begin with TabbedNotebook1 do //вызываем защищенный метод родительского класса TMyTabbedNotebook(TWinControl(Pages.Objects[PageIndex])).DestroyHandle;
end;
procedure TForm1.TabSet1Change(Sender: TObject;
NewTab: integer;
var AllowChange: Boolean);
begin with Notebook1 do //вызываем защищенный метод родительского класса TMyNotebook(TWinControl(Pages.Objects[PageIndex])).DestroyHandle;
NoteBook1.PageIndex := NewTab;
AllowChange := true end;
Наверх к содержанию
Вопрос: Функция keybd_event() принимает значения до 244 - как мне отправить нажатие клавиши с кодом #255 в элемент управления Windows?
ответ: Это может понадобится для иностранных языков или для специальных символов. (например, в русских шрифтах символ с кодом #255 - я прописное). Приведенный в примере метод, не стоит использовать в случае если символ может быть передан обычным способом (функцией keybd_event()). procedure TForm1.Button1Click(Sender: TObject);
var KeyData : packed record RepeatCount : word;
ScanCode : byte;
Bits : byte;
end;
begin {Let the button repaint} Application.ProcessMessages;
{Set the focus to the window} Edit1.SetFocus;
{Send a right so the char is added to the end of the line} // SimulateKeyStroke(VK_RIGHT, 0);
keybd_event(VK_RIGHT, 0,0,0);
{Let the app get the message} Application.ProcessMessages;
FillChar(KeyData, sizeof(KeyData), #0);
KeyData.ScanCode := 255;
KeyData.RepeatCount := 1;
SendMessage(Edit1.Handle, WM_KEYDOWN, 255,LongInt(KeyData));
KeyData.Bits := KeyData.Bits or (1 shl 30);
KeyData.Bits := KeyData.Bits or (1 shl 31);
SendMessage(Edit1.Handle, WM_KEYUP, 255, LongInt(KeyData));
KeyData.Bits := KeyData.Bits and not (1 shl 30);
KeyData.Bits := KeyData.Bits and not (1 shl 31);
SendMessage(Edit1.Handle, WM_CHAR, 255, LongInt(KeyData));
Application.ProcessMessages;
end;
Наверх к содержанию
Вопрос: Некоторые компоненты не меняют курсор мыши до тех пор пока пользователь не сдвинет мышь. Как эмулировать движение мыши?
ответ: В примере мышка слегка "
подталкивается"
без участия пользователя. procedure TForm1.Button1Click(Sender: TObject);
var pt : TPoint;
begin Application.ProcessMessages;
Screen.Cursor := CrHourglass;
GetCursorPos(pt);
SetCursorPos(pt.x + 1, pt.y + 1);
Application.ProcessMessages;
SetCursorPos(pt.x - 1, pt.y - 1);
end;
Наверх к содержанию
Вопрос: Как зарегистрировать расширение файла за своим приложением и контекстное меню, связанное с этим типом?
ответ: Пример регистрирует расширение файла(.myext) - файлы этого типа будут открываться приложением MyApp.Exe. Также регнстрируется одно действие (action) по умолчанию для файлов этого типа и два дополнительных пункта контекстного меню, связанного с этим типом файлов. Возможно, потребуется перезайти в систему чтобы изменения вступили в силу.
Пример: uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var R : TRegIniFile;
begin R := TRegIniFile.Create('');
with R do begin RootKey := HKEY_CLASSES_ROOT;
WriteString('.myext','','MyExt');
WriteString('MyExt','','Some description of MyExt files');
WriteString('MyExt\DefaultIcon','','C:\MyApp.Exe,0');
WriteString('MyExt\Shell','','This_Is_Our_Default_Action');
WriteString('MyExt\Shell\First_Action', '','This is our first action');
WriteString('MyExt\Shell\First_Action\command','', 'C:\MyApp.Exe /LotsOfParamaters %1');
WriteString('MyExt\Shell\This_Is_Our_Default_Action','', 'This is our default action');
WriteString('MyExt\Shell\This_Is_Our_Default_Action\command', '','C:\MyApp.Exe %1');
WriteString('MyExt\Shell\Second_Action', '','This is our second action');
WriteString('MyExt\Shell\Second_Action\command', '','C:\MyApp.Exe /TonsOfParameters %1');
Free;
end;
end;
 

 

Delphisource (2006г.)
Используются технологии uCoz