lazarus/components/htmllite/litegif2.pas
mattias 1428729afd added htmllite
git-svn-id: trunk@3744 -
2002-12-27 17:54:54 +00:00

642 lines
16 KiB
ObjectPascal

{Version 9.03}
{*********************************************************}
{* LITEGIF2.PAS *}
{* Copyright (c) 2001-2002 by *}
{* L. David Baldwin *}
{* All rights reserved. *}
{*********************************************************}
{$i litecons.inc}
unit LiteGIF2;
{$ifndef NoGIF}
interface
uses
Windows, SysUtils, Classes, Graphics, Controls, ExtCtrls, LiteUN2, mmSystem,
litegif1;
type
TRGBColor = packed Record
Red,
Green,
Blue: Byte;
end;
TDisposalType = (dtUndefined, {Take no action}
dtDoNothing, {Leave graphic, next frame goes on top of it}
dtToBackground,{restore original background for next frame}
dtToPrevious); {restore image as it existed before this frame}
type
ThtBitmap=class(TBitmap)
protected
htMask: TBitmap;
htTransparent: boolean;
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
procedure StretchDraw(ACanvas: TCanvas; const DestRect,
SrcRect: TRect);
public
destructor Destroy; override;
end;
TGIFImage = class;
TgfFrame = class
private
{ private declarations }
frLeft: Integer;
frTop: Integer;
frWidth: Integer;
frHeight: Integer;
frDelay: Integer;
frDisposalMethod: TDisposalType;
TheEnd: boolean; {end of what gets copied}
IsCopy: boolean;
Public
constructor Create;
constructor CreateCopy(Item: TgfFrame);
destructor Destroy; override;
end;
TgfFrameList = class(TList)
private
function GetFrame(I: integer): TgfFrame;
public
{note: Frames is 1 based, goes from [1..Count]}
property Frames[I: integer]: TgfFrame read GetFrame; default;
end;
TGIFImage = class(TPersistent)
private
{ Private declarations }
FAnimated: Boolean;
FCurrentFrame: Integer;
FImageWidth: Integer;
FImageHeight: Integer;
FNumFrames: Integer;
FNumIterations: Integer;
FTransparent: Boolean;
FVisible: Boolean;
Strip: ThtBitmap;
TheEnd: boolean; {copy to here}
FBitmap: TBitmap;
FMaskedBitmap, FMask: TBitmap;
FAnimate: Boolean;
FStretchedRect: TRect;
WasDisposal: TDisposalType;
Frames: TgfFrameList;
CurrentIteration: Integer;
LastTime: DWord;
CurrentInterval: DWord;
procedure SetAnimate(AAnimate: Boolean);
procedure SetCurrentFrame(AFrame: Integer);
function GetMaskedBitmap: TBitmap;
function GetMask: TBitmap;
function GetBitMap: TBitmap;
procedure NextFrame(OldFrame: Integer);
public
ShowIt: boolean;
IsCopy: boolean; {set if this is a copy of one in Cache}
{ Public declarations }
constructor Create;
constructor CreateCopy(Item: TGIFImage);
destructor Destroy; override;
procedure Draw(Canvas: TCanvas; MasterList, Cell: TObject; X, Y, Wid, Ht: integer);
property Bitmap: TBitmap read GetBitmap;
property MaskedBitmap: TBitmap read GetMaskedBitmap;
property Mask: TBitmap read GetMask;
property IsAnimated: Boolean read FAnimated;
property IsTransparent: Boolean read FTransparent;
property NumFrames: Integer read FNumFrames;
property NumIterations: Integer read FNumIterations;
procedure CheckTime(WinControl: TWinControl);
property Width: integer read FImageWidth;
property Height: integer read FImageHeight;
property Animate: Boolean read FAnimate write SetAnimate;
property CurrentFrame: Integer read FCurrentFrame write SetCurrentFrame;
property Visible: Boolean read FVisible write FVisible;
end;
function CreateAGifFromStream(var NonAnimated: boolean;
Stream: TStream): TGifImage;
function CreateAGif(const Name: string; var NonAnimated: boolean): TGifImage;
implementation
uses
litesubs;
function CreateBitmap(Width, Height: integer): TBitmap;
begin
Result := TBitmap.Create;
Result.Width := Width;
Result.Height := Height;
end;
function CreateAGifFromStream(var NonAnimated: boolean;
Stream: TStream): TGifImage;
var
AGif: TGif;
Frame: TgfFrame;
I: integer;
ABitmap, AMask: TBitmap;
begin
Result := Nil;
try
NonAnimated := True;
AGif := TGif.Create;
Try
AGif.LoadFromStream(Stream);
Result := TGifImage.Create;
Result.FNumFrames := AGif.ImageCount;
Result.FAnimated := Result.FNumFrames > 1;
NonAnimated := not Result.FAnimated;
Result.FImageWidth := AGif.Width;
Result.FImageHeight := AGif.Height;
Result.FNumIterations:= AGif.LoopCount;
if Result.FNumIterations <= 0 then
Result.FNumIterations := 0; {loop forever}
Result.FTransparent := AGif.Transparent;
with Result do
begin
Strip := ThtBitmap.Create;
ABitmap := AGif.GetStripBitmap(AMask);
try
Strip.Assign(ABitmap);
Strip.htMask := AMask;
Strip.htTransparent := Assigned(AMask);
finally
ABitmap.Free;
end;
DeleteObject(Result.Strip.ReleasePalette);
Result.Strip.Palette := CopyPalette(ThePalette);
end;
for I := 0 to Result.FNumFrames-1 do
begin
Frame := TgfFrame.Create;
try
Frame.frDisposalMethod := TDisposalType(AGif.ImageDisposal[I]);
Frame.frLeft := AGif.ImageLeft[I];
Frame.frTop := AGif.ImageTop[I];
Frame.frWidth := AGif.ImageWidth[I];
Frame.frHeight := AGif.ImageHeight[I];
Frame.frDelay := IntMax(30, AGif.ImageDelay[I] * 10);
except
Frame.Free;
Raise;
end;
Result.Frames.Add(Frame);
end;
if Result.IsAnimated then
Result.WasDisposal := dtToBackground;
finally
AGif.Free;
end;
except
FreeAndNil(Result);
end;
end;
function CreateAGif(const Name: string; var NonAnimated: boolean): TGifImage;
var
Stream: TFileStream;
begin
Result := Nil;
try
Stream := TFileStream.Create(Name, fmOpenRead or fmShareDenyWrite);
try
Result := CreateAGifFromStream(NonAnimated, Stream);
finally
Stream.Free;
end;
except
end;
end;
{----------------TgfFrame.Create}
constructor TgfFrame.Create;
begin
inherited Create;
end;
constructor TgfFrame.CreateCopy(Item: TgfFrame);
begin
inherited Create;
System.Move(Item.frLeft, frLeft, DWord(@TheEnd)-DWord(@frLeft));
IsCopy := True;
end;
{----------------TgfFrame.Destroy}
destructor TgfFrame.Destroy;
begin
inherited Destroy;
end;
{----------------TGIFImage.Create}
constructor TGIFImage.Create;
begin
inherited Create;
FVisible := True;
FCurrentFrame := 1;
Frames := TgfFrameList.Create;
end;
constructor TGIFImage.CreateCopy(Item: TGIFImage);
var
I: integer;
begin
inherited Create;
FImageWidth := Item.Width;
FimageHeight := Item.Height;
System.Move(Item.FAnimated, FAnimated, DWord(@TheEnd)-DWord(@FAnimated));
IsCopy := True;
Frames := TgfFrameList.Create;
for I := 1 to FNumFrames do
Frames.Add(TgfFrame.CreateCopy(Item.Frames[I]));
FCurrentFrame := 1;
CurrentIteration := 1;
if FAnimated then
WasDisposal := dtToBackground;
end;
{----------------TGIFImage.Destroy}
destructor TGIFImage.Destroy;
var
I: Integer;
begin
for I := Frames.Count downto 1 do
Frames[I].Free;
Frames.Free;
FreeAndNil(FBitmap);
if not IsCopy then
FreeAndNil(Strip);
FMaskedBitmap.Free;
FreeAndNil(FMask);
inherited Destroy;
end;
{----------------TGIFImage.Draw}
procedure TGIFImage.Draw(Canvas: TCanvas; MasterList, Cell: TObject; X, Y, Wid, Ht: integer);
var
SRect: TRect;
ALeft: integer;
begin
FStretchedRect := Rect(X, Y, X+Wid, Y+Ht);
SetStretchBltMode(Canvas.Handle, ColorOnColor);
if (FVisible) and (FNumFrames > 0) then
begin
with Frames[FCurrentFrame] do
begin
ALeft := (FCurrentFrame-1)*Width;
SRect := Rect(ALeft, 0, ALeft+Width, Height); {current frame location in Strip bitmap}
end;
Canvas.CopyMode := cmSrcCopy;
{draw the correct portion of the strip}
Strip.StretchDraw(Canvas, FStretchedRect, SRect);
end;
end;
{----------------TGifImage.CheckTime}
procedure TGifImage.CheckTime(WinControl: TWinControl);
var
ThisTime: DWord;
begin
if not FAnimate then Exit;
ThisTime := timeGetTime;
if ThisTime - LastTime < CurrentInterval then
Exit;
LastTime := ThisTime;
if (FCurrentFrame = FNumFrames) then
begin
if (FNumIterations > 0) and (CurrentIteration >= FNumIterations) then
begin
SetAnimate(False);
Exit;
end;
Inc(CurrentIteration);
end;
NextFrame(FCurrentFrame);
Inc(FCurrentFrame);
if (FCurrentFrame > FNumFrames) or (FCurrentFrame <= 0) then
FCurrentFrame := 1;
InvalidateRect(WinControl.Handle, @FStretchedRect, True);
CurrentInterval := IntMax(Frames[FCurrentFrame].frDelay, 1);
end;
{----------------TGIFImage.SetAnimate}
procedure TGIFImage.SetAnimate(AAnimate: Boolean);
begin
if AAnimate = FAnimate then Exit;
FAnimate := AAnimate;
CurrentIteration := 1;
if AAnimate and (FNumFrames > 1) then
begin
CurrentInterval := IntMax(Frames[FCurrentFrame].frDelay, 1);
LastTime := timeGetTime;
end;
end;
{----------------TGIFImage.SetCurrentFrame}
procedure TGIFImage.SetCurrentFrame(AFrame: Integer);
begin
if AFrame = FCurrentFrame then Exit;
NextFrame(FCurrentFrame);
if AFrame > FNumFrames then FCurrentFrame := 1
else if AFrame < 1 then FCurrentFrame := FNumFrames
else FCurrentFrame := AFrame;
if FAnimated then
WasDisposal := dtToBackground;
end;
{----------------TGIFImage.GetBitmap}
function TGIFImage.GetBitmap: TBitmap;
begin
Result := GetMaskedBitmap;
end;
{----------------TGIFImage.GetMaskedBitmap:}
function TGIFImage.GetMaskedBitmap: TBitmap;
{This returns frame 1}
begin
if not Assigned(FMaskedBitmap) then
begin
FMaskedBitmap := TBitmap.Create;
FMaskedBitmap.Assign(Strip);
FMaskedBitmap.Width := FImageWidth;
if Strip.htTransparent then
begin
FMask := CreateBitmap(FImageWidth, FImageHeight);
FMask.Assign(Strip.htMask);
end;
FMaskedBitmap.Transparent := False;
end;
Result := FMaskedBitmap;
end;
{----------------TGIFImage.GetMask:}
function TGIFImage.GetMask: TBitmap;
{This returns mask for frame 1. Content is black, background is white}
begin
if not FTransparent then
Result := nil
else
begin
if not Assigned(FMask) then
GetMaskedBitmap;
Result := FMask;
end;
end;
{----------------TGIFImage.NextFrame}
procedure TGIFImage.NextFrame(OldFrame: Integer);
begin
WasDisposal := Frames[OldFrame].frDisposalMethod;
end;
{----------------TgfFrameList.GetFrame}
function TgfFrameList.GetFrame(I: integer): TgfFrame;
begin
Assert((I <= Count) and (I >= 1 ), 'Frame index out of range');
Result := TgfFrame(Items[I-1]);
end;
{ ThtBitmap }
var
AHandle: THandle;
destructor ThtBitmap.Destroy;
begin
htMask.Free;
inherited;
end;
{----------------ThtBitmap.Draw}
procedure ThtBitmap.Draw(ACanvas: TCanvas; const Rect: TRect);
var
OldPalette: HPalette;
RestorePalette: Boolean;
DoHalftone: Boolean;
Pt: TPoint;
BPP: Integer;
MaskDC: HDC;
Save: THandle;
begin
with Rect do
begin
AHandle := ACanvas.Handle; {LDB}
PaletteNeeded;
OldPalette := 0;
RestorePalette := False;
if Palette <> 0 then
begin
OldPalette := SelectPalette(ACanvas.Handle, Palette, True);
RealizePalette(ACanvas.Handle);
RestorePalette := True;
end;
BPP := GetDeviceCaps(ACanvas.Handle, BITSPIXEL) *
GetDeviceCaps(ACanvas.Handle, PLANES);
DoHalftone := (BPP <= 8) and (PixelFormat in [pf15bit, pf16bit, pf24bit]);
if DoHalftone then
begin
GetBrushOrgEx(ACanvas.Handle, pt);
SetStretchBltMode(ACanvas.Handle, HALFTONE);
SetBrushOrgEx(ACanvas.Handle, pt.x, pt.y, @pt);
end else if not Monochrome then
SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
try
AHandle := Canvas.Handle; {LDB}
if htTransparent then
begin
Save := 0;
MaskDC := 0;
try
MaskDC := CreateCompatibleDC(0); {LDB}
Save := SelectObject(MaskDC, MaskHandle);
TransparentStretchBlt(ACanvas.Handle, Left, Top, Right - Left,
Bottom - Top, Canvas.Handle, 0, 0, Width,
Height, htMask.Canvas.Handle, 0, 0); {LDB}
finally
if Save <> 0 then SelectObject(MaskDC, Save);
if MaskDC <> 0 then DeleteDC(MaskDC);
end;
end
else
StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
Canvas.Handle, 0, 0, Width,
Height, ACanvas.CopyMode);
finally
if RestorePalette then
SelectPalette(ACanvas.Handle, OldPalette, True);
end;
end;
end;
procedure ThtBitmap.StretchDraw(ACanvas: TCanvas; const DestRect, SrcRect: TRect);
{Draw parts of this bitmap on ACanvas}
var
OldPalette: HPalette;
RestorePalette: Boolean;
DoHalftone: Boolean;
Pt: TPoint;
BPP: Integer;
begin
with DestRect do
begin
AHandle := ACanvas.Handle; {LDB}
PaletteNeeded;
OldPalette := 0;
RestorePalette := False;
if Palette <> 0 then
begin
OldPalette := SelectPalette(ACanvas.Handle, Palette, True);
RealizePalette(ACanvas.Handle);
RestorePalette := True;
end;
BPP := GetDeviceCaps(ACanvas.Handle, BITSPIXEL) *
GetDeviceCaps(ACanvas.Handle, PLANES);
DoHalftone := (BPP <= 8) and (PixelFormat in [pf15bit, pf16bit, pf24bit]);
if DoHalftone then
begin
GetBrushOrgEx(ACanvas.Handle, pt);
SetStretchBltMode(ACanvas.Handle, HALFTONE);
SetBrushOrgEx(ACanvas.Handle, pt.x, pt.y, @pt);
end else if not Monochrome then
SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
try
AHandle := Canvas.Handle; {LDB}
if htTransparent then
TransparentStretchBlt(ACanvas.Handle, Left, Top, Right - Left,
Bottom - Top, Canvas.Handle,
SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top,
htMask.Canvas.Handle, SrcRect.Left, SrcRect.Top) {LDB}
else
StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
Canvas.Handle,
SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top,
ACanvas.CopyMode);
finally
if RestorePalette then
SelectPalette(ACanvas.Handle, OldPalette, True);
end;
end;
end;
{$else}
{Dummy routines for NoGif option}
interface
uses
{$IFDEF HL_LAZARUS}
Classes, SysUtils, Graphics, Controls, ExtCtrls;
{$ELSE}
Windows, SysUtils, Classes, Graphics, Controls, ExtCtrls;
{$ENDIF}
type
TGIFImage = class(TPersistent)
private
{ Private declarations }
FCurrentFrame: Integer;
FImageWidth: Integer;
FImageHeight: Integer;
FNumFrames: Integer;
FTransparent: Boolean;
FVisible: Boolean;
FBitmap: TBitmap;
FAnimate: Boolean;
FMaskedBitmap: TBitmap;
FMask: TBitmap;
public
ShowIt: boolean;
IsCopy: boolean; {set if this is a copy of one in Cache}
{ Public declarations }
constructor CreateCopy(Item: TGIFImage);
procedure Draw(Canvas: TCanvas; MasterList, Cell: TObject; X, Y, Wid, Ht: integer);
property Bitmap: TBitmap read FBitmap;
property MaskedBitmap: TBitmap read FMaskedBitmap;
property Mask: TBitmap read FMask;
property IsTransparent: Boolean read FTransparent;
property NumFrames: Integer read FNumFrames;
procedure CheckTime(WinControl: TWinControl);
property Width: integer read FImageWidth;
property Height: integer read FImageHeight;
property Animate: Boolean read FAnimate write FAnimate;
property CurrentFrame: Integer read FCurrentFrame write FCurrentFrame;
property Visible: Boolean read FVisible write FVisible;
end;
function CreateAGifFromStream(var NonAnimated: boolean;
Stream: TStream): TGifImage;
function CreateAGif(const Name: string; var NonAnimated: boolean): TGifImage;
implementation
function CreateAGifFromStream(var NonAnimated: boolean;
Stream: TStream): TGifImage;
begin
Result := Nil;
end;
function CreateAGif(const Name: string; var NonAnimated: boolean): TGifImage;
begin
Result := Nil;
end;
constructor TGIFImage.CreateCopy(Item: TGIFImage);
begin
inherited Create;
end;
{----------------TGIFImage.Draw}
procedure TGIFImage.Draw(Canvas: TCanvas; MasterList, Cell: TObject; X, Y, Wid, Ht: integer);
begin
end;
{----------------TGifImage.CheckTime}
procedure TGifImage.CheckTime(WinControl: TWinControl);
begin
end;
{$endif}
end.