|
|
Система
Этот раздел содержит советы по системному программированию на Delphi. Здесь приведены советы по работе с API, написанию программ-инсталляторов, управлению питанием, работе с принтером, написанию ScreenSaver-ов, DLL и т.п.
Внимание !! Сайт переехал - он теперь расположен
по адресу http://z-oleg.com/delphi, размещенные
там материалы переработаны и дополнены. На z-ol.chat.ru остается копия, однако
обновляться она больше не будет
|
 |
 |
|
Советы для написания программ-инсталляторов
Работа с принтером
Система
Внешние модули (DLL), нити
| Регистрация программ в меню "Пуск"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');
// Устанавливаем связь по DDE
DDEClient.OpenLink;
// Подготавливаем ASCIIZ строку
strPCopy(macrocmd,'['+Command+']');
ProgmanCommand :=DDEClient.ExecuteMacro(MacroCmd,false);
// Закрываем связь по DDE
DDEClient.CloseLink;
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\');
| Копирование файлов |
* |
* |
|
Копирование методом 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 < BufSize;
FileSetDate(TFileRec(outfile).Handle,
FileGetDate(TFileRec(infile).Handle));
finally
if Buffer <> Nil then Dispose(Buffer);
System.close(outfile)
end;
finally
System.close(infile);
end;
end else
Raise EInOutError.Create('File cannot be copied into itself');
end;
Копирование методом потока
Procedure FileCopy(Const SourceFileName, TargetFileName: String);
Var
S,T : TFileStream;
Begin
S := TFileStream.Create(sourcefilename, fmOpenRead );
try
T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);
try
T.CopyFrom(S, S.Size ) ;
FileSetDate(T.Handle, FileGetDate(S.Handle));
finally
T.Free;
end;
finally
S.Free;
end;
end;
Копирование методом LZExpand
uses LZExpand;
procedure CopyFile(FromFileName, ToFileName : string);
var
FromFile, ToFile: File;
begin
AssignFile(FromFile, FromFileName);
AssignFile(ToFile, ToFileName);
Reset(FromFile);
try
Rewrite(ToFile);
try
if LZCopy(TFileRec(FromFile).Handle, TFileRec(ToFile).Handle)<0 then
raise Exception.Create('Error using LZCopy')
finally
CloseFile(ToFile);
end;
finally
CloseFile(FromFile);
end;
end;
Копирование методами Windows
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
// Открыли библиотеку User
hInstUser := LoadLibrary('USER');
LoadString(hInstUser, 514, Buffer, 30);
// Имя пользователя
LabelUserName.Caption := StrPas(Buffer);
LoadString(hInstUser, 515, Buffer, 30);
FreeLibrary(hInstUser);
// Компания
LabelCompName.Caption := StrPas(Buffer);
WinVer := GetVersion;
// Версия Windows
LabelWinVer.Caption := Format('Windows %u.%.2u',
[LoByte(LoWord(WinVer)), HiByte(LoWord(WinVer))]);
// Версия DOS
LabelDosVer.Caption := Format('DOS %u.%.2u',
[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:\ARHIVERS\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;
Вполне очевидно, что вместо переименования можно запускать программу с различными ключами,
например /INSTALL и /UNINSTALL. Я очень часто пользуюсь таким приемом, особенно в тех
случаях, когда проект состоит из одного файла
| Написание хранителя экрана |
* |
* |
|
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 |
* |
* |
|
Решение для Delphi 1
Иногда может возникнуть необходимость в выключении на время устройств ввода
- клавиатуры и мыши. Например, это неплохо сделать на время выполнения кода
системы защиты от копирования, в играх, или в качестве "наказания"
при запуске программы по истечению срока ее бесплатного использования ... .
Однако наилучшее ее применение - отключение клавиатуры и мыши на время работы
демонстрационки, основанной на воспроизведении записанных заранее перемещений
мышки и клавиатурного ввода. Это элементарно сделать при помощи API:
EnableHardwareInput(Enable:boolean): boolean;
Enable - требуемое состояние устройств ввода (True - включены, false - выключены).
Если ввод заблокирован, то его можно разблокировать вручную - нажать Ctrl+Alt+Del,
при появлении меню "Завершение работы программы" ввод разблокируется.
Еще раз подчеркиваю, что это работает только в 16-ти разрядной D1. Исследования в
отладчике показали, что функция по сути ничего не делает, только устанавливает некий
флаг в памяти, явно отвечающий за блокировку клавиатуры/мыши.
Решение для Delphi 2+
По сложно объяснимым причинам фирма Microsoft удалила функцию EnableHardwareInput
из 32-рарядных реализаций Windows и, следовательно, EnableHardwareInput стала
недоступной в D2+. Однако научные изыскания (в ядре Windows при помощи отладчика)
помогли мне найти ее аналог. Он не документирован в справке Borland, но кажется есть
в последнем MSDN
Procedure BlockInput(ABlockInput : boolean); stdcall; external 'USER32.DLL';
Вызов данной функции c параметром true блокирует клавиатуру и мышь, с параметром
false - разблокирует). Как и в случае с EnableHardwareInput блокировка снимается при
нажатии Ctrl+Alt+Del.
| Как программно создать ярлык? |
* |
* |
|
Создать ярлык можно при помощи данной функции:
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;
Наиболее распространенная задача - создание ярлыка на рабочем столе. Для
этого необходимо определить полный путь к системной папке
Windows Desctop через реестр и передать его
в качестве параметра PathLink.
| Оповещение приложения (или всей системы) о изменении WIN.INI |
* |
* |
|
При изменении WIN.INI (например, изменении настроек хранителя экрана) необходимо уведомить
систему (или конкретное приложение) о том, что WIN.INI изменен. Это можно сделать при
помощи передачи приложению сообщения WM_WININICHANGE
SendMessage(HANDLE, WM_WININICHANGE, 0, PCHAR(SECT_NAME));
При этом HANDLE равен или HANDLE приложения, или HWND_BROADCAST - рассылка всем приложениям.
SECT_NAME задает имя секции WIN.INI, в которой произошли изменения. Если указать пустую строку
(#0), то считается, что изменялись все секции, что естественно увеличивает время обработки и нагрузку
на систему
| Как удалить самого себя ?? |
* |
* |
|
Широко известна проблема, связанная с тем, что невозможно удалить запущенный
EXE файл. Следовательно, вознакает проблема при написании деинсталлятора - он
удалит файлы программы, но кто удалит его (сам себя он удалить не может). На
самом деле у данной проблемы есть два решения:
Решение при помощи BAT файла
1. Создаем в любой папке BAT файл del_prg.bat следующего содержания
@echo off
:del_loop
del [полное имя и путь к EXE файлу]
if exist [полное имя и путь к EXE файлу] goto del_loop
del [полное имя bat файла]
2. Запускаем его
3. Завершаем работу EXE файла. BAT файл будет крутится по циклу до тех пор,
пока ему не удатся удалить EXE файл. Затем он самоуничтожится - этому ничто не
препятствует, т.к. bat файлыв могут стирать сами себя без проблем
Решение при помощи реестра
1. Создаем ключ в ветви реестра HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce
с любым именем, например del_self и значением del [полное имя и путь к EXE файлу]
2. Просим пользователя перезагрузить компьютер (или делаем это принудительно). Команда из
ключа сработает при следующей загрузке и будет автоматически удалена из реестра
| Класс TPRINTER |
* |
* |
|
Delphi имеет стандартный объект для доступа к принтеру - TPRINTER,
находящийся в модуле PRINTERS. В этом модуле имеется переменная Printer:Tpinter, что
избавляет от необходимости описывать свою. Он позволяет выводить данные на печать и управлять
процессом печати. Правда, в некоторых версиях Delphi1 он имеет "глюк"
- не работают функции 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;
| Особенности работы с TPrinter |
* |
* |
|
1. После команды 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) - микроскопической.
| Управление питанием из программы на Delphi |
* |
W9x |
|
При написании разнообразны программ типа
заставок, менеджеров управления компьютером ...
возникает необходимость переводить компьютер в
режим "спячки". Для включения этого режима в
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;
// Получаем hWnd первого окна
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
Внимание !! Данный пример не работает под Windows NT/2K
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall;
external 'KERNEL32.DLL';
implementation
procedure TForm1.Button1Click(Sender: TObject);
begin
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID, 1);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
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; // Суффикс ключа (Once - для однократного запуска)
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 для рабочего стола Windows |
* |
* |
|
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('е:\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;
// Блокировка нажатия ALT+F4
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;
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;
| События нажатия на системные кнопки формы (минимизация, закрытие...) |
* |
* |
|
При нажатии на эти кнопки происходит сообщение WM_SYSCOMMAND,
его то и надо перехватить.
При этом:
uCmdType = wParam; // тип команды
xPos = LOWORD(lParam); // X в экранных координатах
yPos = HIWORD(lParam); // Y в экранных координатах
Пример:
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 Begin
--- некая особая реакция на MINIMIZE ----
Form1.Visible:=False;
end else Inherited; // Во всех остальных случаях вызываем стандартный обработчик
End;
Следент отметить, что Inherited можно вызывать безусловно, т.е. не блокировать стандартную обработку.
| Как передать при создании нити (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.
| Как затенить кнопку закрыть в заголовке формы |
* |
* |
|
Следующий текст убирает команду закрыть из
системного меню и одновременно делает серой
кнопку закрыть в заголовке формы:
procedure TForm1.FormCreate(Sender: TObject);
var hMenuHandle:HMENU;
begin
hMenuHandle := GetSystemMenu(Handle, FALSE);
IF (hMenuHandle <> 0) THEN
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
| Как определить, имеется ли в системе звуковая плата |
* |
* |
|
Эта функция может быть полезна при написании инсталляторов
Uses --//--,mmSystem;
--- // ---
Function CheckAudioCard : boolean;
Begin
Result := WaveOutGetNumDevs>0;
end;
| Как подавить реакцию Windows на CTRL+ALT+DEL, ALT-TAB, CTRL-ESC |
* |
* |
|
В некоторых случаях (например, при работе в полноэкранном режиме, показе своей
презентации или экранной заставки ...) бывает полезно заблокировать перечисленные комбинации
клавиш. Они блокируются при работе системы в режиме "экранная заставка" , который в свою
очередь несложно включить и выключить:
Решение для W9х
// Включение режима
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, 0, 0);
// Выключение режима
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, 0, 0);
Кстати, SystemParametersInfo имеет еще кучу полезных
ключей SPI_****, подробности см. в win32.hlp
Универсальное решение для блокировки CTRL+ALT+DEL
Существует еще одно решение этой задачи - редактирование ключа реестра
HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System. В нем
необходимо создать (или изменить существующий) параметр DisableTaskMgr
типа DWORD. Значение 0 блокирует CTRL+ALT+DEL, 1-разрешает. Но этот путь
следует использовать с большой осторожностью, т.к. изменения в реестре
сохраняются после перезагрузки компьютера
Блокировка ALT-TAB
Проще всего это сделать при помощи регистрации горячей клавиши ALT-TAB. Это можно
сделать при помощи функции RegisterHotKey(Handle, 1, MOD_ALT, VK_TAB);. При
завершении программы следует вызывать UnRegisterHotKey(Handle, 1);
| Как определить работает ли уже данное приложение или это его первая копия? |
* |
* |
|
Каждый экземпляр программы имеет ссылку на свою предыдущую копию - hPrevInst: hWnd.
Ее можно проверить перед созданием приложения и при необходимости отреагировать
соответствующим образом. Если запущена только одна копия, то эта ссылка равна
нулю.
Только для Delphi 1.
Пример использования hPrevInst:
procedure TForm1.FormCreate(Sender: TObject);
begin
// Проверяем есть ли указатель на предыдущую копию приложения
IF hPrevInst <> 0 THEN BEGIN
// Если есть, то выдаем сообщение и выходим
MessageDlg('Программа уже запущена!', mtError, [mbOk], 0);
Application.Terminate;
END;
// Иначе - ничего не делаем (не мешаем созданию формы)
end;
Другой способ - по списку загруженных приложений
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;
Данный пример не всегда применим - часто заголовок приложения меняется при каждом старте,
поэтому рассмотрим более надежный способ - через FileMapping
Дело в том, что можно в памяти создавать временные файлы. При перезагрузке они
теряются, а так существуют. Кстати, этот метод можно использовать и для обмена
информацией между вашими приложениями.
Пример с использованием FileMapping:
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);
Пример:
program Project0;
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.
Блокировка запуска второй копии при помощи Mutex
На мой взгляд, это один из самых простых и надежных способов.
procedure TForm1.FormCreate(Sender: TObject);
var
hMutex : THandle;
begin
hMutex := CreateMutex(0, true , 'My application name');
if GetLastError = ERROR_ALREADY_EXISTS then begin
CloseHandle(hMutex);
Application.Terminate;
end;
end;
В данном примере при старте приложения создается мьютекс с некоторым
уникальным именем (у каждого приложения оно должно бять свое !!). Если
хоть одна копия приложения запущена, то в системе уже будет мьютекс с таким
именем и возникнет ошибка ERROR_ALREADY_EXISTS. В противном случае мьютекс
создается и существует, пока работает данная копия приложения
| Как написать свой PlugIN (типа поддержки различных форматов файлов ...) |
* |
* |
|
Типовая задача - разрабатывается некая задача и
при этом
- Некоторые ее компоненты могут не
инсталлироваться баз ущерба для
работоспособности
- Некоторые компоненты предполагается
изготавливать впоследствии и рассылать
пользователям
- Некоторые компоненты могут разрабатываться
другими программистами и распространяться
независимо от программы
- .....
Классические примеры - фильтры для
совместимости по форматам файлов с другими
программами, некоторые расширения и
дополнительные возможности. Примеры и моей
практики - приведу парочку
- Программа управления программатором ПЗУ.
Заранее неизвестно, с каким железом она будет
работать и как им управлять. Необходимо было дать
возможнось разработчику железа написать для
него поддержку
- Программа печати отчетов. Она должна печатать в
любой кодировке на любой принтере, в т.ч. и
экзотическом типа АЦПУ. Заранее неизвестно,
какие принтеры будуп применяться совместно с ней
и как ими управлять (известно только одно -
драйверов под них нет и не будет) - переделывать
программу под каждый принтер - неинтересно ...
Итак, все это можно реализовать в DLL, однако
обычное ее подключение приведет к тому, что при
запуске программа будет искать все подключенне к
ней DLL и в случае отсутствия хотя-бы одной
откажется запускаться. Это не приемлемо, но к
счастю есть возможность и весьма удоюный набор
сервисных функций для динамической загрузки,
использования и выгрузки DLL.
Пример (приложение имеет одно окно, на нем
кнопка):
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
public
end;
// Тип "процедура". Естественно, можно определит типы
// "функция" или "функция с параметрами" ...
TDllProc = procedure;
var
Form1: TForm1;
DllProcPtr : TDllProc;
LibInstance : HMODULE; // Логический номер модуля DLL
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
// Проверим, загружена ли DLL
if LibInstance=0 then Begin
// Не загружена, попробуем загрузить
LibInstance := LoadLibrary('plug_in.dll');
// Проверим, успешна ли загрузка (LibInstance=0 - неуспешно)
If LibInstance=0 then Begin
ShowMessage('Ошибка загрузки библиотеки plug_in.dll');
exit;
end;
// Ищем функцию по ее имени (имя должно точно совпадать)
DllProcPtr := TDllProc(GetProcAddress(LibInstance,'MyProc'));
// Проверим, нашли ли (если нашли, то Assigned вернет true)
if not Assigned(DllProcPtr) then Begin
// Не нашли - выгружаем DLL из памяти
FreeLibrary(LibInstance);
LibInstance:=0;
ShowMessage('Ошибка: функция MyProc не найдена');
exit;
end;
// Непосредственно вызов функции
DllProcPtr;
// Выгрузка библиотеки
FreeLibrary(LibInstance);
LibInstance:=0;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
DllProcPtr:=nil;
LibInstance:=0;
end;
end.
Естественно, в реальной задаче имеет смысл
создать свой класс, который при инициализации
будет загружать библиотеку, а при уничтожении
- выгружать. Кроме того, он должен иметь функцию
типа "Перезагрузить библиотеку", которая
будет выгружать текущую и загружать новую. DLL -
обычная, естественно может иметь неограниченное
количество процедур и функций.
Особенности:
- Пока библиотека загружена, ее файл нельзя ни
удалить, ни переименовать. Поэтому при
возникновении ошибок следует выгружать
библиотеку, иначе пользователь не сможет ее
заменит (без перезагрузки ПК).
- Обычно имеет смысл создать ряд функции типа
GetInfo, GetAutor, GetCopyRight ..., чтобы вызывающая программа
могла получить информацию о назначении данной DLL
- Расширение DLL не является обязательным, поэтому
можно применять свои расширения (например DRV)
| Как изменять иконку приложения/окна во время его работы |
* |
* |
|
Изменять иконку приложения или окна достаточно просто - для этого у
TApplication и TForm предусмотрено свойство Icon. Смена иконки может
вестись обычным присвоением свойству Icon нового значения:
Form1.Icon := Image1.Picture.Icon;
При этом происходит не присвоение указателя (как казалось бы), а копирование
данных посредством вызова Assign, который производится в методе TForm.SetIcon
2. Загрузка иконки из ресурса. В данных советах уже есть примеры помещения
данных в ресурс, загрузка производится типовым вызовом API
Form1.Icon.Handle := LoadIcon(hInstance, 'имя иконки в ресурсе');
Причем имя в ресурсе желательно писать всегда в верхнем регистре
Все сказанное выше пригодно и для приложения, только в этом случае вместо Form1
выступает Application. Для принудительной перерисовки кнопки приложения в панеле
задач можно применить вызов InvalidateRect(Application.Handle, NIL, True);
Пример организации простейшей анамации иконки приложения
procedure TForm1.Timer1Timer(Sender: TObject);
begin
inc(IconIndex);
case IconIndex of
1 : Application.Icon.Assign(Image1.Picture.Icon);
2 : Application.Icon.Assign(Image2.Picture.Icon);
else IconIndex := 0;
end;
InvalidateRect(Application.Handle, NIL, True);
end;
При этом естественно предполагается, что в Image1 и Image2 загружены иконки
Если Вам понравился мой сайт, то Вы можете проголосовать за него на Golden URL (заранее спасибо)
Я советую посетить и другие сайты, посвященные программированию. Это легко сделать по кольцу:
Algorithm project
: Кольцо сайтов, посвященных
программированию (подробнее о
проекте WebRing...) [ Предыдущие 5 сайтов | Предыдуший | Следующий | Следующие 5 сайтов | Выбрать сайт случайным образом | Список всех сайтов ]
