|
|
Programming: Delphi
DELPHI VCL FAQ (Часть 3)
Вопрос:
Когда я добавляю обьект в список TStrings как мне его потом уничтожить?
Ответ:
Просто вызовите метод free этого обьекта.
Пример:
<![CDATA[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.
Пример:
<![CDATA[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?
Ответ:
Эту информацию можно получить из реестра.
Пример:
<![CDATA[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).
Пример:
<![CDATA[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. Как
заставить компилятор проводить более строгую проверку типов и выдавать
предупреждение в таких случаях?
Ответ:
См. ответ.
Пример:
<![CDATA[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 или какой-либо еще диалог.
Пример:
<![CDATA[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 чтобы преобразовать экранные кординаты в
координаты клиентской области окна.
Пример:
<![CDATA[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".
Пример:
<![CDATA[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.
Пример:
<![CDATA[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.
Пример:
<![CDATA[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;]]>
{Другой вариант}
<![CDATA[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;
<![CDATA[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".
Пример:
<![CDATA[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.
Пример:
<![CDATA[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). Пример показывает как перехватить вижение мыши во всей неклиенстской области окна (рамка и заголовок).
Пример:
<![CDATA[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.
Пример:
<![CDATA[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 автоматически изменял ширину колонок, чтобы
вместить самую длинную строчку в колонке?
Ответ:
См. пример.
Пример:
<![CDATA[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).
Далее добавте ресурс к своему приложению.
<![CDATA[{Грузим ресурс}
{$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'а.
Пример:
<![CDATA[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 при рисовании
- таким образом вывод прямоугольника дважды с одними и теми же
координатами стирает прямоугольник, и прямоугольник всегда будет виден, на
фоне какого бы цвета он не выводился.
Пример:
<![CDATA[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?
Ответ:
Можно. См. пример.
Пример:
<![CDATA[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?
Ответ:
<![CDATA[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. В качестве параметров вы должны переслать начальную позицию
курсора, и конечную позицию, определяющую конец выделения текста цветом. В
приведенном примере курсор помещается во вторую позицию, текст внутри
ячейки не выделяется.
Пример:
<![CDATA[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().
Пример:
<![CDATA[procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.SetFocus;
{переводим курсор во вторую позицию}
Edit1.SelStart := 2;
{не выделяем никакого текста}
Edit1.SelLength := 0;
end;]]>
Наверх к содержанию
Вопрос:
Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение
размера формы?
Ответ:
В примере перехватывается сообщение WM_SYSCOMMAND. Если это сообщение говорит о
минимизации или максимизации формы - пищит динамик.
Пример:
<![CDATA[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) форма, но фокус ввода ей
не передается.
Пример:
<![CDATA[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
флоппи дисковода.
Пример:
<![CDATA[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.
Пример:
<![CDATA[{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")
Пример:
<![CDATA[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, чтобы программно "путешествовать" по меню.
Пример:
<![CDATA[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.
Пример:
<![CDATA[procedure TForm1.FormCreate(Sender: TObject);
begin
Label1.Visible := false;
Label1.Caption := '&M';
Label1.FocusControl := Memo1;
end;]]>
Наверх к содержанию
Вопрос:
Можно ли как-то уменьшить мерцание при перерисовке компонента?
Ответ:
Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle компонента
- то фон компонента перерисовываться не будет.
Пример:
<![CDATA[constructor TMyControl.Create;
begin
inherited;
ControlStyle := ControlStyle + [csOpaque];
end;]]>
Наверх к содержанию
Вопрос:
Как запретить изменение размера моего компонента в design-time?
Ответ:
Поместите в конструктор компонента код, устанавливающий размеры по умолчанию.
Переопределите метод SetBounds и проверяйте в нем "componentstate". Если компонет
находится режиме "design-time" (csDesigning in ComponentState) просто передавайте
значения ширины и высоты (width и heights) компонента по умолчанию (в нашем
примере 50) методу класса-предка.
Пример:
<![CDATA[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'ов".
<![CDATA[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()).
<![CDATA[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;]]>
Наверх к содержанию
Вопрос:
Некоторые компоненты не меняют курсор мыши до тех пор пока пользователь не
сдвинет мышь. Как эмулировать движение мыши?
Ответ:
В примере мышка слегка "подталкивается" без участия пользователя.
<![CDATA[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) по умолчанию
для файлов этого типа и два дополнительных пункта контекстного меню, связанного с
этим типом файлов. Возможно, потребуется перезайти в систему чтобы изменения
вступили в силу.
Пример:
<![CDATA[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;]]>
Наверх к содержанию
Часть 2
При перепечатке любого материала
с сайта, видимая ссылка на источник www.warayg.narod.ru
и все имена, ссылки авторов обязательны.
© 2005
|
|
|
