Вопрос:
Как разместить прозрачную надпись на TBitmap?
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
OldBkMode : integer;
begin
Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,TRANSPARENT);
Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,OldBkMode);
end;
Наверх к содержанию
Вопрос:
Можно ли обратиться к колонке или строке grid'а по заголовку?
Ответ:
В следующем примере приведены две функции: GetGridColumnByName() и GetGridRowByName(), которые возвращают колонку или строку, имеющую заданный заголовок (caption).
Пример:
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.Rows[1].Strings[0] := 'This Row';
StringGrid1.Cols[1].Strings[0] := 'This Column';
end;
function GetGridColumnByName(Grid : TStringGrid; ColName : string): integer;
var
i : integer;
begin
for i := 0 to Grid.ColCount - 1 do
if Grid.Rows[0].Strings[i] = ColName then
begin
Result := i;
exit;
end;
Result := -1;
end;
function GetGridRowByName(Grid : TStringGrid; RowName : string): integer;
var
i : integer;
begin
for i := 0 to Grid.RowCount - 1 do
if Grid.Cols[0].Strings[i] = RowName then
begin
Result := i;
exit;
end;
Result := -1;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Column : integer;
Row : integer;
begin
Column := GetGridColumnByName(StringGrid1, 'This Column');
if Column = -1 then
ShowMessage('Column not found')
else
ShowMessage('Column found at ' + IntToStr(Column));
Row := GetGridRowByName(StringGrid1, 'This Row');
if Row = -1 then
ShowMessage('Row not found')
else
ShowMessage('Row found at ' + IntToStr(Row));
end;
Наверх к содержанию
Вопрос:
Как использовать клавишу-акселератор в TTabsheets? Я добавляю клавишу-акселератор в заголовок каждого Tabsheet моего PageControl, но при попытке переключать страницы этой клавишей программа пикает и ничего не происходит.
Ответ:
Можно перехватить сообщение CM_DIALOGCHAR.
Пример:
type
TForm1 = class(TForm)
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
TabSheet3: TTabSheet;
private
{Private declarations}
procedure CMDialogChar(var Msg:TCMDialogChar);
message CM_DIALOGCHAR;
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.CMDialogChar(var Msg:TCMDialogChar);
var
i : integer;
begin
with PageControl1 do
begin
if Enabled then
for i := 0 to PageControl1.PageCount - 1 do
if ((IsAccel(Msg.CharCode, Pages[i].Caption)) and
(Pages[i].TabVisible)) then
begin
Msg.Result:=1;
ActivePage := Pages[i];
exit;
end;
end;
inherited;
end;
Наверх к содержанию
Вопрос:
При использованиии компонента TRegistry под NT пользователь с права доступа ниже чем "администратор" не может получить доступа к информации реестра в ключе HKEY_LOCAL_MACHINE. Как это обойти?
Ответ:
Проблема вызвана тем, что TRegistry всегда открывает реестр с параметром KEY_ALL_ACCESS (полный доступ), даже если необходим доступ KEY_READ (только чтение). Избежать этого можно используя функции API для работы с реестром (RegOpenKey и т.п.), или создать новый класс из компонента TRegestry, и изменить его так чтобы можно было задавать режим открытия реестра.
Наверх к содержанию
Вопрос:
Можно ли изменить число колонок и их ширину в компоненте TFileListBox?
Ответ:
В приведенном примере FileListBox приводится к типу TDirectoryListBox - таким образом можно добавиь дополнительные колонки.
Пример:
with TDirectoryListBox(FileListBox1) do
begin
Columns := 2;
SendMessage(Handle, LB_SETCOLUMNWIDTH, Canvas.TextWidth('WWWWWWWW.WWW'),0);
end;
Наверх к содержанию
Вопрос:
Как настроить табуляцию в компоненте TMemo?
Ответ:
Пошлите в Memo сообщение EM_SETTABSTOPS. Например установим первую позицию табуляции на 20-й пиксел.
Пример:
procedure TForm1.FormCreate(Sender: TObject);
var
DialogUnitsX : LongInt;
PixelsX : LongInt;
i : integer;
TabArray : array[0..4] of integer;
begin
Memo1.WantTabs := true;
DialogUnitsX := LoWord(GetDialogBaseUnits);
PixelsX := 20;
for i := 1 to 5 do
begin
TabArray[i - 1] :=((PixelsX * i ) * 4) div DialogUnitsX;
end;
SendMessage(Memo1.Handle,
EM_SETTABSTOPS,5,LongInt(@TabArray));
Memo1.Refresh;
end;
Наверх к содержанию
Вопрос:
Как перехватить нажатия функциональных клавиш и стрелок?
Ответ:
Проверяйте значение переменной key на равенство VK_RIGHT, VK_LEFT, VK_F1 и т.д. на событии KeyDown формы.
Пример:
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_RIGHT then
Form1.Caption := 'Right';
if Key = VK_F1 then
Form1.Caption := 'F1';
end;
Наверх к содержанию
Вопрос:
При обработке события DrawCell компонента DrawGrid я пишу Font.Color := clRed; и получаю
бесконечный цикл мерцаний. Почему?
Ответ:
Правильно укажите границы используемого канваса.
Пример:
If (Row = 0) then
begin
DrawGrid1.Canvas.Font.Color := clRed;
DrawGrid1.Canvas.TextOut(Rect.Left,Rect.Top, IntToStr(Col));
end;
Наверх к содержанию
Вопрос:
При использовании BitBtn Caption(текст) и картинка(bitmap) из файла не видны
одновременно. Почему?
Ответ:
Это может происходить если картинка слишком велика. Класс TBitBtn сначала рисует
картинку, а затем выводит текст над, под, слева или справа от картинки (в завивимости
от свойства Layout). Если размер картинки такой же как у всей кнопки для вывода текста
просто не остается места. Если Вам нужно получить кнопку такого же размера как Ваша
картинка и видеть при этом надпись на кнопке Вам придется выводить текст надписи
непосредственно на канву картинки.
Пример:
var
bm : TBitmap;
OldBkMode : integer;
begin
bm := TBitmap.Create;
bm.Width := BitBtn1.Glyph.Width;
bm.Height := BitBtn1.Glyph.Height;
bm.Canvas.Draw(0, 0, BitBtn1.Glyph);
OldBkMode := SetBkMode(bm.Canvas.Handle, Transparent);
bm.Canvas.TextOut(0, 0, 'The Caption');
SetBkMode(bm.Canvas.Handle, OldBkMode);
BitBtn1.Glyph.Assign(bm);
end;
Наверх к содержанию
Вопрос:
Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента
управления Windows?
Ответ:
Можно! В примере показано как создать два цветных "bitmap'а": "улыбчивый" и "хмурый"
и присвоить их курсору edit'а. Для этого нужно перехватить оконную процедуру edit'а.
Чтобы сделать это заменим адрес оконной процедуры Edit'а нашим собственным, а старую
оконную процедуру будем вызывать по необходимости. Пример показывает "улыбчивый" курсор
при наборе текста и "хмурый" при забое клавишей backspace.
Пример:
unit caret1;
interface
{$IFDEF WIN32}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
{$ELSE}
uses
WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
{$ENDIF}
type
TForm1 = class(TForm)
Edit1: TEdit;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{Private declarations}
public
{Public declarations}
CaretBm : TBitmap;
CaretBmBk : TBitmap;
OldEditsWindowProc : Pointer;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
{$IFDEF WIN32}
WParameter = LongInt;
{$ELSE}
WParameter = Word;
{$ENDIF}
LParameter = LongInt;
{New windows procedure for the edit control}
function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter;
ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
begin
{Call the old edit controls windows procedure}
NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle,
TheMessage, ParamW, ParamL);
if TheMessage = WM_SETFOCUS then
begin
CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
ShowCaret(WindowHandle);
end;
if TheMessage = WM_KILLFOCUS then
begin
HideCaret(WindowHandle);
DestroyCaret;
end;
if TheMessage = WM_KEYDOWN then
begin
if ParamW = VK_BACK then
CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0)
else
CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
ShowCaret(WindowHandle);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{Create a smiling bitmap using the wingdings font}
CaretBm := TBitmap.Create;
CaretBm.Canvas.Font.Name := 'WingDings';
CaretBm.Canvas.Font.Height := Edit1.Font.Height;
CaretBm.Canvas.Font.Color := clWhite;
CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;
CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;
CaretBm.Canvas.Brush.Color := clBlue;
CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height));
CaretBm.Canvas.TextOut(1, 1, 'J');
{Create a frowming bitmap using the wingdings font}
CaretBmBk := TBitmap.Create;
CaretBmBk.Canvas.Font.Name := 'WingDings';
CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;
CaretBmBk.Canvas.Font.Color := clWhite;
CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;
CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;
CaretBmBk.Canvas.Brush.Color := clBlue;
CaretBmBk.Canvas.FillRect(Rect(0,0, CaretBmBk.Width, CaretBmBk.Height));
CaretBmBk.Canvas.TextOut(1, 1, 'L');
{Hook the edit controls window procedure}
OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle,GWL_WNDPROC,
LongInt(@NewWindowProc)));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
{Unhook the edit controls window procedure and clean up}
SetWindowLong(Edit1.Handle,GWL_WNDPROC, LongInt(OldEditsWindowProc));
CaretBm.Free;
CaretBmBk.Free;
end;
Наверх к содержанию
Вопрос:
При использовании модулей доступа к BDE (DbiTypes, DbiProcs, DbiErrs), любая попытка
вызвать процедуру abort выдает ошибку при компиляции при вызове метода abort "Statement
expected, but expression of type 'Integer' found". Я пытался найти DbiTypes.pas,
DbiProcs.pas и DbiErrs.pas чтобы разобраться но не нашел этих файлов. Где расположены
эти файлы и как обойти ошибку?
Ответ:
Модули DbiTypes, DbiProcs, DbiErrs это псевдонимы модуля "BDE", обьявлены в
Projects->Options->Directories/Conditionals->Unit Aliases. Исходник модуля DBE
находится в каталоге "doc" и называется "BDE.INT". В этом файле обьявленна константа
ABORT со значением -2. Так как Вы хотите использовать процедуру Abort(), которая
обьявлена в модуле SysUtils, Вам нужно добавить префикс SysUtils перед вызовом
процедуры Abort.
Пример:
SysUtils.Abort;
Наверх к содержанию
Вопрос:
Почему при изменении цвета букв StatusBar'а ничего не происходит?
Ответ:
Status bar - стандартный элемент управления Windows, и соответственно цвет его букв
- значение clBtnText которое изменяется с помощью настроек в Control Panel. Этот цвет
черный по умолчанию и может изменяться в зависимости от выбранной цветовой схемы.
Другие стандартные элемент управления Windows, например кнопки, также имеют цвет букв,
настраиваемый из ControlPanel. StatusBar и его панели имеют свойство "owner-draw",
позволяющее Вам использовать любой цвет букв.
Пример:
procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
begin
if Panel = StatusBar.Panels[0] then
begin
StatusBar.Canvas.Font.Color := clRed;
StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0')
end
else
begin
StatusBar.Canvas.Font.Color := clGreen;
StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
end;
end;
Наверх к содержанию
Вопрос:
Как сделать многострочную надпись на TBitBtn?
Ответ:
Выводите текст надписи непосредственно на "glyph" TBitBtn'а. См. пример.
Пример:
procedure TForm1.FormCreate(Sender: TObject);
var
R : TRect;
N : Integer;
Buff : array[0..255] of Char;
begin
with BitBtn1 do
begin
Caption := 'A really really long caption';
Glyph.Canvas.Font := Self.Font;
Glyph.Width := Width - 6;
Glyph.Height := Height - 6;
R := Bounds(0, 0, Glyph.Width, 0);
StrPCopy(Buff, Caption);
Caption := '';
DrawText(Glyph.Canvas.Handle,Buff,StrLen(Buff),R,
DT_CENTER or DT_WORDBREAK or DT_CALCRECT);
OffsetRect(R,(Glyph.Width - R.Right) div 2,
(Glyph.Height - R.Bottom) div 2);
DrawText(Glyph.Canvas.Handle,Buff,StrLen(Buff),R,
DT_CENTER or DT_WORDBREAK);
end;
end;
Наверх к содержанию
Вопрос:
Как изменить стиль шрифта RichEdit нажатиями соответствующих комбинаций клавиш?
(например включить курсив по нажатию Ctrl + I)
Ответ:
В примере стили шрифта меняются по нажатию след. комбинаций клавиш
Ctrl + B - вкл/выкл жирного шрифта
Ctrl + I - вкл/выкл наклонного шрифта
Ctrl + S - вкл/выкл зачеркнутого шрифта
Ctrl + U - вкл/выкл подчеркнутого шрифта
Пример:
const
KEY_CTRL_B = 02;
KEY_CTRL_I = 9;
KEY_CTRL_S = 19;
KEY_CTRL_U = 21;
procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char);
begin
case Ord(Key) of
KEY_CTRL_B:
begin
Key := #0;
if fsBold in (Sender as TRichEdit).SelAttributes.Style then
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style - [fsBold]
else
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style + [fsBold];
end;
KEY_CTRL_I:
begin
Key := #0;
if fsItalic in (Sender as TRichEdit).SelAttributes.Style then
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style - [fsItalic]
else
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style + [fsItalic];
end;
KEY_CTRL_S:
begin
Key := #0;
if fsStrikeout in (Sender as TRichEdit).SelAttributes.Style then
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style-[fsStrikeout]
else
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style+[fsStrikeout];
end;
KEY_CTRL_U:
begin
Key := #0;
if fsUnderline in (Sender as TRichEdit).SelAttributes.Style then
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style-[fsUnderline]
else
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style+[fsUnderline];
end;
end;
end;
Наверх к содержанию
Вопрос:
В документации компонента TRegIniFile говорится, что можно изменять корневой ключ
(root key). Я пытаюсь это сделать но ничего не получается.
Ответ:
См. пример.
Пример:
uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var
WinIni : TRegIniFile;
begin
WinIni := TRegIniFile.Create('');
WinIni.RootKey := HKEY_LOCAL_MACHINE;
WinIni.WriteString('Frank','Borland','Writes Fast Code!');
WinIni.Free;
end;
Наверх к содержанию
Вопрос:
Можно ли динамически изменять свойство "owner" компонента во время выполнения программы?
Ответ:
Вы можете менять свойство "owner" и после создания компонента с помощью методов
InsertComponent() и RemoveComponent().
Наверх к содержанию
Вопрос:
Как очистить содержимое Canvas'а?
Ответ:
Просто нарисуйте прямоугольник любого цвета.
Пример:
Canvas.Brush.Color := ClWhite;
Canvas.FillRect(Canvas.ClipRect);
Наверх к содержанию
Вопрос:
Можно ли динамически менять какая форма считается главной в приложении во время
работы программы?
Ответ:
Можно, но только во время загрузки приложения.
Чтобы сделать это выберите "View->Project Source" и измените код инициализации
приложения, так что порядок создания форм зависил от какого-то условия.
Примечание: Вам придется редактировать этот код, если Вы добавите в приложение новые формы.
begin
Application.Initialize;
if <какое-то условие> then
begin
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);
end
else
begin
Application.CreateForm(TForm2, Form2);
Application.CreateForm(TForm1, Form1);
end;
end.
Application.Run;
Наверх к содержанию
Вопрос:
Как программно "щелкнуть" по компоненту speed button? Я пытался использовать
SendMessage но у Speedbuttons нет "handle".
Ответ:
В примере используется метод Perform класса TControl для отправки сообщения.
Пример:
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
ShowMessage('clicked');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SpeedButton1.Perform(WM_LBUTTONDOWN, 0, 0);
SpeedButton1.Perform(WM_LBUTTONUP, 0, 0);
end;
Наверх к содержанию
Вопрос:
Можно ли отключить определенный элемент в RadioGroup?
Ответ:
В примере показано как получить доступ к отдельным элементам компонента TRadioGroup.
Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin
TRadioButton(RadioGroup1.Controls[1]). Enabled := False;
end;
Наверх к содержанию
Вопрос:
Почему методы рисования Delphi (например MoveTo и LineTo) рисуют на один пиксел короче?
Ответ:
Так работает большинство графических систем, включая Windows. Библиотека VCL просто
передает вызовы в функции GDI. Если Вы хотите нарисовать линию с последним пикселом
включительно просто добавте единицу к координатам.
Наверх к содержанию
Вопрос:
Как показать подсказки "hints" для элементов меню?
Ответ:
В примере создается обработчик события Application.Hint - подсказки меню изображаются
на status panel.
Пример:
type
TForm1 = class(TForm)
Panel1: TPanel;
MainMenu1: TMainMenu;
MenuItemFile: TMenuItem;
MenuItemOpen: TMenuItem;
MenuItemClose: TMenuItem;
OpenDialog1: TOpenDialog;
procedure FormCreate(Sender: TObject);
procedure MenuItemCloseClick(Sender: TObject);
procedure MenuItemOpenClick(Sender: TObject);
private
{Private declarations}
procedure HintHandler(Sender: TObject);
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Panel1.Align := alBottom;
MenuItemFile.Hint := 'File Menu';
MenuItemOpen.Hint := 'Opens A File';
MenuItemClose.Hint := 'Closes the Application';
Application.OnHint := HintHandler;
end;
procedure TForm1.HintHandler(Sender: TObject);
begin
Panel1.Caption := Application.Hint;
end;
procedure TForm1.MenuItemCloseClick(Sender: TObject);
begin
Application.Terminate;
end;
procedure TForm1.MenuItemOpenClick(Sender: TObject);
begin
if OpenDialog1.Execute then
Form1.Caption := OpenDialog1.FileName;
end;
Наверх к содержанию
Вопрос:
Как опеделить состояние списка ComboBox, выпал/скрыт?
Ответ:
Пошлите ComboBox сообщение CB_GETDROPPEDSTATE.
Пример:
if SendMessage(ComboBox1.Handle, CB_GETDROPPEDSTATE,0,0) = 1 then
begin {список ComboBox выпал}
end;
Наверх к содержанию
Вопрос:
Как удалить каталог вместе со всеми содержащимися в нем файлами?
Ответ:
В примере стираются все файлы в каталоге и сам каталог. Чтобы удалить файл,
помечанные только для чтения (read only) и занятые другими программами в момент
удаления - напишите дополнительную процедуру.
procedure TForm1.Button1Click(Sender: TObject);
var
DirInfo: TSearchRec;
r: integer;
begin
r := FindFirst('C:\Download\*.*', FaAnyfile, DirInfo);
while r = 0 do
begin
if ((DirInfo.Attr and FaDirectory <> FaDirectory) and
(DirInfo.Attr and FaVolumeId <> FaVolumeID)) then
if DeleteFile(pChar('C:\Download\' + DirInfo.Name))= false then
ShowMessage('Unable to delete: C:\Download\'+DirInfo.Name);
r := FindNext(DirInfo);
end;
SysUtils.FindClose(DirInfo);
if RemoveDirectory('C:\Download\') = false then
ShowMessage('Unable to delete directory: C:\Download\');
end;
Наверх к содержанию
Вопрос:
Как отключить системное меню формы и кнопки Minimize, Maximize, and Close во время
выполнения(Runtime)?
Ответ:
В приведенном примере показано как это сделать
Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin
{Disable}
Form1.BorderIcons := Form1.BorderIcons - [biSystemMenu, biMinimize, biMaximize];
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
{Enable}
Form1.BorderIcons := Form1.BorderIcons + [biSystemMenu, biMinimize, biMaximize];
end;
Наверх к содержанию
Вопрос:
Как извлечь Red, Green, и Blue компонент из определенного цвета?
Ответ:
Используйте функции Window API Get RValue(), GetGValue(), и GetBValue().
Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Canvas.Pen.Color := clRed;
Memo1.Lines.Add('Red := ' + IntToStr(GetRValue(Form1.Canvas.Pen.Color)));
Memo1.Lines.Add('Red := ' + IntToStr(GetGValue(Form1.Canvas.Pen.Color)));
Memo1.Lines.Add('Blue:= ' + IntToStr(GetBValue(Form1.Canvas.Pen.Color)));
end;
Наверх к содержанию
Вопрос:
Как определить номер текущей строки в TMemo?
Ответ:
Чтобы определить номер текущей строки любого объекта управления edit - пошлите ей
сообщение EM_LINEFROMCHAR
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
LineNumber : integer;
begin
LineNumber := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, word(-1), 0);
ShowMessage(IntToStr(LineNumber));
end;
Наверх к содержанию
Вопрос:
Как проигрываеть MPEG файл в Delphi-программе?
Ответ:
Если в системе Windows MMSystem установлен декодер MPEG - используя компонент
TMediaPlayer
Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin
MediaPlayer1.Filename := 'C:\DownLoad\rsgrow.mpg';
MediaPlayer1.Open;
MediaPlayer1.Display := Panel1;
MediaPlayer1.DisplayRect := Panel1.ClientRect;
MediaPlayer1.Play;
end;
Наверх к содержанию
Вопрос:
Как использовать анимированный курсор?
Ответ:
Во первых необходимо получит handle курсора, а затем определить его в массиве
курсоров компонента TScreen. Индексы предопределенных курсоров системы отрицательны,
пользователь может определить курсор, индекс которого положителен.
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
h : THandle;
begin
h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or
LR_LOADFROMFILE);
if h = 0 then
ShowMessage('Cursor not loaded')
else
begin
Screen.Cursors[1] := h;
Form1.Cursor := 1;
end;
end;
Наверх к содержанию
Вопрос:
Как узнать о нажатии "non-menu" клавиши в момент когда меню показано?
Ответ:
Создайте обработчик сообщения WM_MENUCHAR.
Пример:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
One1: TMenuItem;
Two1: TMenuItem;
THree1: TMenuItem;
private
{Private declarations}
procedure WmMenuChar(var m : TMessage); message WM_MENUCHAR;
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WmMenuChar(var m : TMessage);
begin
Form1.Caption := 'Non standard menu key pressed';
m.Result := 1;
end;
end.
Наверх к содержанию
Вопрос:
Как определить наличие сопроцессора?
Ответ:
В отличие от общепринятого мнения не всее клоны 486/586/686/ и Pentium имеют
сопроцессор для вычислений с плавающей запятой. В примере определяется наличие
сопроцессора и под Win16 и под Win32.
Пример:
{$IFDEF WIN32}
uses Registry;
{$ENDIF}
function HasCoProcesser : bool;
{$IFDEF WIN32}
var
TheKey : hKey;
{$ENDIF}
begin
Result := true;
{$IFNDEF WIN32}
if GetWinFlags and Wf_80x87 = 0 then
Result := false;
{$ELSE}
if RegOpenKeyEx(HKEY_LOCAL_MACHINE,
'HARDWARE\DESCRIPTION\System\FloatingPointProcessor',0,
KEY_EXECUTE, TheKey) <> ERROR_SUCCESS then result := false;
RegCloseKey(TheKey);
{$ENDIF}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if HasCoProcesser then
ShowMessage('Has CoProcessor')
else
ShowMessage('No CoProcessor - Windows Emulation Mode');
end;
Наверх к содержанию
Вопрос:
Как узнать серийный номер аудио CD?
Ответ:
CD может иметь или не иметь серийный номер и/или универсальный код продукта
(Universal Product Code). MCI-расширение Windows предоставляет эту информации
с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает
уникальную ID-строку.
Пример:
uses MMSystem, MPlayer;
procedure TForm1.Button1Click(Sender: TObject);
var
mp : TMediaPlayer;
msp : TMCI_INFO_PARMS;
MediaString : array[0..255] of char;
ret : longint;
begin
mp := TMediaPlayer.Create(nil);
mp.Visible := false;
mp.Parent := Application.MainForm;
mp.Shareable := true;
mp.DeviceType := dtCDAudio;
mp.FileName := 'D:';
mp.Open;
Application.ProcessMessages;
FillChar(MediaString, sizeof(MediaString), #0);
FillChar(msp, sizeof(msp), #0);
msp.lpstrReturn := @MediaString;
msp.dwRetSize := 255;
ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY,
longint(@msp));
if Ret <> 0 then
begin
MciGetErrorString(ret, @MediaString, sizeof(MediaString));
Memo1.Lines.Add(StrPas(MediaString));
end
else
Memo1.Lines.Add(StrPas(MediaString));
mp.Close;
Application.ProcessMessages;
mp.free;
end;
end.
Наверх к содержанию
Вопрос:
Как вывести на элемент управления (Window control) текст, содержащий амперсанд - & ?
Ответ:
Используя два амперсанда подряд. Windows интерпритирует одиночный амперсанд как
указание на то, что следующий символ - горячая клавиша (и поддчеркивает следующий
символ вместо излбражения аперсанда).
Пример:
Button1.Caption := 'Черное && Белое';
Наверх к содержанию
Вопрос:
Как поместить bitmap в Metafile?
Ответ: см. пример
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
m : TmetaFile;
mc : TmetaFileCanvas;
b : tbitmap;
begin
m := TMetaFile.Create;
b := TBitmap.create;
b.LoadFromFile('C:\SomePath\SomeBitmap.BMP');
m.Height := b.Height;
m.Width := b.Width;
mc := TMetafileCanvas.Create(m, 0);
mc.Draw(0, 0, b);
mc.Free;
b.Free;
m.SaveToFile('C:\SomePath\Test.emf');
m.Free;
Image1.Picture.LoadFromFile('C:\SomePath\Test.emf');
end;
Наверх к содержанию
Вопрос:
Как узнать, что курсор мыши над моей формой?
Ответ:
Можно использовать функцию GetCapture() из Windows API.
Примечание: Cм. документацию Windows для информации об ограничениях функции GetCapture.
Пример:
procedure TForm1.FormDeactivate(Sender: TObject);
begin
ReleaseCapture;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
If GetCapture = 0 then
SetCapture(Form1.Handle);
if PtInRect(Rect(Form1.Left,Form1.Top,Form1.Left + Form1.Width,
Form1.Top + Form1.Height), ClientToScreen(Point(x, y))) then
Form1.Caption := 'Мышка над формой!'
else
Form1.Caption := 'Мышка вне формы...';
end;
Наверх к содержанию
Вопрос:
Как программно определить, что приложение работает под Windows NT?
Ответ:см. пример
Пример:
function IsNT : bool;
var
osv : TOSVERSIONINFO;
begin
result := true;
GetVersionEx(osv);
if osv.dwPlatformId = VER_PLATFORM_WIN32_NT then exit;
result := false;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if IsNt then
ShowMessage('Running on NT')
else
ShowMessage('Not Running on NT');
end;
Наверх к содержанию
Вопрос:
Как создать bitmap из пиктогрммы (icon)?
Ответ:
Используя Bitmap.Canvas.Draw нарисуйте пиктограмму на Bitmap'е.
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
TheIcon : TIcon;
TheBitmap : TBitmap;
begin
TheIcon := TIcon.Create;
TheIcon.LoadFromFile('C:\Program Files\Borland\IcoCur32\EARTH.ICO');
TheBitmap := TBitmap.Create;
TheBitmap.Height := TheIcon.Height;
TheBitmap.Width := TheIcon.Width;
TheBitmap.Canvas.Draw(0, 0, TheIcon);
Form1.Canvas.Draw(10, 10, TheBitmap);
TheBitmap.Free;
TheIcon.Free;
end;
Наверх к содержанию
Вопрос:
Как создать отдельную подсказку (hint) для каждой ячейки StringGrid?
Ответ:
В приведенном примере отслеживается движение курсора мыши - при перемещении между
ячейками StringGrid'а - появляется окно подсказки(hint), показываеющее номер текущей
строки и колонки.
Пример:
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
procedure StringGrid1MouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
procedure FormCreate(Sender: TObject);
private
{Private declarations}
Col : integer;
Row : integer;
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.Hint := '0 0';
StringGrid1.ShowHint := True;
end;
procedure TForm1.StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
r : integer;
c : integer;
begin
StringGrid1.MouseToCell(X, Y, C, R);
with StringGrid1 do
begin
if ((Row <> r) or(Col <> c)) then
begin
Row := r;
Col := c;
Application.CancelHint;
StringGrid1.Hint :=IntToStr(r)+#32+IntToStr(c);
end;
end;
end;
Наверх к содержанию
Вопрос:
Как внести изменения в код VCL?
Ответ:
Примечание: внесение изменений в VCL не поддерживается Borland или Borland
Developer Support.
-Но если Вы решили сделать это...
Изменеия в код VCL никогда не должны вносится в секцию "interface" модуля -
только в секцию "implimentation". Наиболее безопасный способ внести изменения
в VCL - создать новый каталог названный "исправленный VCL". Скопируйте файл VCL
который Вы хотите изменить в этот каталог. Внесите изменения
(лучше прокомментировать их) в этот файл. Затем добавьте путь к Вашему каталогу
"исправленный VCL" в самое начало "library path". Перезапустите Delphi/C++ Builder
и перекомпилируйте Ваш проект.
"library path" можно изменить в меню:
Delphi 1 : Options | Environment | Library
Delphi 2 : Tools | Options | Library
Delphi 3 : Tools | Environment Options | Library
Delphi 4 : Tools | Environment Options | Library
C++ Builder : Options | Environment | Library
Наверх к содержанию
Вопрос:
Как в Delphi реализовать функцию - эквивалент TwipsPerPixel из VisualBasic?
Ответ:
Функции TwipsPerPixelX и TwipsPerPixelY, приведенные в примере реализуют ту же
функциональность в Delphi.
Пример:
function TwipsPerPixelX(Canvas : TCanvas) : Extended;
begin
result := 1440 / GetDeviceCaps(Canvas.Handle, LOGPIXELSX);
end;
function TwipsPerPixelY(Canvas : TCanvas) : Extended;
begin
result := 1440 / GetDeviceCaps(Canvas.Handle, LOGPIXELSY);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(FloatToStr(TwipsPerPixelX(Form1.Canvas)));
ShowMessage(FloatToStr(TwipsPerPixelY(Form1.Canvas)));
end;
Наверх к содержанию
Вопрос:
Как вставить содержимое файла в текущую позицию курсора в компонете TMemo?
Ответ:
Считайте файл в TMemoryStream, затем ипользуйте метод TMemo SetSelTextBuf()
для вставки текста;
var
TheMStream : TMemoryStream;
Zero : char;
begin
TheMStream := TMemoryStream.Create;
TheMStream.LoadFromFile('C:\AUTOEXEC.BAT');
TheMStream.Seek(0, soFromEnd);
//Null terminate the buffer!
Zero := #0;
TheMStream.Write(Zero, 1);
TheMStream.Seek(0, soFromBeginning);
Memo1.SetSelTextBuf(TheMStream.Memory);
TheMStream.Free;
end;
Наверх к содержанию
Вопрос:
Как в компоненте TMemo перехватить нажатие Ctrl-V и вставить специальный текст не
из буфера обмена (clipboard)?
Ответ:
См. пример.
Пример:
uses ClipBrd;
procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if ((Key = ord('V')) and (ssCtrl in Shift)) then
begin
if Clipboard.HasFormat(CF_TEXT) then
ClipBoard.Clear;
Memo1.SelText := 'Delphi is RAD!';
key := 0;
end;
end;
Наверх к содержанию
Вопрос:
Как создать эквивалент TEdit но только с выравниваением вводимого текста по центру
или по правой стороне?
Ответ:
TEdit не поддерживает выравниваение текста по центру и по правой стороне - лучше
использовать компонент TMemo. Вам понадобится запретить пользователю нажимать Enter,
Ctrl-Enter и всевозможные комбинации клавиш со стрелками, чтобы избежать появления
нескольких сторк в Memo. Этого можно добиться и просматривая содержимое текста в TMemo
в поисках кода возврата каретки (13) и перевода строки(10) на событиях TMemo Change
и KeyPress. Можно также заменять код возврата каретки на пробел - для того чтобы
позволять вставку из буфера обмена многострочного текста в виде одной строки.
Пример:
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Alignment := taRightJustify;
Memo1.MaxLength := 24;
Memo1.WantReturns := false;
Memo1.WordWrap := false;
end;
procedure MultiLineMemoToSingleLine(Memo : TMemo);
var
t : string;
begin
t := Memo.Text;
if Pos(#13, t) > 0 then
begin
while Pos(#13, t) > 0 do
delete(t, Pos(#13, t), 1);
while Pos(#10, t) > 0 do
delete(t, Pos(#10, t), 1);
Memo.Text := t;
end;
end;
procedure TForm1.Memo1Change(Sender: TObject);
begin
MultiLineMemoToSingleLine(Memo1);
end;
procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
MultiLineMemoToSingleLine(Memo1);
end;
Наверх к содержанию
Вопрос:
Как запрограммировать undo?
Ответ:См. пример
Memo1.Perform(EM_UNDO, 0, 0);
Если Вы хотите узнать, возможно ли выполнить операцию "Undo", проверьте "Undo status":
If Memo1.Perform(EM_CANUNDO, 0, 0) <> 0 then
begin
{Undo is possible}
end;
Для выполнения "Redo" выполните "Undo" еще раз.
Наверх к содержанию
Вопрос:
Можно ли создать форму, которая получает дополнительные параметры в методе Сreate?
Ответ:
Просто замените конструктор Create класса Вашей формы.
Пример:
unit Unit2;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TForm2 = class(TForm)
private
{Private declarations}
public
constructor CreateWithCaption(aOwner: TComponent; aCaption: string);
{Public declarations}
end;
var
Form2: TForm2;
implementation
{$R *.DFM}
constructor TForm2.CreateWithCaption(aOwner: TComponent; aCaption: string);
begin
Create(aOwner);
Caption := aCaption;
end;
uses Unit2;
procedure TForm1.Button1Click(Sender: TObject);
begin
Unit2.Form2 :=Unit2.TForm2.CreateWithCaption(Application, 'My Caption');
Unit2.Form2.Show;
end;
Наверх к содержанию
Вопрос:
Почему при изменении цвета шрифта в StatusBar's он (шрифт) не меняется?
Ответ:
Status bar (строка состояния) - стандартный элемент управления Windows и цвет
его шрифта задается через Control Panel (константа clBtnText). Этот цвет по
умолчанию черный и может меняться при выборе пользователем той или иной цветовой
схемы. У компонента ТStatusBar и его панелей есть возможность "owner-draw"
- программной перерисовки, которая позволяет выводить на панель текст любого цвета.
Измените свойство Style компонента TStatusBar.Panels на OwnerDraw.
Пример:
procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel;
const Rect: TRect);
begin
if Panel = StatusBar.Panels[0] then
begin
StatusBar.Canvas.Font.Color := clRed;
StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0')
end
else
begin
StatusBar.Canvas.Font.Color := clGreen;
StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
end;
end;
Наверх к содержанию
Вопрос:
Как бы мне создать эдакий trackbar в котором вместо широкой белой полоски с ползунком
была бы тонкая линия?
Ответ:
В примере создается компонент, унаследованный от TTrackbar который переопределяет
метод CreateParams и убират флаг TBS_ENABLESELRANGE из Style.
Константа TBS_ENABLESELRANGE обьявленна в модуле CommCtrl.
Пример:
uses CommCtrl, ComCtrls;
type TMyTrackBar = class(TTrackBar)
procedure CreateParams(var Params: TCreateParams); override;
end;
procedure TMyTrackBar.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.Style := Params.Style and not TBS_ENABLESELRANGE;
end;
var
MyTrackbar : TMyTrackbar;
procedure TForm1.Button1Click(Sender: TObject);
begin
MyTrackBar := TMyTrackbar.Create(Form1);
MyTrackbar.Parent := Form1;
MyTrackbar.Left := 100;
MyTrackbar.Top := 100;
MyTrackbar.Width := 150;
MyTrackbar.Height := 45;
MyTrackBar.Visible := true;
end;
Наверх к содержанию
Вопрос:
Мне нужен временный canvas, но когда я пытаюсь его создать получаю сообщения об
ошибках. Как создать TCanvas?
Ответ:
Создайте Bitmap и используйте свойство canvas класса TBitmap. Пример создает Bitmap,
рисует на его canvas'е, выводит этот canvas на форму и освобождает bitmap.
Polygon - метод компонента TCanvas получает в качестве параметра динамический
массив точек. Функция PolyPolygon() из Windows GDI получает указатель на
массив точек.
Как создать невизуальный компонент без иконоки, которая изображается в палитре
компонентов в "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;
Наверх к содержанию
