Стартовый пул

bgrabitmap/test/testgif/project1.lpi

@@ -0,0 +1,83 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="project1"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <Icon Value="0"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+      <Modes Count="1">
+        <Mode0 Name="default"/>
+      </Modes>
+    </RunParams>
+    <RequiredPackages Count="2">
+      <Item1>
+        <PackageName Value="BGRABitmapPack"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="LCL"/>
+      </Item2>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="project1.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="unit1.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="Form1"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="Form"/>
+        <UnitName Value="Unit1"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="project1"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

bgrabitmap/test/testgif/project1.lpr

@@ -0,0 +1,21 @@
+program project1;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms, Unit1
+  { you can add units after this };
+
+{$R *.res}
+
+begin
+  RequireDerivedFormResource:=True;
+  Application.Initialize;
+  Application.CreateForm(TForm1, Form1);
+  Application.Run;
+end.
+

bgrabitmap/test/testgif/project2.lpi

@@ -0,0 +1,87 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <PathDelim Value="\"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="project2"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <Icon Value="0"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <VersionInfo>
+      <StringTable ProductVersion=""/>
+    </VersionInfo>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="3">
+      <Item1>
+        <PackageName Value="bgracontrols"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="BGRABitmapPack"/>
+      </Item2>
+      <Item3>
+        <PackageName Value="LCL"/>
+      </Item3>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="project2.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="unit2.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="Form2"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="Form"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="project2"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

bgrabitmap/test/testgif/project2.lpr

@@ -0,0 +1,21 @@
+program project2;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms, unit2
+  { you can add units after this };
+
+{$R *.res}
+
+begin
+  RequireDerivedFormResource:=True;
+  Application.Initialize;
+  Application.CreateForm(TForm2, Form2);
+  Application.Run;
+end.
+

bgrabitmap/test/testgif/unit1.lfm

@@ -0,0 +1,87 @@
+object Form1: TForm1
+  Left = 125
+  Height = 350
+  Top = 127
+  Width = 505
+  AllowDropFiles = True
+  Caption = 'Form1'
+  ClientHeight = 350
+  ClientWidth = 505
+  Color = clSkyBlue
+  Position = poScreenCenter
+  LCLVersion = '3.99.0.0'
+  OnCreate = FormCreate
+  OnDropFiles = FormDropFiles
+  object Panel1: TPanel
+    Left = 305
+    Height = 350
+    Top = 0
+    Width = 200
+    Align = alRight
+    Caption = 'Panel1'
+    ClientHeight = 350
+    ClientWidth = 200
+    Color = clBtnFace
+    ParentBackground = False
+    ParentColor = False
+    TabOrder = 0
+    object Memo1: TMemo
+      Left = 8
+      Height = 251
+      Top = 32
+      Width = 184
+      Anchors = [akTop, akLeft, akRight, akBottom]
+      Lines.Strings = (
+        'Memo1'
+      )
+      ScrollBars = ssVertical
+      TabOrder = 0
+    end
+    object Label1: TLabel
+      Left = 8
+      Height = 16
+      Top = 288
+      Width = 39
+      Anchors = [akLeft, akBottom]
+      Caption = 'Label1'
+    end
+    object Button1: TButton
+      Left = 10
+      Height = 25
+      Top = 312
+      Width = 75
+      Anchors = [akLeft, akBottom]
+      Caption = 'Refresh'
+      TabOrder = 1
+      OnClick = Button1Click
+    end
+    object Button2: TButton
+      Left = 112
+      Height = 25
+      Top = 312
+      Width = 75
+      Anchors = [akLeft, akBottom]
+      Caption = 'Save as...'
+      TabOrder = 2
+      OnClick = Button2Click
+    end
+    object Label2: TLabel
+      Left = 10
+      Height = 16
+      Top = 8
+      Width = 179
+      Caption = 'Drag and drop a GIF or a PNG'
+    end
+  end
+  object Timer1: TTimer
+    Interval = 15
+    Left = 136
+    Top = 128
+  end
+  object SaveDialog1: TSaveDialog
+    DefaultExt = '.gif'
+    Filter = 'Animated GIF|*.gif|Animated PNG|*.png'
+    Left = 392
+    Top = 184
+  end
+end

bgrabitmap/test/testgif/unit1.pas

