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

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;

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) );