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

ВИДЕОКУРС ВЗЛОМ
выпущен 10 декабря!


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

БОЛЬШОЙ FAQ ПО DELPHI



как добиться того, чтобы 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 в ненулевое значение - дальнейшая рассылка сообщения останавливается.



как определить, что была нажата клавиша tab?

На уровне формы клавиша tab обычно обрабатывается Windows. В примере создается обработчик события CM_Dialog для перехвата Dialog keys.
type
TForm1 = class(TForm)
private
procedure CMDialogKey( Var msg: TCMDialogKey );
message CM_DIALOGKEY;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.CMDialogKey(var msg: TCMDialogKey);
begin
if msg.Charcode <> VK_TAB then
inherited;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_TAB then
Form1.Caption := 'Tab Key Down!';
end;



как заставить появиться hint в нужный момент?

Сделаем это по нажатию на кнопку, а по нажатию на вторую кнопку скрываем окно hint'a:
public
{ Public declarations }
h:THintWindow;
procedure TForm1.Button1Click(Sender: TObject);
begin
IF h<>nil then H.ReleaseHandle;
H:=THintWindow.Create(Form1);
H.ActivateHint(Form1.ClientRect,'Это всплывающая подсказка');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
IF h<>nil then H.ReleaseHandle;
end;




как создать trackbar, в котором вместо широкой белой полосы балы бы тонкая линия?

В примере создается компонент, унаследованный от TTrackbar который переопределяет метод CreateParams и убират флаг TBS_ENABLESELRANGE из Style. Константа TBS_ENABLESELRANGE обьявленна в модуле CommCtrl.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,CommCtrl, ComCtrls,
StdCtrls;
type TMyTrackBar = class(TTrackBar)
procedure CreateParams(var Params: TCreateParams); override;
end;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
MyTrackbar : TMyTrackbar;
implementation
{$R *.DFM}
procedure TMyTrackBar.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.Style := Params.Style and not TBS_ENABLESELRANGE;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MyTrackBar := TMyTrackbar.Create(Form1);
MyTrackbar.Parent := Form1;
MyTrackbar.Left := 100;
MyTrackbar.Top := 100;
MyTrackbar.Width := 150;
MyTrackbar.Height := 45;
MyTrackBar.Visible := true;
end;
end.



как создать эквивалент tedit, но только с выравниванием вводимого текста по центру или по правой стороне?

