实用控件：将任意文件打包进dfm（zlib压缩）的控件 [转]
该控件可以将任意文件打包进.dfm（使用zlib压缩），可以用该控件编写只有一个exe的绿色软件，或者用于自己编写安装程序。
使用非常简单，设计期将该控件放入form, 指定FileName属性即可将该文件内容打包进dfm中。运行时可以调用FileRes1.ResToFile解压到指定的文件内或通过FileRes1.ResToStream解压到一个stream中（比如图片文件，接下去可以用Bitmap.LoadFromStream读入），这两个函数的Keep参数指定是否在操作的同时释放FileRes中占用的内存（如果只需要在程序运行时解压一次则建议使用Keep := False; 这样可以降低程序占用的内存）
unit FileRes;
interface
uses
SysUtils, Classes, Windows, ZLib;
type
TBufferStream = class(TStream)
private
FLen: Cardinal;
FBuffer: Pointer;
FPosition: Cardinal;
protected
procedure SetSize(NewSize: Longint); override;
public
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
procedure SaveToFile(FileName: string);
procedure LoadFromFile(FileName: string);
function SaveToStream(Stm: TStream): Integer;
procedure LoadFromStream(Stm: TStream);
function ReadString: string;
procedure Writestring(const Str: string);
procedure ExchangeBuffer(var ABuffer: Pointer; var ALen: Integer);
property Buffer: Pointer read FBuffer;
end;
TFileRes = class(TComponent)
private
{ Private declarations }
FStream: TBufferStream;
FFileName: TFileName;
procedure WriteFileData(Stm: TStream);
procedure ReadFileData(Stm: TStream);
procedure SetFileName(const Value: TFileName);
protected
{ Protected declarations }
procedure DefineProperties(Filer: TFiler); override;
public
{ Public declarations }
destructor Destroy; override;
function ResToFile(AFileName: string; Keep: Boolean = false): Boolean;
function ResToStream(var Stm: TStream; Keep: Boolean = false): Boolean;
property Stream: TBufferStream read FStream;
published
{ Published declarations }
property FileName: TFileName read FFileName write SetFileName;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TFileRes]);
end;
{ TBufferStream }
destructor TBufferStream.Destroy;
begin
reallocmem(fbuffer, 0);
inherited;
end;
procedure TBufferStream.ExchangeBuffer(var ABuffer: Pointer;
var ALen: Integer);
var
tmp: Integer;
begin
tmp := Integer(ABuffer);
ABuffer := FBuffer;
FBuffer := Pointer(tmp);
tmp := ALen;
ALen := FLen;
FLen := tmp;
if FPosition > FLen then FPosition := FLen;
end;
procedure TBufferStream.LoadFromFile(FileName: string);
var
fid: Integer;
begin
reallocmem(fbuffer, 0);
flen := 0;
fid := fileopen(filename, fmOpenRead or fmShareDenyNone);
if fid < 0 then exit;
flen := getfilesize(fid, nil);
reallocmem(fbuffer, flen);
fileread(fid, fbuffer^, flen);
fileclose(fid);
position := 0;
end;
procedure TBufferStream.LoadFromStream(Stm: TStream);
var
buf: Pointer;
l: Integer;
begin
reallocmem(fbuffer, 0);
flen := 0;
fposition := 0;
stm.Read(l, 4);
if l > 0 then
begin
getmem(buf, l);
stm.Read(buf^, l);
try
decompressbuf(buf, l, l, fbuffer, Integer(flen));
except
fbuffer := nil;
end;
freemem(buf);
end;
end;
function TBufferStream.Read(var Buffer; Count: Integer): Longint;
begin
if fposition+count>flen then result := flen-fposition
else result := count;
if result > 0 then
begin
move(PByteArray(fbuffer)[fposition], buffer, result);
inc(fposition, result);
end;
end;
function TBufferStream.ReadString: string;
var
l: Integer;
begin
read(l, 4);
setlength(result, l);
if l > 0 then
read(result[1], l);
end;
procedure TBufferStream.SaveToFile(FileName: string);
var
fid: Integer;
begin
fid := filecreate(filename);
if fid < 0 then exit;
if flen > 0 then
filewrite(fid, fbuffer^, flen);
fileclose(fid);
end;
function TBufferStream.SaveToStream(Stm: TStream): Integer;
var
buf: Pointer;
begin
try
compressbuf(fbuffer, flen, buf, result);
except
result := 0;
end;
stm.Write(result, 4);
if result > 0 then
begin
stm.Write(buf^, result);
freemem(buf);
end;
inc(result, 4);
end;
function TBufferStream.Seek(Offset: Integer; Origin: Word): Longint;
begin
case origin of
0: if offset >= 0 then fposition := offset;
1: inc(fposition, offset);
2: fposition := flen + offset;
end;
result := fposition;
end;
procedure TBufferStream.SetSize(NewSize: Integer);
begin
if flen <> newsize then
begin
flen := newsize;
reallocmem(fbuffer, newsize);
if fposition > flen then fposition := flen;
end;
end;
function TBufferStream.Write(const Buffer; Count: Integer): Longint;
begin
try
if fposition + count > flen then
setsize(fposition + count);
result := count;
move(buffer, PByteArray(fbuffer)[fposition], count);
inc(fposition, count);
except
result := 0;
end;
end;
procedure TBufferStream.Writestring(const Str: string);
var
l: Integer;
begin
l := Length(str);
write(l, 4);
if l > 0 then
write(str[1], l);
end;
{ TFileRes }
destructor TFileRes.Destroy;
begin
if assigned(FStream) then
fstream.Free;
inherited;
end;
procedure TFileRes.DefineProperties(Filer: TFiler);
begin
inherited;
filer.DefineBinaryProperty('FileStreamData', ReadFileData, WriteFileData, assigned(fstream));
end;
procedure TFileRes.ReadFileData(Stm: TStream);
begin
if not assigned(fstream) then
fstream := TBufferStream.Create;
fstream.LoadFromStream(stm);
end;
procedure TFileRes.WriteFileData(Stm: TStream);
begin
if assigned(fstream) then
fstream.SaveToStream(stm);
end;
function TFileRes.ResToFile(AFileName: string; Keep: Boolean): Boolean;
var
fid: Integer;
begin
result := false;
if not assigned(fstream) then exit;
fid := filecreate(afilename);
if fid < 0 then exit;
if fstream.FLen > 0 then
filewrite(fid, fstream.fbuffer^, fstream.FLen);
fileclose(fid);
result := true;
if not keep then
freeandnil(fstream);
end;
function TFileRes.ResToStream(var Stm: TStream; Keep: Boolean): Boolean;
begin
result := assigned(fstream);
if result then
begin
stm := fstream;
if not keep then
fstream := nil;
end;
end;
procedure TFileRes.SetFileName(const Value: TFileName);
begin
if (csDesigning in ComponentState) {and (value <> ffilename)} then
begin
FFileName := Value;
if not (csLoading in ComponentState) then
if value <> '' then
begin
if not assigned(fstream) then
fstream := TBufferStream.Create;
fstream.LoadFromFile(value);
if fstream.FLen = 0 then
freeandnil(fstream);
end
else freeandnil(fstream);
end;
end;
end.
