Секция 4 из 4 - Предыдущая - Следующая
Все секции - 1 - 2 - 3 - 4

Вопрос:
Как сохранить обьект TFont в реестре/ini/файле/таблице базы данных?

Ответ:

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"?

Ответ:

Пример:

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 работает не достаточно точно. Как получить более высокую точность?

Ответ:

Наверх к содержанию



Вопрос:
Как поместить 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;


Наверх к содержанию



Вопрос:
Как сделать прямоугольник для выделения части картинки для редактирования?

Ответ:

Пример:

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 в реим редактирования и установить курсор в
окошке редактирования в требуемую позицию?

Ответ:

Пример:

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;


Наверх к содержанию



Вопрос:
Как программно заставить выпасть меню?

Ответ:

Пример:

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) компонету у которого нет заголовка?

Ответ:

Пример:

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;


Наверх к содержанию

Секция 4 из 4 - Предыдущая - Следующая

© faqs.org.ru