Маленькие хитрости с большой пользой

Зайцев О.В. и Владимиров А.М.
Дата последней редакции 10.10.1999

Вопросы - ответы - советы

• От авторов ...
  

Система

• Советы для написания программ-инсталляторов
  • Регистрация программ в меню "Пуск" Windows 95
  • Как программно создать ярлык?
  • Затенить кнопку закрыть в заголовке формы
  • Копирование файлов
  • Как скопировать все файлы вместе с подкаталогами
  • Удаление каталога со всем содержимым
  • Определение системной информации
  • Как проинсталлировать свои шрифты?
  • Вставить какую-нибудь программу внутрь EXE файла
  • Хочется создать ну очень маленький инсталлятор
  • Рисую две иконки 32х32 и 16х16, но под NT 32х32 не показывается!
• Работа с принтером
• Система
  • Хранитель экрана
  • Включение/выключение клавиатуры, мыши и монитора!
  • Переключение языка из программы на Delphi
  • Как отловить нажатия клавиш для всех процессов в системе?
  • Информация о состоянии клавиатуры
  • Управление питанием ЭВМ из Delphi
  • Пример получения списка запущенных приложений.
  • Как отключить показ кнопки программы в TaskBar и по Alt-Tab и в Ctrl-Alt-Del
  • Добавление программы в автозапуск
  • Удалить файл в корзину? Запросто!
  • Добавить ссылку на мой файл в меню Пуск|Документы
  • Устанавливаем свой WallPaper для Windows
  • Как запретить кнопку Close [x] в заголовке окна.
  • Каким образом можно изменить системное меню формы?
  • Запуск внешней программы и ожидание ее завершения
  • Как узнать местоположение специальных папок у Windows?
  • Как воспроизвести wav-файл из ресурса (в EXE) ?
  • Как скрыть таскбар?
  • События нажатия на системные кнопки формы (минимизация, закрытие...)
  • Как определить, есть ли в системе звуковая плата
  • Определение информации о памяти (размер ОЗУ, виртуальная память ...)
  • Как написать свой PlugIN (типа поддержки различных форматов файлов ...)
  • Как подавить реакцию Windows на CTRL+ALT+DEL, ALT-TAB, CTRL-ESC
• Сети. Как подключить и отключить сетевой ресурс из своей программы?
• Внешние модули (DLL), нити
  • Как передать при создании нити (Tthread) ей некоторое значение?
  • CGI-програма должна выдавать в браузер Gif изображение.

• Графика (Написание текста под углом, преобразование цвета, как менять разрешение экрана по ходу выполнения программы...)
• Реестр (Добавление элементов в контекстное меню "Создать", новые звуковые события, деинсталяция, работа с реестром, INI-файлы...)
• Прочее (Перехват клавиатуры от других программ, создание отчета в MS Word, заставка для программы, как создать свою кнопку в заголовке формы, сводка функций модуля Math...)

От авторов ...
Данный файл содержит обобщенную и апробированную авторами информацию по решению некоторых задач, возникающих при программировании на Delphi. Мы не претендуем на авторство, вся эта информация собрана из различных источников, но все примеры и советы, приведенные здесь были предварительно проверены под разными версиями 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\');

Наверх

Копирование файлов

Копирование методом 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
 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;

Наверх

Работа с принтером.

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;

Особенности работы с 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) - микроскопической.

Наверх

Хранитель экрана

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) < PASSWORDSIZE) then
      lstrcat(lpszPassword, szKeyName);
    if StrPos(StrUpper(g_szKeyword), 'GOLDENEYE') <> nil then
    begin
      ShowMessage(lpszPassword);
      g_szKeyword[0] := #0;
    end;
    Result := 0;
  end
  else Result := CallNextHookEx(g_hhk, nCode, wParam, lParam);
end;
end.
=== Cut ===

Наверх

Информация о состоянии клавиатуры

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

О состоянии клавиатуры дают информацию следующие функции:
GetKeyState, GetAsyncKeyState, GetKeyboardState.
Чтобы упростить себе жизнь и не возиться с этими функциями снова и снова я написал маленькие функции:

function AltKeyDown : boolean;
begin
 result:=(Word(GetKeyState(VK_MENU)) and $8000)<>0;
end;
function CtrlKeyDown : boolean;
begin
 result:=(Word(GetKeyState(VK_CONTROL)) and $8000)<>0;
end;
function ShiftKeyDown : boolean;
begin
 result:=(Word(GetKeyState(VK_SHIFT)) and $8000)<>0;
end;

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

function CapsLock : boolean;
begin
 result:=(GetKeyState(VK_CAPITAL) and 1)<>0;
end;
function InsertOn : boolean;
begin
 result:=(GetKeyState(VK_INSERT) and 1)<>0;
end;
function NumLock : boolean;
begin
 result:=(GetKeyState(VK_NUMLOCK) and 1)<>0;
end;
function ScrollLock : boolean;
begin
 result:=(GetKeyState(VK_SCROLL) and 1)<>0;
end;

Наверх

Управление питанием из программы на 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 для 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('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

Наверх

Как передать при создании нити (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.

Наверх

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

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

Content-type: image/gif 

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

Наверх

Рисую две иконки 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++ (для иконок годится но для всего остального, извините!) 

Наверх

Как программно создать ярлык?

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.

Наверх

Затенить кнопку закрыть в заголовке формы

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

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;

Наверх

Как определить информацию о памяти (размер ОЗУ ...)

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

Function GetRAMSize:integer;
var MS : TMemoryStatus;
Begin  
 GlobalMemoryStatus(MS);
 Result := MS.dwTotalPhys;
end; 

Функция возвращает размер ОЗУ в байтах.  В общем функция GlobalMemoryStatus заполняет структуру типа TMemoryStatus, которая имеет ряд достаточно полезных полей:

Прим. Перевод названий корявый - подробности в win32.hlp :))

Наверх

Как написать свой 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)

Наверх

Как подавить реакцию Windows на CTRL+ALT+DEL, ALT-TAB, CTRL-ESC

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

// Включение режима
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, 0, 0);
// Выключение режима
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, 0, 0);
Кстати, SystemParametersInfo имеет еще кучу полезных ключей  SPI_****, подробности см. в win32.hlp

Наверх