Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 1 марта!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Как изменить число фиксированных колонок в 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;



<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS