CLASSES2.PAS
unit Classes2;
interface
uses SysUtils, WinTypes, WinProcs, Classes;
const
SCantWriteResourceStreamError = 'Can''t write to a read-only resource stream';
SResNotFound = 'Resource %s not found';
type
HRSRC = Integer;
{ Exception classes }
EResNotFound = class(Exception);
{ TCustomMemoryStream abstract class }
TCustomMemoryStream = class(TStream)
private
FMemory: Pointer;
FSize, FPosition: Longint;
protected
procedure SetPointer(Ptr: Pointer; Size: Longint);
public
function Read(var Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
procedure SaveToStream(Stream: TStream);
procedure SaveToFile(const FileName: string);
property Memory: Pointer read FMemory;
end;
{ TResourceStream }
TResourceStream = class(TCustomMemoryStream)
private
HResInfo: HRSRC;
HGlobal: THandle;
procedure Initialize(Instance: THandle; Name, ResType: PChar);
public
constructor Create(Instance: THandle; const ResName: string; ResType: PChar);
constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
destructor Destroy; override;
function Write(const Buffer; Count: Longint): Longint; override;
end;
{ TSharedImage }
TSharedImage = class
private
FRefCount: Integer;
protected
procedure Reference;
procedure Release;
procedure FreeHandle; virtual; abstract;
property RefCount: Integer read FRefCount;
end;
implementation
{ TCustomMemoryStream }
procedure TCustomMemoryStream.SetPointer(Ptr: Pointer; Size: Longint);
begin
FMemory := Ptr;
FSize := Size;
end;
function TCustomMemoryStream.Read(var Buffer; Count: Longint): Longint;
begin
if (FPosition >= 0) and (Count >= 0) then
begin
Result := FSize - FPosition;
if Result > 0 then
begin
if Result > Count then Result := Count;
Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
Inc(FPosition, Result);
Exit;
end;
end;
Result := 0;
end;
function TCustomMemoryStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
case Origin of
0: FPosition := Offset;
1: Inc(FPosition, Offset);
2: FPosition := FSize + Offset;
end;
Result := FPosition;
end;
procedure TCustomMemoryStream.SaveToStream(Stream: TStream);
begin
if FSize <> 0 then Stream.WriteBuffer(FMemory^, FSize);
end;
procedure TCustomMemoryStream.SaveToFile(const FileName: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(FileName, fmCreate);
try
SaveToStream(Stream);
finally
Stream.Free;
end;
end;
{ TResourceStream }
constructor TResourceStream.Create(Instance: THandle; const ResName: string;
ResType: PChar);
var S:String;
begin
inherited Create;
S:=ResName+#0;
Initialize(Instance, @S[1]{PChar(ResName)}, ResType);
end;
constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer;
ResType: PChar);
begin
inherited Create;
Initialize(Instance, PChar(ResID), ResType);
end;
procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PChar);
procedure Error;
begin
raise EResNotFound.Create(Format(SResNotFound, [Name]));
end;
begin
HResInfo := FindResource(Instance, Name, ResType);
if HResInfo = 0 then Error;
HGlobal := LoadResource(Instance, HResInfo);
if HGlobal = 0 then Error;
SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo));
end;
destructor TResourceStream.Destroy;
begin
UnlockResource(HGlobal);
FreeResource(HResInfo);
inherited Destroy;
end;
function TResourceStream.Write(const Buffer; Count: Longint): Longint;
begin
raise EStreamError.Create(SCantWriteResourceStreamError);
end;
procedure TSharedImage.Reference;
begin
Inc(FRefCount);
end;
procedure TSharedImage.Release;
begin
if Pointer(Self) <> nil then
begin
Dec(FRefCount);
if FRefCount = 0 then
begin
FreeHandle;
Free;
end;
end;
end;
end.