@@ -0,0 +1,238 @@
+unit Unit1;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
+  BGRABitmap, BGRAAnimatedGif, LCLType, StdCtrls;
+
+type
+
+  { TGifAnimationPanel }
+
+  TGifAnimationPanel = class(TPanel)
+  private
+    FOnRenderFrame: TNotifyEvent;
+    procedure SetImage(AValue: TBGRAAnimatedGif);
+    procedure SetOnRenderFrame(AValue: TNotifyEvent);
+  protected
+    FImage: TBGRAAnimatedGif;
+    FFirstPaint, FAnimatePaint: boolean;
+    FTimer: TTimer;
+    procedure Paint; override;
+    procedure EraseBackground(DC: HDC); override;
+    procedure ImageChanged(Sender: TObject);
+    procedure TimerTimer(Sender: TObject);
+  public
+    constructor Create(TheOwner: TComponent); override;
+    destructor Destroy; override;
+    property Image: TBGRAAnimatedGif read FImage;
+    property OnRenderFrame: TNotifyEvent read FOnRenderFrame write SetOnRenderFrame;
+  end;
+
+  { TForm1 }
+
+  TForm1 = class(TForm)
+    SaveDialog1: TSaveDialog;
+    Timer1: TTimer;
+    Panel1: TPanel;
+    Label1: TLabel;
+    Label2: TLabel;
+    Button1: TButton;
+    Button2: TButton;
+    Memo1: TMemo;
+    procedure Button1Click(Sender: TObject);
+    procedure Button2Click(Sender: TObject);
+    procedure FormCreate(Sender: TObject);
+    procedure FormDropFiles(Sender: TObject; const FileNames: array of string);
+  protected
+    { private declarations }
+    procedure GifAnimationPanelRenderFrame(Sender: TObject);
+  public
+    { public declarations }
+    filename, error: string;
+    animationPanel: TGifAnimationPanel;
+    procedure LoadImage(AFilename: string);
+    procedure FillMemo;
+  end;
+
+var
+  Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+{ TGifAnimationPanel }
+
+constructor TGifAnimationPanel.Create(TheOwner: TComponent);
+begin
+  inherited Create(TheOwner);
+  FFirstPaint:= true;
+  FAnimatePaint:= false;
+  BevelInner:= bvNone;
+  BevelOuter:= bvNone;
+  FImage := TBGRAAnimatedGif.Create;
+  FImage.OnChange := @ImageChanged;
+  FTimer := TTimer.Create(self);
+  FTimer.Enabled := false;
+  FTimer.OnTimer := @TimerTimer;
+end;
+
+destructor TGifAnimationPanel.Destroy;
+begin
+  inherited Destroy;
+end;
+
+procedure TGifAnimationPanel.SetImage(AValue: TBGRAAnimatedGif);
+begin
+  FImage.Free;
+end;
+
+procedure TGifAnimationPanel.SetOnRenderFrame(AValue: TNotifyEvent);
+begin
+  if FOnRenderFrame=AValue then Exit;
+  FOnRenderFrame:=AValue;
+end;
+
+procedure TGifAnimationPanel.Paint;
+var
+  waitTime: Integer;
+begin
+  inherited Paint;
+
+  if FFirstPaint or not FAnimatePaint then
+  begin
+    Canvas.Brush.Assign(Brush);
+    Canvas.FillRect(ClientRect);
+    image.BackgroundMode := gbmEraseBackground;
+    image.EraseColor:= Color;
+    if Assigned(FImage) and (FImage.Count > 0) then
+      FImage.Show(Canvas, ClientRect);
+  end else
+  begin
+    if Assigned(FImage) and (FImage.Count > 0) then
+      FImage.Update(Canvas, ClientRect);
+  end;
+  FAnimatePaint := false;
+  FFirstPaint := false;
+  if Assigned(FOnRenderFrame) then
+    FOnRenderFrame(self);
+  if Assigned(FImage) and (FImage.Count > 1) then
+  begin
+    waitTime := Image.TimeUntilNextImageMs;
+    if waitTime < 15 then waitTime := 15;
+    FTimer.Interval := waitTime;
+    FTimer.Enabled := true;
+  end;
+end;
+
+procedure TGifAnimationPanel.EraseBackground(DC: HDC);
+begin
+  // don't erase background
+end;
+
+procedure TGifAnimationPanel.ImageChanged(Sender: TObject);
+begin
+  FTimer.Enabled:= false;
+  Invalidate;
+end;
+
+procedure TGifAnimationPanel.TimerTimer(Sender: TObject);
+begin
+  FTimer.Enabled := false;
+  FAnimatePaint := true;
+  Refresh;
+end;
+
+{ TForm1 }
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+  animationPanel := TGifAnimationPanel.Create(self);
+  animationPanel.OnRenderFrame := @GifAnimationPanelRenderFrame;
+  animationPanel.Left := 4;
+  animationPanel.Top := 4;
+  animationPanel.Color:= self.Color;
+  InsertControl(animationPanel, 0);
+  LoadImage(ConcatPaths([ExtractFilePath(Application.ExeName), 'waterdrops.gif']));
+  FillMemo;
+end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+begin
+  animationPanel.Refresh;
+end;
+
+procedure TForm1.Button2Click(Sender: TObject);
+begin
+  try
+    if SaveDialog1.Execute then
+      animationPanel.Image.SaveToFile(SaveDialog1.FileName);
+  except
+    on ex: exception do
+    begin
+      error := ex.Message;
+      FillMemo;
+    end;
+  end;
+end;
+
+procedure TForm1.FormDropFiles(Sender: TObject; const FileNames: array of string);
+begin
+  LoadImage(FileNames[0]);
+end;
+
+procedure TForm1.GifAnimationPanelRenderFrame(Sender: TObject);
+begin
+  Label1.Caption := 'Frame: ' + inttostr(animationPanel.image.CurrentImage) +
+                    ', Wait: ' + inttostr(animationPanel.Image.TimeUntilNextImageMs);
+end;
+
+procedure TForm1.LoadImage(AFilename: string);
+begin
+  filename := AFilename;
+  try
+    if not FileExists(filename) then
+    begin
+      animationPanel.Image.Clear;
+      error := 'Not found';
+    end else
+    begin
+      animationPanel.Image.LoadFromFile(filename);
+      error := 'Ok';
+    end;
+  except
+    on ex:Exception do
+      error := ex.Message;
+  end;
+  animationPanel.Width := animationPanel.Image.Width;
+  animationPanel.Height := animationPanel.Image.Height;
+  FillMemo;
+end;
+
+procedure TForm1.FillMemo;
+var s: string;
+  i: Integer;
+begin
+  with animationPanel do
+  begin
+    s := error + LineEnding +
+         ExtractFileName(filename) + LineEnding +
+         inttostr(image.Width)+'x'+inttostr(image.height) + LineEnding +
+         inttostr(image.Count)+' frames' + LineEnding;
+    if image.LoopCount = 0 then
+      s += 'infinite loop' + LineEnding
+    else
+      s += inttostr(image.LoopCount)+' loops' + LineEnding;
+    for i := 0 to image.Count-1 do
+      s += '#' + inttostr(i)+': '+inttostr(image.FrameDelayMs[i])+' ms, '+
+           inttostr(image.FrameImage[i].Width)+'x'+inttostr(image.FrameImage[i].Height) + LineEnding;
+  end;
+  Memo1.Text := s;
+end;
+
+end.
+

