Виртуальная библиотека Delphi

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

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

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

begin

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

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

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

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

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

end;

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

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

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

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

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

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

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

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

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

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

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

5 — Активация

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

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

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

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

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

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

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

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

uses ShlObj, ComObj, ActiveX;

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

var

IObject: IUnknown;

SLink: IShellLink;

PFile: IPersistFile;

begin

IObject := CreateComObject(CLSID_ShellLink);

SLink := IObject as IShellLink;

PFile := IObject as IPersistFile;

with SLink do begin

SetArguments(PChar(Param));

SetDescription(PChar(Desc));

SetPath(PChar(PathObj));

end;

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

end;

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

procedure TForm1.FormCreate(Sender: TObject);

var hMenuHandle:HMENU;

begin

hMenuHandle := GetSystemMenu(Handle, FALSE);

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

end;

Type

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

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

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

Type

PBuffer = ^TBuffer;

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

var

Size : integer;

Buffer : PBuffer;

infile, outfile : File;

SizeDone,SizeFile: Longint;

begin

if (InFileName <> OutFileName) then begin

buffer := Nil;

AssignFile(infile, InFileName);

System.Reset(infile, 1);

try

SizeFile := FileSize(infile);

AssignFile(outfile, OutFileName);

System.Rewrite(outfile, 1);

try

SizeDone := 0; New(Buffer);

repeat

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

Inc(SizeDone, Size);

CallBack(SizeDone, SizeFile);

BlockWrite(outfile,Buffer^, Size)

until Size < BufSize;

FileSetDate(TFileRec(outfile).Handle,

FileGetDate(TFileRec(infile).Handle));

finally

if Buffer <> Nil then Dispose(Buffer);

System.close(outfile)

end;

finally

System.close(infile);

end;

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

end;

Procedure FileCopy(Const SourceFileName, TargetFileName: String);

Var

S,T : TFileStream;

Begin

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

try

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

try

T.CopyFrom(S, S.Size ) ;

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

finally

T.Free;

end;

finally

S.Free;

end;

end;

uses LZExpand;

procedure CopyFile(FromFileName, ToFileName : string);

var

FromFile, ToFile: File;

begin

AssignFile(FromFile, FromFileName);

AssignFile(ToFile, ToFileName);

Reset(FromFile);

try

Rewrite(ToFile);

try

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

finally

CloseFile(ToFile);

end;

finally

CloseFile(FromFile);

end;

end;

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

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

var F : TShFileOpStruct;

begin

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

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

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

F.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;

result:=ShFileOperation(F) = 0;

end;

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

procedure TForm1.Button1Click(Sender: TObject);

begin

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

end;

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);

var

OpStruc: TSHFileOpStruct;

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

Begin

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

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

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

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

With OpStruc DO Begin

Wnd:= Handle;

wFunc:= FO_COPY;

pFrom:= @frombuf;

pTo:=@tobuf;

fFlags:= FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;

fAnyOperationsAborted:= False;

hNameMappings:= Nil;

lpszProgressTitle:= Nil;

end;

ShFileOperation( OpStruc );

end;

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

function DeleteDir(Dir : string) : boolean;

Var

Found : integer;

SearchRec : TSearchRec;

begin

result:=false;

if IOResult<>0 then ;

ChDir(Dir);

if IOResult<>0 then begin

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