| "Синие страницы DELPHI" на Кудрявцев.народ.ру | ||||||||||
|
СистемаСоветы для написания программ-инсталляторов Регистрация программ в меню "Пуск" 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) ? Как скрыть таскбар? События нажатия на системные кнопки формы (минимизация, закрытие...) Сети. Как подключить и отключить сетевой дисковод из своей программы? Внешние модули (DLL), нити Надо подключить DLL и использовать некоторые ее функции. Как передать при создании нити (Tthread) ей некоторое значение? CGI-програма должна выдавать в браузер Gif изображение. Регистрация программ в меню "Пуск" 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, если посылка
макроса была успешна. Система
команд (основных) приведена
ниже: Копирование
файлов 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;
Определение
системной информации. 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;
Как
проинсталлировать свои шрифты? {$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 файла 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;
Как
написать маленький
инсталлятор ? Application.Initialize; if UpperCase(ExtractFileName(Application.ExeName))='SETUP.EXE' then Application.CreateForm(TSetupForm, SetupForm) // форма инсталлятора else Application.CreateForm(TMainForm, MainForm); // форма основной программы Application.Run;
Работа
с принтером. Procedure TForm1.Button1Click(Sender: TObject);
Begin
With Printer do Begin
BeginDoc; { Начало печати }
Canvas.Font:=label1.font; { Задали шрифт }
Canvas.TextOut(100,100,'Это тест принтера !!!'); { Печатаем текст }
EndDoc; { Конец печати }
end;
end;
Особенности
работы с TPrinter 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) -
микроскопической.
Хранитель
экрана
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. Я удалил
проверку ошибки, но обычно все
проходит хорошо, особенно в
этом типе приложения. 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"). 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.
Запомните тип функции? 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, которая имеет
функцию, чтобы установить
пароль хранителя экрана, так
что нам не нужно беспокоиться
об этом. 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 программу.
Включение
и выключение устройств ввода/вывода
из программы на Delphi Переключение
языка из программы 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 ===
Информация
о состоянии клавиатуры 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
Пример
получения списка запущенных
приложений. 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 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) 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;
Добавить
ссылку на мой файл в меню Пуск|Документы
Устанавливаем свой
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;
Каким
образом можно изменить
системное меню формы? 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;
Запуск
внешней программы и ожидание
ее завершения
Как
узнать местоположение
специальных папок у Windows?
Как
засунуть в исполняемый файл 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;
Как
скрыть таскбар?
События
нажатия на системные кнопки
формы (минимизация, закрытие...) Пример: 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;
Подключение
и отключение сетевых
дисководов
Надо
подключить DLL и использовать
некоторые ее функции. Есть первый вариант: procedure procname1(param1:type1; param2:type2... и т.д.) external 'dllname.dll' name 'procname_in_dllfile'; Но тут есть один нюанс: при
отсутствии DLL модуля, либо при
отсутствии в нем указанной
процедуры будет выдаваться
ошибка и запуск программы
будет отменен. Type
prc1 = procedure (param1:type1; param2:type2... и т.д.) ;
var
proc1 : prc1;
head : integer ; // или что-то в этом роде
.....
var
p : pointer;
begin
head:= loadlibrary ('DLLFile.DLL'); // загружаем модуль в память
if head=0 then
begin
// Сообщаем о том что модуль не найден
end
else
begin
// Ищем в модуле наши процедуры и функции
p:=getprocaddress ('Имя_Искомой_Процедуры');
// Тут посмотри точно название этой
// функции в хелпе по LoadLibrary.
// Имя_Искомой_Процедуры должно
// быть один в один с именем процедуры
// в библиотеке с учетом регистров.
if p=nil then
begin
// Процедура не найдена
end else proc1:=prc1(p);
end;
Как передать при создании нити (Tthread) ей некоторое значение? К примеру, функция "прослушивает"
каталог на предмет файлов. Если
находит, то создает нить,
которая будет обрабатывать
файл. Потомку надо передать имя
файла, а вот как? ...... 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-програмы, то как это сделать?
Рисую две иконки 32х32 и 16х16, но под NT 32х32 не показывается! С помощью Image Editor из комплекта
Delphi3 создаю ресурс содержащий
иконки и добавляю его в свой
проект. Как известно, одна
иконка в ресурсе может иметь
два вида 32х32 и 16х16, которые
отображаются соответственно
при выборе крупных и мелких
значков. Я создаю оба
изображения, но после
компиляции отображается
только 16х16 (при крупных значках
оно растягивается). Как мне
сделать так, чтобы
отображались обе иконки?
uses ShlObj, ComObj, ActiveX;
procedure CreateLink(const PathObj, PathLink, Desc, Param: string);
var
IObject: IUnknown;
SLink: IShellLink;
PFile: IPersistFile;
begin
IObject := CreateComObject(CLSID_ShellLink);
SLink := IObject as IShellLink;
PFile := IObject as IPersistFile;
with SLink do begin
SetArguments(PChar(Param));
SetDescription(PChar(Desc));
SetPath(PChar(PathObj));
end;
PFile.Save(PWChar(WideString(PathLink)), FALSE);
end;
Затенить кнопку закрыть в заголовке формы Следующий текст убирает команду закрыть из системного меню и одновременно делает серой кнопку закрыть в заголовке формы: procedure TForm1.FormCreate(Sender: TObject); var hMenuHandle:HMENU; begin hMenuHandle := GetSystemMenu(Handle, FALSE); IF (hMenuHandle <> 0) THEN DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND); end;
|