TEdit не поддерживает выравниваение текста по центру и по правой стороне - лучше использовать компонент TMemo. Вам понадобится запретить пользователю нажимать Enter, Ctrl-Enter и всевозможные комбинации клавиш со стрелками, чтобы избежать появления нескольких сторк в Memo. Этого можно добиться и просматривая содержимое текста в TMemo в поисках кода возврата каретки (13) и перевода строки(10) на событиях TMemo Change и KeyPress. Можно также заменять код возврата каретки на пробел - для того чтобы позволять вставку из буфера обмена многострочного текста в виде одной строки.
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Alignment := taRightJustify;
Memo1.MaxLength := 24;
Memo1.WantReturns := false;
Memo1.WordWrap := false;
end;
procedure MultiLineMemoToSingleLine(Memo : TMemo);
var
t : string;
begin
t := Memo.Text;
if Pos(#13, t) > 0 then
begin
while Pos(#13, t) > 0 do
delete(t, Pos(#13, t), 1);
while Pos(#10, t) > 0 do
delete(t, Pos(#10, t), 1);
Memo.Text := t;
end;
end;
procedure TForm1.Memo1Change(Sender: TObject);
begin
MultiLineMemoToSingleLine(Memo1);
end;
procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
MultiLineMemoToSingleLine(Memo1);
end;



при попытке создать объект класса 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;




как изменить оконную процедуру для 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;



описание функций модуля "math"

Тригонометрические функции и процедуры
ArcCos - Арккосинус
ArcCosh - Пиперболический арккосинус
ArcSIn - Арксинус
ArcSInh - Гиперболический арксинус
ArcTahn - Гиперболический арктангенс
ArcTan2 - Арктангенс с учетом квадранта (функция ArcTan,
не учитывающая квадрант, находится в модуле System)
Cosh - Гиперболический косинус
Cotan - Котангенс
CycleToRad - Преобразование циклов в радианы
DegToRad - Преобразование градусов в радианы
GradToRad - Преобразование градов в радианы
Hypot - Вычисление гипотенузы прямоугольного
треугольника по длинам катетов
RadToCycle - Преобразование радианов в циклы
RadToDeg - Преобразование радианов в градусы
RacIToGrad - Преобразование радианов в грады
SinCos - Вычисление синуса и косинуса угла. Как и в случае SumAndSquares и MeanAndStdDev, одновременная генерация обеих величин происходит быстрее
Sinh - Гиперболический синус
Tan - Тангенс
Tanh - Гиперболический тангенс

Арифметические функции и процедуры
Cell - Округление вверх
Floor - Округление вниз
Frexp - Вычисление мантиссы и порядка заданной величины
IntPower - Возведение числа в целую степень. Если вы не собираетесь пользоваться экспонентами с плавающей точкой, желательно использовать эту функцию из-за ее скорости
Ldexp - Умножение Х на 2 в заданной степени
LnXPI - Вычисление натурального логарифма Х+1. Рекомендуется для X, близких к нулю
LogN - Вычисление логарифма Х по основанию N
LogIO - Вычисление десятичного логарифмах
Log2 - Вычисление двоичного логарифмах
Power - Возведение числа в степень. Работает медленнее IntPower, но для операций с плавающей точкой вполне приемлемо

Финансовые функции и процедуры
DoubleDecliningBalance - Вычисление амортизации методом двойного баланса
FutureValue - Будущее значение вложения
InterestPayment - Вычисление процентов по ссуде
InterestRate - Норма прибыли, необходимая для получения заданной суммы
InternalRateOfReturn - Вычисление внутренней скорости оборота вложения для ряда последовательных выплат
NetPresentValue - Вычисление чистой текущей стоимости вложения для ряда последовательных выплат с учетом процентной ставки
NumberOf Periods - Количество периодов, за которое вложение достигнет заданной величины
Payment - Размер периодической выплаты, необходимой для погашения ссуды, при заданном числе периодов, процентной ставке, а также текущем и будущем значениях ссуды
PerlodPayment - Платежи по процентам за заданный период
PresentValue - Текущее значение вложения
SLNDepreclatlon - Вычисление амортизации методом постоянной нормы
SYDepreclatlon - Вычисление амортизации методом весовых коэффициентов

Статистические функции и процедуры
MaxIntValue - Максимальное значение в наборе целых чисел. Функция появилась в Delphi 3. ее не существует в Delphi 2
MaxValue - Максимальное значение в наборе чисел. В Delphi 2 функция возвращает минималъное значение
Mean - Среднее арифметическое для набора чисел
MeanAndStdDev - Одновременное вычисление среднего арифметического и стандартного отклонения для набора чисел. Вычисляется быстрее, чем обе величины по отдельности
MinIntValLie - Минимальное значение в наборе целых чисел. Функция появилась в Delphi 3, ее не существует в Delphi 2
MInValue - Минимальное значение в наборе чисел. В Delphi 2 функция возвращает максимальное значение
MoiiientSkewKurtosIs - Статистические моменты порядков с первого по четвертый, а также асимметрия (skew) и эксцесс (kurtosis) для набора чисел
Norm - Норма для набора данных (квадратный корень из суммы квадратов)
PopnStdDev - Выборочное стандартное отклонение. Отличается от обычного стандартного отклонения тем, что при вычислениях используется выборочное значение дисперсии, PopnVarl апсе (см. ниже)
PopnVarlance - Выборочная дисперсия. Использует "смещенную" формулу TotalVanance/n
RandG - Генерация нормально распределенных случайных чисел с заданным средним значением и
среднеквадратическим отклонением
StdDev - Среднеквадратическое отклонение для набора чисел
Sum - Сумма набора чисел
SLimsAndSquares - Одновременное вычисление суммы и суммы квадратов для набора чисел. Как и в других функциях модуля Math, обе величины вычисляются быстрее, чем по отдельности
Sumint - Сумма набора целых чисел. Функция появилась в Delphi 3, ее не существует в Delphi 2
SLimOfSquares - Сумма квадратов набора чисел
Total Variance - "Полная дисперсия" для набора чисел. Это сумма квадратов расстояний всех величин от их среднего арифметического
Variance - Выборочная дисперсия для набора чисел. Функция использует "несмещенную" формулу TotalVanапсе/ (п -1)



rtf в sgml

Здесь процедура, которую я использую для конвертации содержимого RichEdit
в код SGML. Она не создает полноценный HTML-файл, но Вы можете расширить
функциональность, указал, какие RTF-коды Вы желаете конвертировать в
какие-либо HTML-тэги.

function rtf2sgml (text : string) : string;
{Funktion for att konvertera en RTF-rad till SGML-text.}
var
temptext : string;
start : integer;
begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&');
text := stringreplaceall (text,'\'+chr(39)+'e5','a');
text := stringreplaceall (text,'\'+chr(39)+'c5','A');
text := stringreplaceall (text,'\'+chr(39)+'e4','a');
text := stringreplaceall (text,'\'+chr(39)+'c4','A');
text := stringreplaceall (text,'\'+chr(39)+'f6','o');
text := stringreplaceall (text,'\'+chr(39)+'d6','O');
text := stringreplaceall (text,'\'+chr(39)+'e9','e');
text := stringreplaceall (text,'\'+chr(39)+'c9','E');
text := stringreplaceall (text,'\'+chr(39)+'e1','a');
text := stringreplaceall (text,'\'+chr(39)+'c1','A');
text := stringreplaceall (text,'\'+chr(39)+'e0','a');
text := stringreplaceall (text,'\'+chr(39)+'c0','A');
text := stringreplaceall (text,'\'+chr(39)+'f2','o');
text := stringreplaceall (text,'\'+chr(39)+'d2','O');
text := stringreplaceall (text,'\'+chr(39)+'fc','u');
text := stringreplaceall (text,'\'+chr(39)+'dc','U');
text := stringreplaceall (text,'\'+chr(39)+'a3','?');
text := stringreplaceall (text,'\}','#]#');
text := stringreplaceall (text,'\{','#[#');
text := stringreplaceall (text,'{\rtf1\ansi\deff0\deftab720','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort}
text := stringreplaceall (text,'{\f0\fnil MS Sans Serif;}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\f1\fnil\fcharset2 Symbol;}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');{Skall alltid tas bort}
{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort
det efter \fs16 och la istallet en egen tvatt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}
text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');{Plocka fran deflang till pard for att fa }
text := stringreplace (text,temptext,'');{oavsett vilken lang det ar. Norska o svenska ar olika}
{Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu stadar vi istallet bort alla tvasiffriga fontsize.}
while pos ('\fs',text) >0 do
begin
application.processmessages;
start := pos ('\fs',text);
Delete(text,start,5);
end;
text := stringreplaceall (text,'\pard\plain\f0 ','
');
text := stringreplaceall (text,'\par \plain\f0\b\ul ','
');
text := stringreplaceall (text,'\plain\f0\b\ul ','
');
text := stringreplaceall (text,'\plain\f0','');
text := stringreplaceall (text,'\par }','
');
text := stringreplaceall (text,'\par ','
');
text := stringreplaceall (text,'#]#','}');
text := stringreplaceall (text,'#[#','{');
text := stringreplaceall (text,'\\','\');
result := text;
end;

//This is cut directly from the middle of a fairly long save routine that calls the above function.
//I know I could use streams instead of going through a separate file but I have not had the time
to change this

utfilnamn :=
mditted.exepath+stringreplace(stringreplace(extractfilename(pathname),'.TTT',''),'.ttt','') +
'ut.RTF';
brodtext.lines.savetofile (utfilnamn);
temptext := '';
assignfile(tempF,utfilnamn);
reset (tempF);
try
while not eof(tempF) do
begin
readln (tempF,temptext2);
temptext2 := stringreplaceall (temptext2,'\'+chr(39)+'b6','');
temptext2 := rtf2sgml (temptext2);
if temptext2 <>'' then temptext := temptext+temptext2;
application.processmessages;
end;
finally
closefile (tempF);
end;
deletefile (utfilnamn);
temptext := stringreplaceall (temptext,' ','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
'+chr(0),'
');
temptext := stringreplaceall (temptext,'
','');
temptext := stringreplaceall (temptext,'
','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'','<#MELLIS>
');
temptext := stringreplaceall (temptext,'<#MELLIS>','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
-','
_');
temptext := stringreplaceall (temptext,'
_','_');
while pos('_',temptext)>0 do
begin
application.processmessages;
temptext2 := hamtastreng (temptext,'_','
');
temptext := stringreplace (temptext,temptext2+'
',temptext2+'');
temptext := stringreplace (temptext,'_','-');
end;
writeln (F,''+temptext+'');



пример программирования com портов

unit TestRosh;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
Label1: TLabel;
PortCombo: TComboBox;
Label2: TLabel;
BaudCombo: TComboBox;
Label3: TLabel;
ByteSizeCombo: TComboBox;
Label4: TLabel;
ParityCombo: TComboBox;
Label5: TLabel;
StopBitsCombo: TComboBox;
Label6: TLabel;
Memo1: TMemo;
Edit1: TEdit;
Button1: TButton;
Memo2: TMemo;
Edit2: TEdit;
Label7: TLabel;
Button2: TButton;
Label8: TLabel;
Edit3: TEdit;
procedure Button1Click(Sender: TObject);
procedure Memo2Change(Sender: TObject);
procedure Memo1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure PortComboChange(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Memo1DblClick(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses Registry;
var
hPort: THandle;
procedure TForm1.Memo1Change(Sender: TObject);
var
i: Integer;
begin
Edit1.Text := '';
for i := 1 to Length(Memo1.Text) do
Edit1.Text := Edit1.Text + Format('%x', [Ord(Memo1.Text[i])]) + ' '
end;
procedure TForm1.Memo2Change(Sender: TObject);
var
i: Integer;
begin
Edit2.Text := '';
for i := 1 to Length(Memo2.Text) do
Edit2.Text := Edit2.Text + Format('%x', [Ord(Memo2.Text[i])]) + ' '
end;
procedure TForm1.Button1Click(Sender: TObject);
var
S, D: array[0..127] of Char;
actual_bytes: Integer;
DCB: TDCB;
begin
FillChar(S, 128, #0);
FillChar(D, 128, #0);
DCB.DCBlength := SizeOf(DCB);
if not GetCommState(hPort, DCB) then begin
ShowMessage('Can''t get port state: ' + IntToStr(GetLastError));
Exit;
end;
try
DCB.BaudRate := StrToInt(BaudCombo.Text);
except
BaudCombo.Text := IntToStr(DCB.BaudRate);
end;
try
DCB.ByteSize := StrToInt(ByteSizeCombo.Text);
except
ByteSizeCombo.Text := IntToStr(DCB.ByteSize);
end;
if ParityCombo.ItemIndex > -1 then
DCB.Parity := ParityCombo.ItemIndex
else
ParityCombo.ItemIndex := DCB.Parity;
if StopBitsCombo.ItemIndex > -1 then
DCB.StopBits := StopBitsCombo.ItemIndex
else
StopBitsCombo.ItemIndex := DCB.StopBits;
if not SetCommState(hPort, DCB) then begin
ShowMessage('Can''t set new port settings: ' + IntToStr(GetLastError));
Exit;
end;
PurgeComm(hPort, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);
StrPCopy(S, Memo1.Text);
if not WriteFile(hPort, S, StrLen(S), actual_bytes, nil) then begin
ShowMessage('Can''t write to port: ' + IntToStr(GetLastError));
Exit;
end;
if not ReadFile(hPort, D, StrToInt(Edit3.Text), actual_bytes, nil) then
ShowMessage('Can''t read from port: ' + IntToStr(GetLastError))
else
ShowMessage('Read ' + IntToStr(actual_bytes) + ' bytes');
Memo2.Text := D;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
with TRegistry.Create do begin
OpenKey('Shkila', True);
WriteString('Port', PortCombo.Text);
WriteString('Baud Rate', BaudCombo.Text);
WriteString('Byte Size', ByteSizeCombo.Text);
WriteString('Parity', IntToStr(ParityCombo.ItemIndex));
WriteString('Stop Bits', IntToStr(StopBitsCombo.ItemIndex));
Destroy;
end;
if not CloseHandle(hPort) then begin
ShowMessage('Can''t close port: ' + IntToStr(GetLastError));
Exit;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
hPort := CreateFile(PChar(PortCombo.Text),
GENERIC_READ + GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hPort = INVALID_HANDLE_VALUE then
ShowMessage('Can''t open ' + PortCombo.Text + ': ' + IntToStr(GetLastError))
else
Button2.Hide;
end;
procedure TForm1.PortComboChange(Sender: TObject);
begin
FormDestroy(Sender);
Button2.Show;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
with TRegistry.Create do begin
OpenKey('Shkila', True);
PortCombo.Text := ReadString('Port');
BaudCombo.Text := ReadString('Baud Rate');
ByteSizeCombo.Text := ReadString('Byte Size');
ParityCombo.ItemIndex := StrToInt(ReadString('Parity'));
StopBitsCombo.ItemIndex := StrToInt(ReadString('Stop Bits'));
Destroy;
end;
end;
procedure TForm1.Memo1DblClick(Sender: TObject);
begin
Memo1.Lines.Clear;
Memo2.Lines.Clear;
Edit1.Text := '';
Edit2.Text := '';
end;
end.



вывод текста на печать, используя com порт

Var
Printer: THandle;
N : Cardinal;
C : POverlapped;
begin
//Открываем порт принтера для записи
Printer := CreateFile(PChar('LPT1'),
GENERIC_READ or GENERIC_WRITE,0,nil,
OPEN_EXISTING,FILE_FLAG_OVERLAPPED,0);
//Печатаем слово 'Hello World';
WriteFile(Printer,'Hello World',11,N,c);
//Закрываем порт
CloseHandle(Printer);



создание компонента

Разработка собственных компонентов
Если вас не устраивают стандартные компоненты, поставляемые вместе с Delphi, значит, вам пора попробовать себя в создtании своих собственных. Сначала мы начнем с простых и постепенно перейдем к более сложным. И так, начнем.
Перед созданием своего компонента важно правильно выбрать для него предка. Кто же может быть предком для вашего компонента? Как правило, используются в виде предков TComponent, TControl, TWinControl, TGraphicControl, TCustomXXXXXX, а также все компоненты палитры компонентов. Возьмем для примера компонент TOpenDialog, который находится на странице Dialogs палитры компонентов. Он хорошо справляется со своей задачей, но у него есть одно маленькое неудобство. Каждый раз, когда его используешь необходимо каждый раз изменять значение свойства Options. И причем это, как правило, одни и те же действия.
OpenDialog1.Options := OpenDialog1.Options + [ofFileMustExist, ofPathMustExist]; чтобы файл, который мы пытаемся ткрыть с помощью этого диалогового окна, действительно существовал на диске. Задание для себя мы уже выбрали, осталось за малым - создать компонент. Заготовку для компонента создаем, выбирая из меню команду Component/New Component... и в диалоговом окне выбираем
Ancestor type: TOpenDialog
Class Name: TOurOpenDialog
Palette Page: Our Test
Нажали Ok и у нас появился шаблон нашего будущего компонента.
Переопределяем конструктор у этого компонента, т.е. в секции public вставляем строку:
constructor Create(AOwner: TComponent); override;
нажатие на этой строке Ctrl + Shift + C создает шаблон для этого метода, внутри которого мы вставляем такие строки:
inherited Create(AOwner); {Вызываем унаследованный конструктор}
Options := Options + [ofFileMustExist, ofPathMustExist]; {Выполняем необходимые нам действия}
Установка созданного компонента Component/Install Component...
Install Into New Package
Package file name: C:\Program Files\Borland\Delphi4\Lib\OurTest.dpk
Package description: Our tested package
Вам не нравится, что у нашего компонента иконка такая же как у стандартного? Тогда создадим для него свою собственную. Для этого нам необходимо вызвать Tools/Image Editor. Создаем новый *.dcr файл. Вставляем в него рисунок Resource/New/Bitmap. Устанавливаем размер картинки 24x24 точек. А дальше - ваше творчество... Обратите внимание: цвет точек, совпадающий с цветом точки в левом нижнем углу рисунка, будет считаться ПРОЗРАЧНЫМ!
После того как вы создали свой рисунок, переименуйте его из Bitmap1 в TOurOpenDialog и сохраните файл с именем OurOpenDialog.dcr. Удалите компонент из пакета и установите его снова (только в этом случае добавится и ссылка на *.dcr файл).
Compile, Install и удачи!



база данных методами object pascal

В статье рассматривается работа с бинарными файлами из Delphi, а так же использование Object Pascal для управления записью, чтением и изменением собственных типов файлов.
Постановка задачи: Допустим, мне нужно в приложении Delphi сохранять некоторую информацию на диск. Мне не охото работать с текстовыми файлами, так как просмотр и обновление информации в них довольно муторное занятие. Преобладать будут операции записи и чтения, в то время как операции изменения и апдейта будут присутствовать в меньшей степени. Вся информация будет хранится в переопределённом типе данных Pascal Record. Итак, какой подход мне лучше всего использовать?
BDE плюс Paradox или Access, ... спасибо, не надо...Не хотелось бы испытывать мороку с BDE. Использовать текстовые файлы ASCII ? Не пойдёт. Нужна хоть какая-то минимальная защита, а текстовые файлы "полностью видимы". Оказывается, ответ на данный вопрос кроется в Delphi, а именно в непечатных файлах (или файлы некоторых типов/бинарные файлы).
Файлы
В Delphi существует три класса файлов: typed, text, и untyped. Файлы typed - это файлы, которые содержат данные определённого типа, такие как Double, Integer или предварительно определённый тип Record. Текстовые файлы содержат читаемые символы ASCII. Файлы Untyped используются в том случае, если мы хотим работать с файлом через определённую структуру.
Файлы Typed
В отличие от тектовых файлов, которые содержат строки, завершающиеся комбинацией CR/LF, файлы typed содержат данные, взятые из определённой структуры данных.
Например, следующее объявление создаёт запись с именем TMember и массив переменных типа TMember, который мы будем использовать для хранения нашей информации.
type
TMember = record
Name : string[50];
eMail : string[30];
Posts : LongInt;
end;
var Members : array[1..50] of TMember;
Перед тем, как мы сможем записать информацию на диск, нам необходимо объявить переменную типа file. Следующая строка объявляет переменную файла F:
var F : file of TMember;
Обратите внимание: Чтобы создать файл typed в Delphi, мы используем следующий синтакс:
var SomeTypedFile : file of SomeType
Базовый тип (SomeType) для файла может быть скалярным (наподобие Double), массивом или записью. Он не может быть длинной строкой, динамическим массивом, классом, объектом или указателем.
Чтобы начать работать с файлом из Delphi нам надо связать файл на диске с переменной файла в нашей программе. Для этого используем процедуру AssignFile.
AssignFile(F, 'Members.dat')
Как только связь с внешним файлом установлена, переменную F необходимо 'открыть' для подготовки её к чтению или записи. Для открытия существующего файла мы используем процедуру Reset либо Rewrite для создания нового файла. После того, как программа закончит обработку файла, его необходимо закрыть при помощи процедуры CloseFile. Сразу после закрытия файла, связанный с ним внешний файл будет обновлён. Затем переменную файла можно связать с другим внешним файлом. Вообще, мы должны всегда производить обработку исключительных ситуаций, так как при работе с файлами может происходить довольно много ошибок. Например, если мы вызовем CloseFile для файла, который уже закрыт, то Delphi выдаст ошибку I/O. С другой стороны, если мы попробуем закрыть файл, до вызова AssignFile, то результаты могут быть непредсказуемыми.
Запись
Предположим, что у нас есть массив, заполненный именами, e-мейлами и т.д., и мы хотим сохранить эту информацию на диск. Делается это следующим образом:
var F : file of TMember;
begin
AssignFile(F,'members.dat');
Rewrite(F);
try
for i:= 1 to 50 do
Write (F, Members[i]);
finally
CloseFile(F);
end;
end;
Чтение
Для получения всей информации из файла 'members.dat' используется следующий код:
var Member: TMember
F : file of TMember;
begin
AssignFile(F,'members.dat');
Reset(F);
try
while not Eof(F) do begin
Read (F, Member);
{ Что-нибудь делаем с данными; }
end;
finally
CloseFile(F);
end;
end;
Обратите внимание: Eof это функция проверки конца файла (EndOfFile). Мы используем эту функцию, чтобы не выйти за пределы файла (за пределы последней, сохранённой записи).
Поиск и позиционирование
Обычно, доступ к файлам осуществляется последовательно. При чтении из файла (используя стандартную процедуру Read) или при записи (используя стандартную процедуру Write), текущая позиция в файле перемещается на следующий по порядку компонент (следующая запись). К файлам typed так же можно обращаться через стандартную процедуру Seek, которая перемещает текущую позицию в файле на указанный компонент. Для определения текущей позиции в файле и размера файла можно использовать функции FilePos и FileSize.
{устанавливаем на начало - на первую запись}
Seek(F, 0);
{устанавливаем на 5-ю запись}
Seek(F, 5);
{Переходим в конец - "после" последней записи}
Seek(F, FileSize(F));
Изменение и обновление
Мы разобрались как записывать и считывать из файла массив Members. А что, если нам нужно найти десятую запись и изменить в ней e-mail? Давайте посмотрим на процедуру, которая делает это:
procedure ChangeEMail
(const RecN : integer; const NewEMail : string);
var DummyMember : TMember;
begin
{связывание, открытие, блок обработки исключений}
Seek(F, RecN);
Read(F, DummyMember);
DummyMember.Email := NewEMail;
{чтение перемещается на следующую запись, для этого необходимо
вернуться на первоначальную запись, а затем записать}
Seek(F, RecN);
Write(F, DummyMember);
{закрываем файл}
end;
Всё готово
Итак, теперь мы имеем всё, что нам нужно для реализации нашей задачи. Мы можем записать информацию на диск, считать её, и даже изменить некоторые данные (например, e-mail) в "середине" файла.
Самое главное, что этот файл не в ASCII формате !
--------------------------------------------------------------------------------
Общий вид модуля выглядит примерно так [здесь для наглядности данные выводятся в StringGrid'e]:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids;
type
TMember = record
Name : string[50];
eMail : string[30];
Posts : LongInt;
end;
type
TForm1 = class(TForm)
SaveBtn: TButton;
EnterDataToArrayBtn: TButton;
OpenBtn: TButton;
StringGrid1: TStringGrid;
ChangeEmailBtn: TButton;
procedure SaveBtnClick(Sender: TObject);
procedure EnterDataToArrayBtnClick(Sender: TObject);
procedure OpenBtnClick(Sender: TObject);
procedure ChangeEmailBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Members : array[1..50] of TMember;
implementation
{$R *.DFM}
procedure TForm1.SaveBtnClick(Sender: TObject);
var
F : file of TMember;
i:integer;
begin
AssignFile(F,'members.dat');
Rewrite(F);
try
for i:= 1 to 50 do
Write (F, Members[i]);
finally
CloseFile(F);
end;
end;
procedure TForm1.EnterDataToArrayBtnClick(Sender: TObject);
begin
Members[1].Name:='Nikolay';
Members[1].eMail:='bestprogramming@mail.ru';
Members[1].Posts:=10;
Members[2].Name:='Maryana';
Members[2].eMail:='maryana28@narod.ru';
Members[2].Posts:=28;
Members[3].Name:='Janina';
Members[3].eMail:='JaninaArgentum@mail.ru';
Members[3].Posts:=5;
end;
procedure TForm1.OpenBtnClick(Sender: TObject);
var
ReadMembers : array[1..50] of TMember;
F : file of TMember;
i:integer;
begin
AssignFile(F,'members.dat');
Reset(F);
try
i:=0;
while not Eof(F) do begin
Read (F, ReadMembers[i]);
////////////////////////
StringGrid1.Cells[0,i]:=ReadMembers[i].Name;
StringGrid1.Cells[1,i]:=ReadMembers[i].eMail;
StringGrid1.Cells[2,i]:=IntToStr(ReadMembers[i].Posts);
////////////////////////
i:=i+1;
end;
finally
CloseFile(F);
end;
end;
procedure ChangeEMail (const RecN : integer; const NewEMail : string);
var
DummyMember : TMember;
F : file of TMember;
begin
AssignFile(F,ExtractFilePath(Application.ExeName)+'members.dat');
Reset(F);
Seek(F, RecN);
Read(F, DummyMember);
DummyMember.Email := NewEMail;
{чтение перемещается на следующую запись, для этого необходимо
вернуться на первоначальную запись, а затем записать}
Seek(F, RecN);
Write(F, DummyMember);
CloseFile(F);
end;
procedure TForm1.ChangeEmailBtnClick(Sender: TObject);
begin
ChangeEmail(2,'NewJaninaEmail@Girl.com');
end;
end.



прозрачное окно

Для создания прозрачного окна Вам понадобится:
Форма - 1 штука,
Время - 5 минут,
Желание - неимоверное.
Если всё это у Вас в наличии имеется, то можете смело приступать к выполнению следующих действий:
Первым делом в защищённых объявлениях (после слова protected) объявим две процедуры. Изначально это слово отсутствует, поэтому Вам придётся самим вписать его (можно до слова public):
protected
procedure RebuildWindowRgn;
procedure Resize; override;
Затем в публичных объявлениях (теперь уже в public)размещаем объявление конструктора. Нам его нужно переопределить, поэтому добавляем ключевое слово override:
constructor Create(AOwner:TComponent);override;
В области реализации (после слова implementation) описываем конструктор так:
implementation
{$R *.DFM}
constructor TForm1.Create(AOwner:TComponent);
begin
inherited;
HorzScrollbar.Visible:=false;
VertScrollbar.Visible:=false;
RebuildWindowRgn;
end;
Ресурс формы {$R *.DFM} оставляем без изменений. Слово inherited свидетельствует о том, что используется стандартный обработчик этой процедуры. Мы лишь убрали полосы прокрутки
HorzScrollbar.Visible:=false;
VertScrollbar.Visible:=false;
(скролбары), чтобы они не мешались. И построили регион с помощью процедуры RebuildWindowRgn.
Тело переобъявленной процедуры Resize выглядит так:
procedure TForm1.Resize;
begin
inherited;
RebuildWindowRgn;
end;
Здесь мы всего лишь перестраиваем регион, когда пользователь изменяет размер окна.
И, наконец, описываем процедуру RebuildWindowRgn:
procedure TForm1.RebuildWindowRgn;
var
FullRgn,Rgn:THandle;
ClientX,ClientY,i:integer;
begin
ClientX:=(Width-ClientWidth) div 2;
ClientY:=Height-ClientHeight-ClientX;
FullRgn:=CreateRectRgn(0,0,Width,Height);
Rgn:=CreateRectRgn(ClientX,ClientY,ClientX+ClientWidth,ClientY+ClientHeight);
CombineRgn(FullRgn,FullRgn,Rgn,RGN_DIFF);
for i:=0 to ControlCount-1 do
with Controls[i] do begin
Rgn:=CreateRectRgn(ClientX+Left,ClientY+Top,ClientX+Left+Width,ClientY+Top+Height);
CombineRgn(FullRgn,FullRgn,Rgn,RGN_OR);
end;
SetWindowRgn(Handle,FullRgn,true);
end;
Как это сделано?
В переменные ClientX и ClientY мы помещаем относительные координаты клиентской части. Создаём регион для всей формы:
FullRgn:=CreateRectRgn(0,0,Width,Height);
Создаём регион для клиентской части формы и вычитаем его из FullRgn
Rgn:=CreateRectRgn(ClientX,ClientY,ClientX+ClientWidth,ClientY+ClientHeight);
CombineRgn(FullRgn,FullRgn,Rgn,RGN_DIFF);
Добавляем в цикле к FullRgn регионы каждого контрольного элемента.
for i:=0 to ControlCount-1 do
with Controls[i] do begin
Rgn:=CreateRectRgn(ClientX+Left,ClientY+Top,ClientX+Left+Width,ClientY+Top+Height);
CombineRgn(FullRgn,FullRgn,Rgn,RGN_OR);
end;
Устанавливаем новый регион окна
SetWindowRgn(Handle,FullRgn,true);



эллипсовидное окно

Для начала нужно обеспечить возможность пользователю перемещать окно, хватаясь за клиентскую область, а не за заголовочную, т.к. полосы заголовка, собственно, у нас нет.Сначала в частных объявлениях (после слова private) объявляем процедуру:
private
procedure WMNCHitTest(var M:TWMNCHitTest);message wm_NCHitTest;
Затем в разделе implementation описываем её так:
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest(var M:TWMNCHitTest);
begin
inherited;
if M.Result=htClient then M.Result:=htCaption;
end;
Далее самое главное. По созданию окна (событие OnCreate) пишем следующий код:
procedure TForm1.FormCreate(Sender: TObject);
var
hsWindowRegion:Integer;
begin
hsWindowRegion:=CreateEllipticRgn(50,50,350,200);
SetWindowRgn(Handle,hsWindowRegion,true);
end;
Как это сделано?
Сначала мы объявляем переменную типа Integer, называем её hsWindowRegion.В неё в дальнейшем мы поместим дескриптор созданного региона. Затем, с помощью функции CreateEllipticRgn создаём регион эллипсовидной формы. В скобках ей указываем координаты для построения эллипса. В зависимости от того, какие значения вы укажите, такого размера и создастся ваш эллипс. После того, как регион создан, осталось только применить его к форме. Это делается с помощью следующего кода:
SetWindowRgn(Handle,hsWindowRegion,true);
Вышеуказанной функции в качестве параметров нужно указать три вещи. Это:
1) дескриптор окна,
2) дескриптор применяемого региона и
3) указать будет ли перерисован регион (true - истина, false - ложь)



окно в виде кольца

Умея создавать окно эллипсовидной формы, для вас не составит большого труда слепить что-нибудь наподобие того, что показано на рисунке. Всё, что вам нужно сделать - это создать не один, а два региона и объединить их, используя функцию CombineRgn, т.е. теперь по созданию окна можно написать что-то вроде этого:
procedure TForm1.FormCreate(Sender: TObject);
var
hsWindowRegion, hsWindowRegion2:Integer;
begin
hsWindowRegion:=CreateEllipticRgn(50,50,350,200);
hsWindowRegion2:=CreateEllipticRgn(80,80,200,150);
CombineRgn(hsWindowRegion,hsWindowRegion,hsWindowRegion2,RGN_DIFF);
SetWindowRgn(Handle,hsWindowRegion,true);
end;
Как это сделано?
Мы уже знаем какую функцию нужно использовать для объединения регионов, но как же она действует и что же ей нужно указывать? Вводятся следующие параметры:
1) Дескриптор региона назначения,
2) Дескриптор первого региона источника,
3) Дескриптор второго региона источника,
4) Режим взаимодействия регионов источников.
В качестве режима мы указали константу RGN_DIFF, а использовать можем:
RGN_AND - Создает пересечение из двух смешанных областей,
RGN_COPY - Создает копию области, идентифицированной дескриптором первой области источника,
RGN_DIFF - Выводит части первой области источника, которые не пересекаются со второй,
RGN_OR - Создает объединение двух смешанных областей,
RGN_XOR - Создает объединение двух смешанных областей за исключением зоны перекрытия.



окно в виде крутого кольца

unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, StdCtrls;
type
TForm1 = class(TForm)
SpeedButton1: TSpeedButton;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
rTitleBar : THandle;
Center : TPoint;
CapY : Integer;
Circum : Double;
SB1 : TSpeedButton;
RL, RR : Double;
procedure TitleBar(Act : Boolean);
procedure WMNCHITTEST(var Msg: TWMNCHitTest);
message WM_NCHITTEST;
procedure WMNCACTIVATE(var Msg: TWMNCACTIVATE);
message WM_NCACTIVATE;
procedure WMSetText(var Msg: TWMSetText);
message WM_SETTEXT;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
CONST TitlColors : ARRAY[Boolean] OF TColor = (clInactiveCaption, clActiveCaption); TxtColors : ARRAY[Boolean] OF TColor = (clInactiveCaptionText, clCaptionText);
procedure TForm1.FormCreate(Sender: TObject);
VAR
rTemp, rTemp2 : THandle;
Vertices : ARRAY[0..2] OF TPoint;
X, Y : INteger;
begin
Caption := 'OOOH! Doughnuts!';
BorderStyle := bsNone; {required}
IF Width > Height THEN Width := Height
ELSE Height := Width; {harder to calc if width <> height}
Center := Point(Width DIV 2, Height DIV 2);
CapY := GetSystemMetrics(SM_CYCAPTION)+8;
rTemp := CreateEllipticRgn(0, 0, Width, Height);
rTemp2 := CreateEllipticRgn((Width DIV 4), (Height DIV 4),
3*(Width DIV 4), 3*(Height DIV 4));
CombineRgn(rTemp, rTemp, rTemp2, RGN_DIFF);
SetWindowRgn(Handle, rTemp, True);
DeleteObject(rTemp2);
rTitleBar := CreateEllipticRgn(4, 4, Width-4, Height-4);
rTemp := CreateEllipticRgn(CapY, CapY, Width-CapY, Height-CapY);
CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_DIFF);
Vertices[0] := Point(0,0);
Vertices[1] := Point(Width, 0);
Vertices[2] := Point(Width DIV 2, Height DIV 2);
rTemp := CreatePolygonRgn(Vertices, 3, ALTERNATE);
CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_AND);
DeleteObject(rTemp);
RL := ArcTan(Width / Height);
RR := -RL + (22 / Center.X);
X := Center.X-Round((Center.X-1-(CapY DIV 2))*Sin(RR));
Y := Center.Y-Round((Center.Y-1-(CapY DIV 2))*Cos(RR));
SB1 := TSpeedButton.Create(Self);
WITH SB1 DO
BEGIN
Parent := Self;
Left := X;
Top := Y;
Width := 14;
Height := 14;
OnClick := Button1Click;
Caption := 'X';
Font.Style := [fsBold];
END;
end;
procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitTest);
begin
Inherited;
WITH Msg DO
WITH ScreenToClient(Point(XPos,YPos)) DO
IF PtInRegion(rTitleBar, X, Y) AND
(NOT PtInRect(SB1.BoundsRect, Point(X,Y))) THEN
Result := htCaption;
end;
procedure TForm1.WMNCActivate(var Msg: TWMncActivate);
begin
Inherited;
TitleBar(Msg.Active);
end;
procedure TForm1.WMSetText(var Msg: TWMSetText);
begin
Inherited;
TitleBar(Active);
end;
procedure TForm1.TitleBar(Act: Boolean);
VAR
TF : TLogFont;
R : Double;
N, X, Y : Integer;
begin
IF Center.X = 0 THEN Exit;
WITH Canvas DO
begin
Brush.Style := bsSolid;
Brush.Color := TitlColors[Act];
PaintRgn(Handle, rTitleBar);
R := RL;
Brush.Color := TitlColors[Act];
Font.Name := 'Arial';
Font.Size := 12;
Font.Color := TxtColors[Act];
Font.Style := [fsBold];
GetObject(Font.Handle, SizeOf(TLogFont), @TF);
FOR N := 1 TO Length(Caption) DO
BEGIN
X := Center.X-Round((Center.X-6)*Sin(R));
Y := Center.Y-Round((Center.Y-6)*Cos(R));
TF.lfEscapement := Round(R * 1800 / pi);
Font.Handle := CreateFontIndirect(TF);
TextOut(X, Y, Caption[N]);
R := R - (((TextWidth(Caption[N]))+2) / Center.X);
IF R < RR THEN Break;
END;
Font.Name := 'MS Sans Serif';
Font.Size := 8;
Font.Color := clWindowText;
Font.Style := [];
end;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
WITH Canvas DO
BEGIN
Pen.Color := clBlack;
Brush.Style := bsClear;
Pen.Width := 1;
Pen.Color := clWhite;
Arc(1, 1, Width-1, Height-1, Width, 0, 0, Height);
Arc((Width DIV 4)-1, (Height DIV 4)-1,
3*(Width DIV 4)+1, 3*(Height DIV 4)+1, 0, Height, Width, 0);
Pen.Color := clBlack;
Arc(1, 1, Width-1, Height-1, 0, Height, Width, 0);
Arc((Width DIV 4)-1, (Height DIV 4)-1,
3*(Width DIV 4)+1, 3*(Height DIV 4)+1, Width, 0, 0, Height);
TitleBar(Active);
END;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
end.



окно в виде звезды

Если вы хотите создать самое необычное окно, тогда нужно будет подготовить для него оболочку (например в PhotoShop'е). На рисунке показан пример с часами. Здесь используется один эллипсовидный и один многоугольный регион. По центру окна выведена метка, в которой показывается текущее время. Как это всё сделать рассмотрим подробнее.
Общий вид модуля может быть примерно таким:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, jpeg;
type
TForm1 = class(TForm)
Label1: TLabel; //Это метка для отображения времени
Timer1: TTimer; //Это таймер - с помощью него мы отображаем время
Image1: TImage; //Компонент Image - нужен для вывода рисунка на форме
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{Для перемещения формы вне заголовка объявляем процедуру}
procedure WMNCHitTest(var M:TWMNCHitTest);message wm_NCHitTest;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
{Для перемещения формы вне заголовка описываем процедуру}
procedure TForm1.WMNCHitTest(var M:TWMNCHitTest);
begin
inherited;
if M.Result=htClient then M.Result:=htCaption;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
hsWindowRegion,hsWindowRegion2:integer;
p:array [0..11]of TPoint;
begin
p[0].x:=30; p[0].y:=40;
p[1].x:=80; p[1].y:=70;
p[2].x:=95; p[2].y:=20;
p[3].x:=110; p[3].y:=70;
p[4].x:=160; p[4].y:=40;
p[5].x:=130; p[5].y:=85;
p[6].x:=260; p[6].y:=230;
p[7].x:=110; p[7].y:=100;
p[8].x:=95; p[8].y:=200;
p[9].x:=80; p[9].y:=100;
p[10].x:=30; p[10].y:=130;
p[11].x:=60; p[11].y:=85;
hsWindowRegion:=CreatePolygonRgn(P,12,Alternate);
hsWindowRegion2:=CreateEllipticRgn(50,50,140,120);
CombineRgn(hsWindowRegion,hsWindowRegion,hsWindowRegion2,rgn_or);
SetWindowRgn(Handle,hsWindowRegion,true);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption:=TimeToStr(Time);
end;
end.
Как это сделано?
По созданию окна создаём два региона, их дескрипторы помещаем в переменные hsWindowRegion, hsWindowRegion2. Для многоугольного региона создаём массив точек. Для каждого элемента массива - для каждой точки - указываем координаты по осям Х & Y. Комбинируем регионы в режиме rgn_or, чтобы области объединились:
CombineRgn(hsWindowRegion,hsWindowRegion,hsWindowRegion2,rgn_or);
Устанавливаем созданный регион:
SetWindowRgn(Handle,hsWindowRegion,true);
Чтобы в метке показывалось системное время, делаем следующее: выносим компонент Timer - он выполняет указанный код спустя заданное количество (в свойстве Interval) миллисекунд. Оставим значение этого свойства без изменения, равным 1000 миллисекунд - это 1 секунда. А по событию OnTimer напишем следующее:
Label1.Caption:=TimeToStr(Time);
Time - функция, выдающая текущее время.
TimeToStr - функция переводящая время в текстовую строку
Так как интервал у таймера равен одной секунде, то текущее время будет постоянно обновляться. В итоге - часы идут!



изменить системное меню

Многие, наверное, уже задумывались над тем, как же внести изменения в системное меню. На примере вы видите, что кнопка закрытия окна неактивна. К тому же команда "Закрыть" вообще отсутствует в системном меню.(Системное меню вызывается по щелчку на иконке окна или Alt+Space)
Если вы напишите следующий код на создание окна (событие OnCreate), то сможете сами в этом убедиться.
procedure TForm1.FormCreate(Sender: TObject);
var
hMenuHandle:HMENU;
begin
hMenuHandle:=GetSystemMenu(Handle, false);
if hMenuHandle<>0 then begin
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
end;
Как это сделано?
Объявляем переменную типа HMENU. Получаем дескриптор своего системного меню и помещаем его в переменную:
hMenuHandle:=GetSystemMenu(Handle,false);
Получить дескриптор позволяет функция GetSystemMenu. Ей в качестве параметра указываем ключевое слово Handle - оно указывает, что будет получен дескриптор нашего системного меню. Второй параметр, равный false, означает, что возвращаемое функцией значение будет не нулевое, а равное дескриптору меню окна.
Функция DeleteMenu позволяет удалить пункт меню. Сначала ей указываем дескриптор меню - hMenuHandle, затем (SC_CLOSE) значение, идентифицирующее пункт меню, которое может принимать следующие значания:
sc_close - "Закрыть",
sc_move - "Переместить",
sc_size - "Размер",
sc_minimize - "Свернуть",
sc_maximize - "Развернуть"... и т.д.
Последний параметр (MF_BYCOMMAND) означает, что предыдущий параметр дает идентификатор пункта меню. Если бы предыдущий параметр указывал на положение пункта меню, отсчитываемое от нуля, тогда бы мы написали MF_BYPOSITION.
Вот теперь вы можете смело менять наличие и активность того или иного пункта системного меню! Плюс к тому, если вы заботитесь о наличии и активности кнопок на заголовочной полосе, соответствующих пунктам меню, то можете поэкспериментировать со свойствами окна BorderStyle & BorderIcons.



наполовину активное окно

Как сделать так, чтобы окно было неактивно? Вы скажите: "Ничего сложного. Нужно только свойство окна Enabled установить в false"... но, так как окно является владельцем компонентов, находящихся на нём, то и все компоненты станут неактивными! Но был найден способ избежать этого!
Делаем так:
Нужно объявить процедуру в частных объявлениям (после ключевого слова Private):
private
{ Private declarations }
procedure WMNCHitTest (var M:TWMNCHitTest);message wm_NCHitTest;
В области implementation описываем процедуру так:
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest (var M:TWMNCHitTest);
begin
if M.Result=htClient then M.Result:=htCaption;
end;



ограничение размеров окна

Нужно объявить процедуру в частных объявлениям (после ключевого слова Private):
private
{ Private declarations }
procedure WMGetMinMaxInfo(var Info:TWMGetMinMaxInfo); message wm_GetMinMaxInfo;
В области implementation описываем процедуру так: implementation
{$R *.DFM}
procedure TForm1.WMGetMinMaxInfo(var Info:TWMGetMinMaxInfo);
begin
with Info.MinMaxInfo^ do begin
ptMinTrackSize.x:=200;
ptMinTrackSize.y:=100;
ptMaxTrackSize.x:=300;
ptMaxTrackSize.y:=200;
ptMaxPosition.x:=BoundsRect.Left;
ptMaxPosition.y:=BoundsRect.top;
end;
inherited;
end;
Как это сделано?
Строка
ptMinTrackSize.x:=200;
задаёт минимальный размер окна по оси Х, т.е. минимальную ширину окна, строка
ptMinTrackSize.y:=200;
- минимальную высоту. Максимальные лимиты задаются соответственно:
ptMaxTrackSize.x:=300;
ptMaxTrackSize.y:=200;
Даже если пользователь развернёт окно, оно не превысит максимальные значения, указанные нами! Следующие две строки задают положение левого верхнего угла окна в развёрнутом виде
ptMaxPosition.x:=BoundsRect.Left;
ptMaxPosition.y:=BoundsRect.top;
- левый верхний угол не сместиться



меню с правой стороны

Главное меню окна – до боли знакомая вещь. Какое же извращение придумать с ним?..
Весьма необычно будет, если какой-нибудь пункт меню будет обособленно располагаться с правой стороны окна! (или несколько пунктов меню). Как же это сделать? Для этого нужно иметь: компонент MainMenu – 1 штука, форма – 1 штука, клава – 2 штуки (одна для того, чтобы набить ту чушь, что расположена ниже, а другая, являющаяся особой женского пола – для одних только вам известных забав). Начнём с первой (тем более, что кончить на второй всегда успеем!).
Всё что нужно сделать для этого – это создать главное меню, например, показанное на рисунке, и по созданию окна (событие OnCreate) написать следующий код:
procedure TForm1.FormCreate(Sender: TObject);
begin
ModifyMenu(MainMenu1.Handle,3,mf_ByPosition or mf_Popup or mf_Help,Help1.Handle,PChar(Help1.Caption));
end;



анимированная иконка приложения

Увидев анимацию на форме, мы не удивимся, но сейчас нам предстоит освоить более сложную технологию: мы попытаемся анимировать иконку приложения, ту самую, которая находится на панели задач на кнопке нашего exe-файла!
Сначала нужно будет создать каждый кадр потенциального анимационного клипа. Для этого запустим утилиту "Image Editor", которая в ходит в стандартный пакет Delphi. Запустить её можно одноимённой командой из меню Tools[инструменты]. Там создаём несколько bmp-файлов размером 16х16.
После чего возвращаемся в Delphi и выносим на форму компонент класса TImageList, дважды щёлкаем на нём и с помощью кнопки Add последовательно добавляем созданные кадры. В каком порядке изображения будут добавляться, в таком же порядке они затем будут выводится.
Далее выносим таймер[Timer], его свойство Interval устанавливаем в нужное значение[например - 5], и именно через заданное здесь количество миллисекунд будут меняться кадры. По событию OnTimer пишем такой код:
ImageList1.GetIcon(iconindex,Application.icon);
iconindex:=iconindex+1;
if iconindex>5 then iconindex:=0;
В строке [if iconindex>5 then iconindex:=0;] число 5 замените на индекс последней иконки в вашем ImageList'e[это количество иконок -1]
Не забудьте объявить глобальную переменную iconindex, которая должна быть целочисленного типа[integer]
А по созданию окна инициализируйте иконку приложения первым изображением в списке:
iconindex:=0;
ImageList1.GetIcon(iconindex,Application.icon);
Посмотрите на иконку программы ACDSee, которая показана в левом верхнем углу. На ней изображён глаз. По-моему, было бы довольно эффектно, если бы время от времени он подмигивал пользователю!



четвёртая кнопка на заголовочной полосе окна

Вы когда-нибудь видели как работают многие архиваторы[ZipMagic] или переводчики[Socrat] - они в чужое окно вставляют свою кнопку и по её нажатию выполняют нужное действие. Круто! В этой статье мы научимся добавлять дополнительную кнопку в своё окно и обрабатывать её нажатие. Всё, что нужно вам будет сделать - копию с нижеуказанного кода:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, ExtCtrls, StdCtrls;
const
wm_BtnClk = wm_User + 111;{Определяем своё сообщение}
type
TForm1 = class(TForm)
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
R: TRect;{Переменная для обозначения прямоугольной области кнопки}
Press: Boolean;
procedure WmNcPaint(var Msg: TWmNcPaint); message wm_NcPaint;
procedure WMNcActivate(var msg: TwmncActivate); message wm_NcActivate;
procedure WmNcLButtonDown( var Msg: TWMNCLBUTTONDOWN); message Wm_NCLbuttonDown;
procedure wmnchittest(var Msg: TWMncHITTEST); message wm_NcHittest;
procedure wmSize(var Msg: TMessage); message wm_Size;
procedure wmncLButtonUp(var msg: TWMncLBUTTONUP); message wm_NclButtonUp;
procedure wmLbuttonUp(var Msg: TMessage); message wm_LbuttonUp;
procedure wmBtnClk(var msg: TMessage); message wm_BtnClk;
public
{ Public declarations }
procedure DrawBtn;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
{ TForm1 }
procedure TForm1.WmNcPaint(var Msg: TWmNcPaint);
begin
inherited;
Drawbtn;{При перерисовке окна прорисовываем кнопку}
end;
procedure TForm1.DrawBtn;{Код прорисовки кнопки}
var
WDc: HDc;
Cx,Cy: Integer;
XFrame, Yframe: Integer;
begin{Получаем контекст нашего окна, снимаем мерки с оконных размеров, вычисляем положение нашей кнопки и прорисовываем её в зависимости от того нажата ли кнопка мыши над ней}
WDc := GetWindowDc(Handle);
Cx := GetSystemMetrics(SM_CXSize);
Cy := GetSystemMetrics(SM_CYSize);
xFrame := GetSystemMetrics(SM_CXFrame);
yFrame := GetSystemMetrics(SM_CYFrame);
R := Bounds(Width - xFrame - 4*Cx + 2, yFrame + 2, Cx - 2, Cy - 4);
if Press then
DrawFrameControl(WDc,R,DFC_BUTTON,DFCS_ButtonPUSH or DFCS_PUSHED)
else
DrawFrameControl(WDc,R,DFC_BUTTON,DFCS_ButtonPUSH);
ReleaseDc(Handle,WDC);
end;
procedure TForm1.WMNcActivate(var msg: TwmncActivate);
begin
inherited;
DrawBtn;
end;
procedure TForm1.WmNcLButtonDown(var Msg: TWMNCLBUTTONDOWN);
var pt: TPoint;
begin
inherited;
drawbtn;
pt := Point(msg.XCursor - Left,msg.YCursor - top);
if PtInRect(R,pt) then
begin
Press := True;
drawbtn;
end;
end;
procedure TForm1.wmnchittest(var Msg: TWMncHITTEST);
var pt: tpoint;
begin
inherited;
pt :=Point(msg.XPos - Left, msg.YPos - Top);
if PtinRect(r,pt) then
msg.Result := htBorder;
end;
procedure TForm1.wmSize(var Msg: TMessage);
begin
inherited;
RedrawWindow(Handle, PRect(0), 0, RDW_FRAME or RDW_NOINTERNALPAINT or RDW_INVALIDATE);
end;
procedure TForm1.wmncLButtonUp(var msg: TWMncLBUTTONUP);
var pt: TPoint;
begin
inherited;
pt := Point(msg.XCursor - Left,msg.YCursor - top);
if PtInRect(R,pt) then
begin
Press := False;
drawbtn;
PostMessage(Handle,wm_btnClk,0,0);
end;
end;
procedure TForm1.wmLbuttonUp(var Msg: TMessage);
begin
inherited;
if Press then
begin
Press := False;
DrawBtn;
end;
end;
procedure TForm1.wmBtnClk(var msg: TMessage);
begin{Объявили константу своего сообщения, посылаем его своему окну при отпускании кнопки мыши над новой кнопкой, а здесь обрабатываем своё сообщение}
ShowMessage('О, круто, наша кнопка нажимается !!!');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
RedrawWindow(Handle, PRect(0), 0, RDW_FRAME or RDW_NOINTERNALPAINT or RDW_INVALIDATE);
end;
end.



градиентная заливка формы

Процедура GradientRect делает градиентную заливку (сверху в низ)
Параметры: цвета [от и до] и объект Canvas, поверхность которого и будет закрашена
procedure TForm1.GradientRect (FromRGB, ToRGB: TColor;Canvas:tcanvas);
var
RGBFrom : array[0..2] of Byte; { from RGB values }
RGBDiff : array[0..2] of integer; { difference of from/to RGB values }
ColorBand : TRect; { color band rectangular coordinates }
I : Integer; { color band index }
R : Byte; { a color band's R value }
G : Byte; { a color band's G value }
B : Byte; { a color band's B value }
begin
{ extract from RGB values}
RGBFrom[0] := GetRValue (ColorToRGB (FromRGB));
RGBFrom[1] := GetGValue (ColorToRGB (FromRGB));
RGBFrom[2] := GetBValue (ColorToRGB (FromRGB));
{ calculate difference of from and to RGB values}
RGBDiff[0] := GetRValue (ColorToRGB (ToRGB)) - RGBFrom[0];
RGBDiff[1] := GetGValue (ColorToRGB (ToRGB)) - RGBFrom[1];
RGBDiff[2] := GetBValue (ColorToRGB (ToRGB)) - RGBFrom[2];
{ set pen sytle and mode}
Canvas.Pen.Style := psSolid;
Canvas.Pen.Mode := pmCopy;
{ set color band's left and right coordinates}
ColorBand.Left := 0;
ColorBand.Right:= canvas.ClipRect.Right-Canvas.ClipRect.Left;
for I := 0 to $ff do
begin
{ calculate color band's top and bottom coordinates}
ColorBand.Top := MulDiv (I , canvas.ClipRect.Bottom-Canvas.ClipRect.Top, $100);
ColorBand.Bottom := MulDiv (I + 1,canvas.ClipRect.Bottom-Canvas.ClipRect.Top, $100);
{ calculate color band color}
R := RGBFrom[0] + MulDiv (I, RGBDiff[0], $ff);
G := RGBFrom[1] + MulDiv (I, RGBDiff[1], $ff);
B := RGBFrom[2] + MulDiv (I, RGBDiff[2], $ff);
{ select brush and paint color band}
Canvas.Brush.Color := RGB (R, G, B);
Canvas.FillRect (ColorBand);
end;
end;
Эту процедуру объявляем в публичных объявлениях:
public
{ Public declarations }
procedure GradientRect (FromRGB, ToRGB: TColor;Canvas:tcanvas);
Для закраски формы в обработчик формы OnPaint нужно вставить:
GradientRect (clBlue, clBlack,Canvas);
По событию OnResize для формы напишем:
Paint;



плазменная заливка формы

Если вам надоели обычные монотонные формы, то эта статья - спасенье для вас!!! Всё, что вам нужно сделать для того, чтобы ваше окно выглядело так же эффектно, как и показанное на рисунке , это только написать несколько строк кода на событие OnPaint (на прорисовку) для вашего подопытного окна:
procedure TForm1.FormPaint(Sender: TObject);
var
x,y:integer;
begin
makeplasma;
for x:=0 to 255 do
begin
for y:=0 to 255 do
begin
form1.canvas.pixels[x,y]:=rgb(plasma[x,y],plasma[x+256,y+256],plasma[x+512,y+512]);
end;
Form1.update;
end;
end;
Ещё нужно в частных объявлениях объявить процедуру создания плазмы:
private
{ Private declarations }
procedure makeplasma;
А после слова implementation описать её так:
procedure TForm1.makeplasma;
procedure halfway(x1,y1,x2,y2: integer);
procedure adjust(xa,ya,x,y,xb,yb: integer);
var
d: integer;
v: double;
begin
if plasma[x,y]<>0 then exit;
d:=Abs(xa-xb)+Abs(ya-yb);
v:=(plasma[xa,ya]+plasma[xb,yb])/2+(random-0.5)*d*2;
if v<1 then v:=1;
if v>=193 then v:=192;
plasma[x,y]:=Trunc(v);
end;
var
x,y: integer;
v: double;
begin
if (x2-x1<2) and (y2-y1<2) then exit;
x:=(x1+x2) div 2;
y:=(y1+y2) div 2;
adjust(x1,y1,x,y1,x2,y1);
adjust(x2,y1,x2,y,x2,y2);
adjust(x1,y2,x,y2,x2,y2);
adjust(x1,y1,x1,y,x1,y2);
if plasma[x,y]=0 then
begin
v:=(plasma[x1,y1]+plasma[x2,y1]+plasma[x2,y2]+plasma[x1,y2])/4;
plasma[x,y]:=Trunc(v);
end;
halfway(x1,y1,x,y);
halfway(x,y1,x2,y);
halfway(x,y,x2,y2);
halfway(x1,y,x,y2);
end;
var
x,y :integer ;
begin
randomize;
plasma[0,768]:=random(192);
plasma[768,768]:=random(192);
plasma[768,0]:=random(192);
plasma[0,0]:=random(192);
halfway(0,0,768,768);
end;



как найти cd-rom диск

function GetFirstCDROM:string;
{возвращает букву 1-го привода CD-ROM или пустую строку}
var
w:dword;
Root:string;
i:integer;
begin
w:=GetLogicalDrives;
Root:='#:\';
for i:=0 to 25 do begin
Root[1] := Char(Ord('A')+i);
if (W and (1 shl i))>0
then if GetDriveType(Pchar(Root)) = DRIVE_CDROM then begin
Result:=Root[1];
exit;
end;
end;
Result:='';
end;



Определение пути, где находится программа

function GetExePath:string;
begin
Result:=ExtractFilePath(paramstr(0));
end;



Перевод символа в верхний регистр для русского алфавита

function UpCaseRus( ch : Char ) : Char;
asm
CMP AL,'a'
JB @@exit
CMP AL,'z'
JA @@Rus
SUB AL,'a' - 'A'
RET
@@Rus:
CMP AL,'я'
JA @@Exit
CMP AL,'а'
JB @@yo
UB AL,'я' - 'Я'
RET
@@yo:
CMP AL,'ё'
JNE @@exit
MOV AL,'Ё'
@@exit:
end;



Перевод символа в нижний регистр для русского алфавита

function LoCaseRus( ch : Char ) : Char;
{Перевод символа в нижний регистр для русского алфавита}
asm
CMP AL,'A'
JB @@exit
CMP AL,'Z'
JA @@Rus
ADD AL,'a' - 'A'
RET
@@Rus:
CMP AL,'Я'
JA @@Exit
CMP AL,'А'
JB @@yo
ADD AL,'я' - 'Я'
RET
@@yo:
CMP AL,'Ё'
JNE @@exit
MOV AL,'ё'
@@exit:
end;



Замена подстроки в строке

function ReplaceStr(const S, Srch, Replace: string): string;
{замена подстроки в строке}
var
I:Integer;
Source:string;
begin
Source:= S;
Result:= '';
repeat
I:=Pos(Srch, Source);
if I > 0 then begin
Result:=Result+Copy(Source,1,I-1)+Replace;
Source:=Copy(Source,I+Length(Srch),MaxInt);
end else Result:=Result+Source;
until I<=0;
end;



Добавление строки к файлу

procedure AddStrToFile(S:string;const FileName:string;doNextLine:boolean);
{Добавление строки к файлу
doNextLine - перевод строки}
const
CR=#13#10;
var
f:TFileStream;
begin
if FileExists(FileName)
then f:=TFileStream.Create(FileName,fmOpenWrite+fmShareDenyNone)
else f:=TFileStream.Create(FileName,fmCreate);
f.Position:=f.Size;
if doNextLine and (f.Size>0)
then f.Write(CR,2);
f.Write(pointer(s)^,length(s));
f.Destroy;
end;



Определение размера файла

function GetFileSize(const FileName:string):longint;
{Определение размера файла}
var
SearchRec:TSearchRec;
begin
if FindFirst(ExpandFileName(FileName),faAnyFile,SearchRec)=0
then Result:=SearchRec.Size
else Result:=-1;
FindClose(SearchRec);
end;



Сравнение файлов

function CompareFiles(Filename1,FileName2:string):longint;
{Сравнение файлов
возвращает номер несовпадающего байта,
(байты отсчитываются с 1)или:
0 - не найдено отличий,
-1 - ошибка файла 1
-2 - ошибка файла 2
-3 - другие ошибки}
const
Buf_Size=16384;
var
F1,F2:TFileStream;
i:longint;
Buff1,Buff2:PByteArray;
BytesRead1,BytesRead2:integer;
begin
Result:=0;
try
F1:=TFileStream.Create(FileName1,fmShareDenyNone);
except
Result:=-1;
exit;
end;
try
F2:=TFileStream.Create(FileName2,fmShareDenyNone);
except
Result:=-2;
F1.Free;
exit;
end;
GetMem(Buff1,Buf_Size);
GetMem(Buff2,Buf_Size);
try
if F1.Size>F2.Size then Result:=F2.Size+1
else if F1.SizeF1.Position) and (Result=0) do begin
BytesRead1 :=F1.Read(Buff1^,Buf_Size);
BytesRead2 :=F2.Read(Buff2^,Buf_Size);
if (BytesRead1=BytesRead2) then begin
for i:= 0 to BytesRead1-1 do begin
if Buff1^[i]<>Buff2^[i]
then begin
result:=F1.Position-BytesRead1+i+1;
break;
end;
end;
end else begin
Result:=-3;
break;
end;
end;
end;
except
Result:=-3;
end;
F1.Free;
F2.Free;
FreeMem(Buff1,Buf_Size);
FreeMem(Buff2,Buf_Size);
end;



Получение информации о диске

function GetVolumeInfoFVS(const Dir:string;
var FileSystemName,VolumeName:string;var Serial:longint):boolean;
{Получение информации о диске
Dir - каталог или буква требуемого диска
FileSystemName - название файловой системы
VolumeName - метка диска
Serial - серийный номер диска
В случае ошибки функция возвращает false}
var
root:pchar;
res:longbool;
VolumeNameBuffer,FileSystemNameBuffer:pchar;
VolumeNameSize,FileSystemNameSize:DWord;
VolumeSerialNumber,MaximumComponentLength,FileSystemFlags:DWORD;
s:string;
n:integer;
begin
n:=pos(':',Dir);
if n>0 then s:=copy(Dir,1,n+1) else s:=s+':';
if s[length(s)]=':' then s:=s+'\';
root:=pchar(s);
getMem(VolumeNameBuffer,256);
getMem(FileSystemNameBuffer,256);
VolumeNameSize:=255;
FileSystemNameSize:=255;
res:=GetVolumeInformation(Root,VolumeNameBuffer,VolumeNameSize
,@VolumeSerialNumber,
MaximumComponentLength, FileSystemFlags
,FileSystemNameBuffer,FileSystemNameSize);
Result:=res;
VolumeName:=VolumeNameBuffer;
FileSystemName:=FileSystemNameBuffer;
Serial:=VolumeSerialNumber;
freeMem(VolumeNameBuffer,256);
freeMem(FileSystemNameBuffer,256);
end;



Получение даты BIOS в Windows

function GetBIOSDate:string;
{получение даты BIOS в Win95}
var
s:array[0..7] of char;
p:pchar;
begin
p:=@s;
asm
push esi
push edi
push ecx
mov esi,$0ffff5
mov edi,p
mov cx,8
@@1:mov al,[esi]
mov [edi],al
inc edi
inc esi
loop @@1
pop ecx
pop edi
pop esi
end;
setstring(result,s,8);
end;



Получение переменных среды

procedure GetEnvironmentStrings(ss:TStrings);
{Переменные среды}
var
ptr: PChar;
s: string;
Done: boolean;
begin
ss.Clear;
s:='';
Done:=FALSE;
ptr:=windows.GetEnvironmentStrings;
while Done=false do begin
if ptr^=#0 then begin
inc(ptr);
if ptr^=#0 then Done:=TRUE
else ss.Add(s);
s:=ptr^;
end else s:=s+ptr^;
inc(ptr);
end;
end;



Работает ли Delphi сейчас?

function IsDelphiRun:boolean;
{Работает ли Delphi сейчас}
var
h1,h2,h3:Hwnd;
begin
h1:=FindWindow('TAppBuilder',nil);
h2:=FindWindow('TAlignPalette',nil);
h3:=FindWindow('TPropertyInspector',nil);
Result:=(h1<>0)and(h2<>0)and(h3<>0);
end;



Определение имени пользователя

function GetUserName:string;
{Определение имени пользователя}
var
Buffer: array[0..MAX_PATH] of Char;
sz:DWord;
begin
sz:=MAX_PATH-1;
if windows.GetUserName(Buffer,sz)
then begin
if sz>0 then dec(sz);
SetString(Result,Buffer,sz);
end else begin
Result:='Error '+inttostr(GetLastError);
end;
end;



Как разместить прозрачную надпись на TBitmap?

procedure TForm1.Button1Click(Sender: TObject);
var
OldBkMode : integer;
begin
Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,TRANSPARENT);
Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,OldBkMode);
end;



Можно ли обратиться к колонке или строке grid'а по заголовку?

В следующем примере приведены две функции: GetGridColumnByName() и GetGridRowByName(), которые возвращают колонку или строку, имеющую заданный заголовок (caption).
Пример:
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.Rows[1].Strings[0] := 'This Row';
StringGrid1.Cols[1].Strings[0] := 'This Column';
end;
function GetGridColumnByName(Grid : TStringGrid; ColName : string): integer;
var
i : integer;
begin
for i := 0 to Grid.ColCount - 1 do
if Grid.Rows[0].Strings[i] = ColName then
begin
Result := i;
exit;
end;
Result := -1;
end;
function GetGridRowByName(Grid : TStringGrid; RowName : string): integer;
var
i : integer;
begin
for i := 0 to Grid.RowCount - 1 do
if Grid.Cols[0].Strings[i] = RowName then
begin
Result := i;
exit;
end;
Result := -1;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Column : integer;
Row : integer;
begin
Column := GetGridColumnByName(StringGrid1, 'This Column');
if Column = -1 then
ShowMessage('Column not found')
else
ShowMessage('Column found at ' + IntToStr(Column));
Row := GetGridRowByName(StringGrid1, 'This Row');
if Row = -1 then
ShowMessage('Row not found')
else
ShowMessage('Row found at ' + IntToStr(Row));
end;



Как использовать клавишу-акселератор в TTabsheets?

Можно перехватить сообщение CM_DIALOGCHAR.
Пример:
type
TForm1 = class(TForm)
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
TabSheet3: TTabSheet;
private
{Private declarations}
procedure CMDialogChar(var Msg:TCMDialogChar);
message CM_DIALOGCHAR;
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.CMDialogChar(var Msg:TCMDialogChar);
var
i : integer;
begin
with PageControl1 do
begin
if Enabled then
for i := 0 to PageControl1.PageCount - 1 do
if ((IsAccel(Msg.CharCode, Pages[i].Caption)) and
(Pages[i].TabVisible)) then
begin
Msg.Result:=1;
ActivePage := Pages[i];
exit;
end;
end;
inherited;
end;



TRegistry и права доступа ниже чем Администратор

Проблема вызвана тем, что TRegistry всегда открывает реестр с параметром KEY_ALL_ACCESS (полный доступ), даже если необходим доступ KEY_READ (только чтение). Избежать этого можно используя функции API для работы с реестром (RegOpenKey и т.п.), или создать новый класс из компонента TRegestry, и изменить его так чтобы можно было задавать режим открытия реестра.



Можно ли изменить число колонок и их ширину в компоненте TFileListBox?

В приведенном примере FileListBox приводится к типу TDirectoryListBox - таким образом можно добавиь дополнительные колонки.
Пример:
with TDirectoryListBox(FileListBox1) do
begin
Columns := 2;
SendMessage(Handle, LB_SETCOLUMNWIDTH, Canvas.TextWidth('WWWWWWWW.WWW'),0);
end;




Как настроить табуляцию в компоненте TMemo?

Пошлите в Memo сообщение EM_SETTABSTOPS. Например установим первую позицию табуляции на 20-й пиксел.
Пример:
procedure TForm1.FormCreate(Sender: TObject);
var
DialogUnitsX : LongInt;
PixelsX : LongInt;
i : integer;
TabArray : array[0..4] of integer;
begin
Memo1.WantTabs := true;
DialogUnitsX := LoWord(GetDialogBaseUnits);
PixelsX := 20;
for i := 1 to 5 do
begin
TabArray[i - 1] :=((PixelsX * i ) * 4) div DialogUnitsX;
end;
SendMessage(Memo1.Handle,
EM_SETTABSTOPS,5,LongInt(@TabArray));
Memo1.Refresh;
end;





Как перехватить нажатия функциональных клавиш и стрелок?

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_RIGHT then
Form1.Caption := 'Right';
if Key = VK_F1 then
Form1.Caption := 'F1';
end;



При DrawCell компонента DrawGrid я получаю бесконечный цикл мерцаний. Почему?

Правильно укажите границы используемого канваса.
Пример:
If (Row = 0) then
begin
DrawGrid1.Canvas.Font.Color := clRed;
DrawGrid1.Canvas.TextOut(Rect.Left,Rect.Top, IntToStr(Col));
end;



При использовании BitBtn названия и картинка из файла не видны

Это может происходить если картинка слишком велика. Класс TBitBtn сначала рисует картинку, а затем выводит текст над, под, слева или справа от картинки (в завивимости от свойства Layout). Если размер картинки такой же как у всей кнопки для вывода текста просто не остается места. Если Вам нужно получить кнопку такого же размера как Ваша картинка и видеть при этом надпись на кнопке Вам придется выводить текст надписи непосредственно на канву картинки.
Пример:
var
bm : TBitmap;
OldBkMode : integer;
begin
bm := TBitmap.Create;
bm.Width := BitBtn1.Glyph.Width;
bm.Height := BitBtn1.Glyph.Height;
bm.Canvas.Draw(0, 0, BitBtn1.Glyph);
OldBkMode := SetBkMode(bm.Canvas.Handle, Transparent);
bm.Canvas.TextOut(0, 0, 'The Caption');
SetBkMode(bm.Canvas.Handle, OldBkMode);
BitBtn1.Glyph.Assign(bm);
end;






Можно ли изменить вид текстового курсора для Edit или другого элемента

Можно! В примере показано как создать два цветных "bitmap'а": "улыбчивый" и "хмурый" и присвоить их курсору edit'а. Для этого нужно перехватить оконную процедуру edit'а. Чтобы сделать это заменим адрес оконной процедуры Edit'а нашим собственным, а старую оконную процедуру будем вызывать по необходимости. Пример показывает "улыбчивый" курсор при наборе текста и "хмурый" при забое клавишей backspace.
Пример:
unit caret1;
interface
{$IFDEF WIN32}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
{$ELSE}
uses
WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
{$ENDIF}
type
TForm1 = class(TForm)
Edit1: TEdit;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
public
CaretBm : TBitmap;
CaretBmBk : TBitmap;
OldEditsWindowProc : Pointer;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
{$IFDEF WIN32}
WParameter = LongInt;
{$ELSE}
WParameter = Word;
{$ENDIF}
LParameter = LongInt;
{New windows procedure for the edit control}
function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter;
ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
begin
{Call the old edit controls windows procedure}
NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle,
TheMessage, ParamW, ParamL);
if TheMessage = WM_SETFOCUS then
begin
CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
ShowCaret(WindowHandle);
end;
if TheMessage = WM_KILLFOCUS then
begin
HideCaret(WindowHandle);
DestroyCaret;
end;
if TheMessage = WM_KEYDOWN then
begin
if ParamW = VK_BACK then
CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0)
else
CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
ShowCaret(WindowHandle);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{Create a smiling bitmap using the wingdings font}
CaretBm := TBitmap.Create;
CaretBm.Canvas.Font.Name := 'WingDings';
CaretBm.Canvas.Font.Height := Edit1.Font.Height;
CaretBm.Canvas.Font.Color := clWhite;
CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;
CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;
CaretBm.Canvas.Brush.Color := clBlue;
CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height));
CaretBm.Canvas.TextOut(1, 1, 'J');
{Create a frowming bitmap using the wingdings font}
CaretBmBk := TBitmap.Create;
CaretBmBk.Canvas.Font.Name := 'WingDings';
CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;
CaretBmBk.Canvas.Font.Color := clWhite;
CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;
CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;
CaretBmBk.Canvas.Brush.Color := clBlue;
CaretBmBk.Canvas.FillRect(Rect(0,0, CaretBmBk.Width, CaretBmBk.Height));
CaretBmBk.Canvas.TextOut(1, 1, 'L');
{Hook the edit controls window procedure}
OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle,GWL_WNDPROC,
LongInt(@NewWindowProc)));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
{Unhook the edit controls window procedure and clean up}
SetWindowLong(Edit1.Handle,GWL_WNDPROC, LongInt(OldEditsWindowProc));
CaretBm.Free;
CaretBmBk.Free;
end;



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



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



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


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