bgrabitmap/test/testgif/unit2.lfm

@@ -0,0 +1,29 @@
+object Form2: TForm2
+  Left = 241
+  Height = 240
+  Top = 150
+  Width = 320
+  Caption = 'Form2'
+  ClientHeight = 240
+  ClientWidth = 320
+  OnCreate = FormCreate
+  OnDestroy = FormDestroy
+  LCLVersion = '1.6.0.4'
+  object BGRAVirtualScreen1: TBGRAVirtualScreen
+    Left = 0
+    Height = 155
+    Top = 0
+    Width = 156
+    OnRedraw = BGRAVirtualScreen1Redraw
+    Alignment = taLeftJustify
+    Color = clBtnFace
+    ParentColor = False
+    TabOrder = 0
+  end
+  object Timer1: TTimer
+    Interval = 15
+    OnTimer = Timer1Timer
+    left = 111
+    top = 44
+  end
+end

bgrabitmap/test/testgif/unit2.pas

@@ -0,0 +1,64 @@
+unit unit2;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
+  BGRABitmap, BGRABitmapTypes, BGRAAnimatedGif, BGRAVirtualScreen, BCTypes;
+
+type
+
+  { TForm2 }
+
+  TForm2 = class(TForm)
+    BGRAVirtualScreen1: TBGRAVirtualScreen;
+    Timer1: TTimer;
+    procedure BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
+    procedure FormCreate(Sender: TObject);
+    procedure FormDestroy(Sender: TObject);
+    procedure Timer1Timer(Sender: TObject);
+  private
+    { private declarations }
+  public
+    { public declarations }
+    image: TBGRAAnimatedGif;
+  end;
+
+var
+  Form2: TForm2;
+
+implementation
+
+{$R *.lfm}
+
+{ TForm2 }
+
+procedure TForm2.FormCreate(Sender: TObject);
+begin
+  image := TBGRAAnimatedGif.Create('waterdrops.gif');
+  BGRAVirtualScreen1.Width := image.Width;
+  BGRAVirtualScreen1.Height := image.Height;
+  ClientWidth := image.Width;
+  ClientHeight := image.Height;
+end;
+
+procedure TForm2.BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
+begin
+  Bitmap.PutImage(0,0, image.MemBitmap, dmDrawWithTransparency);
+end;
+
+procedure TForm2.FormDestroy(Sender: TObject);
+begin
+  image.Free;
+end;
+
+procedure TForm2.Timer1Timer(Sender: TObject);
+begin
+  if image.TimeUntilNextImageMs <= 0 then
+    BGRAVirtualScreen1.DiscardBitmap;
+end;
+
+end.
+