Category: StackOverflow

Directory TreeView in Delphi FMX

I made a directory TreeView in Delphi FMX, but when I expand 'C:\Windows\WinSxS' it contains 15000 folders. It took a lot of time, but it doesn't expand. On the other hand, when I tried to do it with a VCL TreeView, it worked fine, as it should. Is there any way to make it fast? Here is my code: function SlashSep(const Path, S: String): String; begin {$IF DEFINED(CLR)} if Path[Length(Path)] <> '\' then {$ELSE} if AnsiLastChar(Path)^ <> '\' then {$ENDIF} Result := Path + '\' + S else Result := Path + S; end; procedure GetDir(const ParentDirectory: string; ParentItem: TTreeViewItem); var Status: Integer; SearchRec: TSearchRec; Node: TTreeViewItem; begin Status := FindFirst(SlashSep(ParentDirectory, '*.*'), faDirectory, SearchRec); try while Status = 0 do begin if (SearchRec.Attr and faDirectory = faDirectory) then begin if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then begin Node := AddChild(ParentItem,ExtractFileName(SearchRec.Name)); Node.HasChildren := True; end; end; Status := FindNext(SearchRec); end; finally FindClose(SearchRec); end; end; procedure TForm1.ItemOnExpanding(Sender: TObject; Node: TTreeViewItem); var i: Integer; begin for i := Node.Count - 1 downto 0 do TreeView1.RemoveObject(Node.Items[i]); Node.BeginUpdate; GetDir(GetPathItem(node),node); Node.EndUpdate; end; It's expanding from here: procedure TCustomTreeView.ItemExpanded(const Item: TTreeViewItem); var I: Integer; Child: TTreeViewItem; AllowExpansion: Boolean; begin InvalidateGlobalList; if Item.IsExpanded then for I := 0 to Item.Count - 1 do begin Child := Item.Items[I]; if not Child.IsInflated then Child.Inflate; end; RealignContent; //end; if Assigned(FOnExpanding) then if Item.IsExpanded then FOnExpanding(Self, Item, AllowExpansion) else if Assigned(FOnCollapsing) then if not Item.IsExpanded then FOnCollapsing(Self, Item, AllowExpansion) end;
Read More

Switch specific colors in a TPathData

I am using Delphi Rio with firemonkey. I generated a polygon form TBitmap that has transparent background and some text in black. I want to change the black color only to red color of the polygon and save the changes to the original Tbitmap? I tried iteration through the points of the TPathData and change the individual pixels, but this process is time consuming. Is there a faster way to do switch the colors of TPathData? This is the procedure that uses iteration through TPathData points the change the color of the pixel. procedure TForm1.ChangePathColor(Npath : TPathData; TopV : Integer; BotV : Integer); var Polygon: TPolygon; Color: TAlphaColor; MyBitmap : TBitmap; BMPD, MBMPD : TBitmapData; MyBitmapCopy: TBitmap; access : TMapAccess; h,v : integer; begin Npath.FlattenToPolygon(Polygon,1); MyBitmap := TBitmap.Create(0, 0); MyBitmap.Assign(Image1.Bitmap); MyBitmapCopy := TBitmap.Create(0, 0); MyBitmapCopy.Assign(MyBitmap); try if (MyBitmap.Map(access, BMPD) and (MyBitmapCopy.Map(access,MBMPD))) then Begin Try for h := 1 to MyBitmap.Width do for v := TopV to BotV do begin if image1.Canvas.PtInPath(pointf(h,v),Npath) then begin Color := BMPD.GetPixel(h,v); if (TAlphaColorRec(Color).R < 50) then MBMPD.SetPixel(h,v, TAlphaColors.Red); end; end; finally MyBitmap.Unmap(BMPD); MyBitmapCopy.Unmap(MBMPD); end; end; Image1.Bitmap := MyBitmapCopy; finally MyBitmapCopy.Free; MyBitmap.Free; end; end; Excuse my poor English for misunderstanding. I will explain my problem in pictures The User choose a verse by click and the verse is sent to color transformation procedure This is option will highlight the verse and is very fast This option will change the color of the verse and is very slow using the ChangePathColor procedure that change pixel by pixel The whole new changed BitMap will be sent back the TImage. I want to speed up the process for the colorizing option.
Read More

How to check if a file is locked on macos with delphi?

I work with delphi berlin. I create an application for macos with firemonkey. I need to open a file with an external program (i'm using _system function for that) and then to detect when the file is closed in the external application. So i'd like to check regularly if the file is locked. How to check if the file is locked on macos with delphi ?
Read More

Delphi 10.3.3 and Adroid SDK version

I have a question. I was looking for answers on the net but I found nothing specific. I have Delphi version 10.3.3. What is the highest version of Android SDK I can/should install so that there is no problem? By default Delphi installs version 25 and Google Play requires version 26. It is a bit strange that a new version of Delphi has default such an old version of Android Studio. Now, Version 29 of Android Studio is available!
Read More

Mouse Leave event in Firemonkey 10.3

I have a form with a control (myControl) and a child control (myChildControl). I want to manage the mouse exit on myControl so that I can take some actions. The problem is that the On Mouse Leave event is fired even though the mouse is still physically inside myControls but getting over myChildControl, while in this case I wouldn't need the event to be fired. I cannot set the HitTest property in the child control as I need to take some actions on mouse events on it too. Conceptually the Mouse Leave event fires properly, but what's the cleanest way to manage this case?
Read More

indy compressor doesn’t work, TIdCompressorZlib not found

I'm trying to decompress a gzip response, all the samples and demos and answers on the internet simply create a TIdCompressorZlib but i can't find this in Delphi 10.3 FMX, i tried manually downloading and using TIdCompressorZlib but it had many errors and other dependencies so i gave up, i can see that idhttp.compressor uses IdZLibCompressorBase but doing something like: idhttp.Compressor := IdZLibCompressorBase.TIdZLibCompressorBaseClass.Create(idhttp); Doesn't work either because in run time it throws the error: --------------------------- Debugger Exception Notification --------------------------- Project MiniDownloader.exe raised exception class EAbstractError with message 'Abstract Error'. --------------------------- Break Continue Help --------------------------- I also tried forcing the response to not be a gzip to avoid decompressing, by using: idhttp.Request.AcceptEncoding := 'identity'; But this also fails because the response remains compressed I also tried using IdZlib.DecompressStream(inputMemoryStream, outputMemoyStream); But this also throws a runtime error : --------------------------- Debugger Exception Notification --------------------------- Project MiniDownloader.exe raised exception class EDecompressionError with message 'ZLib Error (-5)'. --------------------------- Break Continue Help --------------------------- I don't understand why this is so hard~! nothing works...!, is this because i'm not in VLC ? and i'm using FMX ? any solution and suggestion is much appreciated.
Read More

Delphi FMX function to open a local file fails on Android platform

I require a cross-platform function to open a file using any app on the device registered to be able to open the file type concerned, along the lines of the WinAPI function ShellExecute in Windows. Using various code examples that I found on Stack-overflow I finally came up with the following code which compiles with Delphi 10.3. uses {$ifdef Android} FMX.Helpers.Android, AndroidAPI.Helpers, AndroidApi.JNI.GraphicsContentViewText, AndroidApi.JNI.Net, AndroidApi.JNI.JavaTypes; {$endif Android} {$ifDef MSWindows} Winapi.ShellAPI, Winapi.Windows; {$endif MSWindows} procedure OpenFile(FilePathname: string; DisplayError: Boolean); const COption= 0; var Extension: string; {$ifdef Android} Intent: JIntent; URI: Jnet_Uri; {$endif Android} Result: integer; begin Extension:= LowerCase(ExtractFileExt(FilePathname)); {$ifdef Android} URI := TJnet_Uri.JavaClass.parse(StringToJString('file:///' + FilePathname)); Intent:= TJIntent.Create; Intent.setFlags(TJIntent.JavaClass.FLAG_GRANT_READ_URI_PERMISSION); Intent.setAction(TJIntent.JavaClass.ACTION_VIEW); case COption of 0: Intent.setData(URI); 1: if Extension= '.pdf' then Intent.setDataAndType(URI,StringToJString('application/pdf')) else if Extension= '.txt' then Intent.setDataAndType(URI,StringToJString('text/*')); end; try SharedActivity.startActivity(Intent); except on E: Exception do begin if DisplayError then ShowMessage('Error: ' + E.Message); end; end; {$endif Android} {$ifdef MSWindows} Result:= ShellExecute(0, 'Open', PChar(FilePathname), '', '', SW_SHOWNORMAL); {$endif MSWindows} end; Applying this function to a local .PDF file on an SD card on an Android 9 device, the following exception is thrown: android.os.FileUriExposedException: file:////SDCard/test.pdf exposed beyond app through Intent.getData() I have found on StackOverflow the following thread which addresses this problem: android.os.FileUriExposedException: file:///storage/emulated/0/test.txt exposed beyond app through Intent.getData() However the idea of having to declare and use a class inheriting from the Java class File-provider in order to give access to a particular file or folder and make it accessible to other apps, and then document this in the AndroidManifest.xml seems greatly over-complicated, particularly considering that all the files in the SD card are public by definition. My questions, therefore, are: Is there a simpler way of dealing with this issue in Delphi FMX 10.3+? If not, how does one go about creating a Object Pascal class in Delphi inheriting from a Java class? A code example would be appreciated. Addendum: From a link to this post I have found the following code by Dave Nottage: procedure OpenPDFA(const AFileName: string); var LIntent: JIntent; LAuthority: JString; LUri: Jnet_Uri; begin LAuthority := StringToJString(JStringToString(TAndroidHelper.Context.getApplicationContext.getPackageName) + '.fileprovider'); LUri := TJFileProvider.JavaClass.getUriForFile(TAndroidHelper.Context, LAuthority, TJFile.JavaClass.init(StringToJString(AFileName))); LIntent := TJIntent.JavaClass.init(TJIntent.JavaClass.ACTION_VIEW); LIntent.setDataAndType(LUri, StringToJString('application/pdf')); LIntent.setFlags(TJIntent.JavaClass.FLAG_GRANT_READ_URI_PERMISSION); TAndroidHelper.Activity.startActivity(LIntent); end; However the class TJFileProvider is flagged up in the Delphi compiler as an undeclared identifier. The uses list in my code seems to be the same as in Dave Nottage's code. So where is TJFileProvider declared?
Read More

Throwing an exception on Android causes Segmentation Fault 11 error before catch handler is called

I am developing my first multi-platform application with C++Builder 10.3.3. My first two targets will be Android and Windows. I have run into an issue with even the most simplest Android apps when I try to use any exception handling. The following code in ANY function causes a "Segmentation fault (11)" error. I have tried it on a Huawei Mate 8 Pro running Android 7, and on a Samsung Note 9 running Android 9. void __fastcall Function(void) { try { throw Exception(_D("This is a test exception!")); } catch (const Exception & objException) { if (objException.Message.IsEmpty() == false) { } } } The exception gets created and thrown, but the Segmentation Fault gets raised and my catch handler is never reached. How do I fix this?
Read More

How to break ITask in Delphi/Firemonkey

I use the following block: TTask.Run(procedure begin TThread.Synchronize(nil, procedure begin loader.Visible := true; end); ... SQL SELECT TThread.Synchronize(nil, procedure begin loader.Visible := false; end); end); In general, everything is OK. The problem occurs when I close the Form while executing the SELECT procedure. When I reopen this Form, the loader is active, but the SQL function no longer performs. How can I complete all Tasks before closing the forms?
Read More

Delphi FMX 10.3: Issues with obtaining file properties in for multi-platform applications

I am seeking to convert some Delphi code to extract file properties from the operating system from a time-honoured implementation for the Windows platform to a new implementation for the Android platform. I have found that whereas the implementation for the Delphi platform uses the functions FindFirst() and FindNext() without problem and allows the file properties to be obtained from the TSearchRec parameter, this approach doesn’t appear to work for the Android platform. So I need to find cross-platform functions to obtain file and directory properties. Several properties may be obtained using methods of the System.IOUtils record types TDirectory and TFile. But for some reason, these does not appear to include a method to obtain the size in bytes of a file. Therefore, I have tried to obtain the file size by creating a TFileStream object for the file given its pathname, and then getting the size from the TFileStream.Size property. This method works when the file is not already open. However if the file is open, then an exception is thrown. The next question, then, is how to find out whether a file is open before calling TFileStream.Create(). This ought to be straightforward, but I cannot remember how to do it. So I have tried the following global procedure: procedure FXGetFileSize(FilePathname: string; var FileInUse: Boolean; var Size: int64); var FileStream: TFileStream; begin try FileStream:= TFileStream.Create(FilePathname, fmOpenRead); try FileInUse:= False; Size:= FileStream.Size; finally FileStream.Free; end; except on E: Exception do begin FileInUse:= True; Size:= 0; FileStream.Free; end; end; end; I call this procedure from within the following method: procedure TFolder.ReadFX (Pathname: string; Recurse: Boolean); {Reads details of folder file components in a folder into a TFolder data structure – cross-platform version} var Separator: char; FolderPaths: TStringDynArray; FilePathNames: TStringDynArray; i: integer; FolderPathI: string; FilePathnameI: string; SubFolder: TFolder; SubFileCpt: TFileCpt; SubFileCptIndex: integer; FolderCptName: string; Datetime: TDatetime; FileInUse: Boolean; FileSize: int64; begin Separator:= TPath.DirectorySeparatorChar; FCount:= 0; FCumSize:= 0; FCumFileCount:= 0; FCumFolderCount:= 1; {Extract list of subfolders in directory:} FolderPaths:= TDirectory.GetDirectories(Pathname); {Create a TFolder object for each subfolder:} for i:= 0 to High(FolderPaths) do begin FolderPathI:= FolderPaths[i]; if TDirectory.Exists(FolderPathI) then begin try {Create TFolder object for subfolder i:} SubFolder:= TFolder.Create; AddFolderCpt(SubFolder, SubFileCptIndex); {Assign TFolder properties:} FolderCptName:= StringReplace(FolderPathI, (Pathname + Separator), '', [rfIgnoreCase]); Subfolder.Name:= FolderCptName; {Subfolder.Name:= Path; } Subfolder.FDateTime:= TDirectory.GetLastWriteTime(FolderPathI); {Recursively process subfolder:} if Recurse then Subfolder.Read(FolderPathI, Recurse); {Compute aggregate properties:} FCumSize:= FCumSize + SubFolder.FCumSize; FCumFileCount:= FCumFileCount + SubFolder.FCumFileCount; FCumFolderCount:= FCumFolderCount + SubFolder.FCumFolderCount; except on E: Exception do begin E.Message:= 'Error in TFolder.ReadFX processing folder "' + FolderPathI + '"' + #13#10 + '(' + E.Message + ')'; end; end; end; end; {Get list of files in directory:} FilePathNames:= TDirectory.GetFiles(Pathname); {Create TFileCpt objects for each child file:} for i:= 0 to High(FilePathnames) do begin FilePathnameI:= FilePathnames[i]; if (FilePathnameI<> '.') and (FilePathnameI<>'..') then begin try {$ifdef MSWINDOWS} if not ([TFileAttribute.faHidden, TFileAttribute.faSystem] <= TFile.GetAttributes(FilePathnameI)) then {$endif} begin FXGetFileSize(FilePathnameI, FileInUse, FileSize); {***} {Create a TFileCpt object corresponding to FilePathnameI:} SubFileCpt:= TFileCpt.Create; AddFolderCpt(SubFileCpt, SubFileCptIndex); {Assign TFileCpt properties:} SubFileCpt.FName:= TPath.GetFileName(FilePathnameI); SubFileCpt.FSize:= FileSize; SubFileCpt.FDateTime:= TFile.GetLastWriteTime(FilePathnameI); FCumSize:= FCumSize + FileSize; FCumFileCount:= FCumFileCount + 1; end; except on E: Exception do begin E.Message:= 'Error in TFolder.ReadFX processing file "' + FilePathnameI + '"' + #13#10 + '(' + E.Message + ')'; end; end; end; end; end; Unfortunately, when I call TFolder.ReadFX() for Pathanme= ‘C:\\Users\User XXX' on Windows 7, a runtime exception is always thrown when an open file presumably opened by the Windows OS is encountered. In conclusion, can any one help with the following questions: How to obtain the size of a file without having to open the file stream How to determine whether or not the file is already/in use In the case of a folder, how to extract the name of lowest level folder from the folder path, without manually parsing the path.
Read More

Control on embedded form not refreshing (Delphi, Firemonkey)

I have a very simple Firemonkey project (RadStudio 10.3.3) that I am building to test certain layout options for a future project. In the past with VCL, I used modal forms. The project I am testing uses panels (Panel1 and Panel2) on the main form (Form1) to embed two additional forms (Form2 and Form3). The two embedded forms consist of a single listbox (ListBox1) on each form. The panels on the main form overlay, so I use the Visibility property to show the embedded form that I want. All the code is on the main form. The issue I have is that when I switch between Form2 and Form3, the strings loaded into the listbox on Form3 never appear. I have tried Repaint on the listbox and panel, InvalidateRect on the listbox, SetFocus on the panel, etc., all followed by Application.ProcessMessages. Nothing works successfully. The main code is: unit Unit1; interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Controls.Presentation, FMX.StdCtrls; type TForm1 = class(TForm) Panel1: TPanel; Button1: TButton; Panel2: TPanel; Button2: TButton; procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } procedure EmbedForm(AParent:TControl; AForm:TCustomForm); public { Public declarations } end; var Form1: TForm1; implementation {$R *.fmx} uses Unit2, Unit3; procedure TForm1.FormCreate(Sender: TObject); begin // Embed Form2 in Panel1 Application.CreateForm(TForm2, Form2); EmbedForm(Panel1, Form2); Panel1.Visible := true; // Embed Form3 in Panel2 Application.CreateForm(TForm3, Form3); EmbedForm(Panel2, Form3); Panel2.Visible := false; end; procedure TForm1.Button1Click(Sender: TObject); begin // Populate ListBox1 on Form2 - the LOAD button Form2.ListBox1.Items.Add('Hello'); Form2.ListBox1.Items.Add('World'); end; procedure TForm1.Button2Click(Sender: TObject); begin // Hide Panel1 (Form2) and show Panel2 (Form3) Panel1.Visible := false; Panel2.Visible := true; // Populate ListBox1 on Form3 Form3.ListBox1.Items.Add('Goodbye'); Form3.ListBox1.Items.Add('World'); // Repaint (Here's why I have tried various things to get the listbox strings to show up) //Panel2.Repaint; //Form3.ListBox1.Repaint; //Application.ProcessMessages; end; procedure TForm1.EmbedForm(AParent: TControl; AForm: TCustomForm); begin while AForm.ChildrenCount>0 do AForm.Children[0].Parent:=AParent; end; end. Form2 is as follows: unit Unit2; interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Layouts, FMX.ListBox; type TForm2 = class(TForm) ListBox1: TListBox; private { Private declarations } public { Public declarations } end; var Form2: TForm2; implementation {$R *.fmx} end. Form3 is as follows: unit Unit3; interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Layouts, FMX.ListBox, FMX.Controls.Presentation, FMX.StdCtrls; type TForm3 = class(TForm) ListBox1: TListBox; private { Private declarations } public { Public declarations } end; var Form3: TForm3; implementation {$R *.fmx} end. The .fmx files are below, as requested. Unit1.fmx (Form1): object Form1: TForm1 Left = 0 Top = 0 Caption = 'Form1' ClientHeight = 480 ClientWidth = 640 FormFactor.Width = 320 FormFactor.Height = 480 FormFactor.Devices = [Desktop] OnCreate = FormCreate DesignerMasterStyle = 0 object Button1: TButton Position.X = 232.000000000000000000 Position.Y = 448.000000000000000000 TabOrder = 1 Text = 'Load' OnClick = Button1Click end object Button2: TButton Position.X = 328.000000000000000000 Position.Y = 448.000000000000000000 TabOrder = 2 Text = 'Next' OnClick = Button2Click end object Panel1: TPanel Align = Center Size.Width = 640.000000000000000000 Size.Height = 393.000000000000000000 Size.PlatformDefault = False TabOrder = 0 end object Panel2: TPanel Position.Y = 43.000000000000000000 Size.Width = 640.000000000000000000 Size.Height = 393.000000000000000000 Size.PlatformDefault = False TabOrder = 4 end end Unit2.fmx (Form2): object Form2: TForm2 Left = 0 Top = 0 Caption = 'Form2' ClientHeight = 480 ClientWidth = 640 FormFactor.Width = 320 FormFactor.Height = 480 FormFactor.Devices = [Desktop] DesignerMasterStyle = 0 object ListBox1: TListBox Align = Center TabOrder = 0 DisableFocusEffect = True DefaultItemStyles.ItemStyle = '' DefaultItemStyles.GroupHeaderStyle = '' DefaultItemStyles.GroupFooterStyle = '' Viewport.Width = 200.000000000000000000 Viewport.Height = 200.000000000000000000 end end Unit3.fmx (Form3): object Form3: TForm3 Left = 0 Top = 0 Caption = 'Form3' ClientHeight = 480 ClientWidth = 640 FormFactor.Width = 320 FormFactor.Height = 480 FormFactor.Devices = [Desktop] DesignerMasterStyle = 0 object ListBox1: TListBox Position.X = 8.000000000000000000 Position.Y = 8.000000000000000000 TabOrder = 1 DisableFocusEffect = True DefaultItemStyles.ItemStyle = '' DefaultItemStyles.GroupHeaderStyle = '' DefaultItemStyles.GroupFooterStyle = '' Viewport.Width = 196.000000000000000000 Viewport.Height = 196.000000000000000000 end end Again, Form2 and Form3 each only contain a listbox (Listbox1 on both) and no additional code. I simply run the executable, click Button1 to display Hello World, then click Button2 to switch panels and display the second form and its listbox. As I am new to Firemonkey, I am sure I am missing something simple. Thanks for any and all help! The solution was very simple. I had to remove the CreateForm events for Form2 and Form3 from the project's initialization settings--a dumb mistake on my part. It was losing the reference to those forms during execution.
Read More

can not compile my Android app in 64 bit, I receive DCC Error: cannot find lgnustl_static [closed]

When I try to compile my app in android 64 bit under Delphi Rio 10.3.3 I receive this error message [DCC Error] E2597 C:\SDKs\android-ndk-r17b\toolchains\aarch64-linux-android-4.9\prebuilt\windows\aarch64-linux-android\bin\ld.exe: cannot find -lgnustl_static When I try to compile a new blank application, it's seam to work. Look like it's not working when I try to open an existing project (that was done in a lower version of Delphi) Note: I found, it's look like it's connected to Grijjy.ErrorReporting. Now I let the question open because I would like to find a workaround
Read More

Delphi GIF Firemonkey bugged

This is Firemonkey Animated GIF library for GIF Delphi Rad Studio. Last frame of the animation glitches when it loops back to the first frame i think. GIF starts to flicker when it goes to the beginning, the first frame from the last. Tried to change everything that you can, nothing helps. Help pls. Code in project for animate GIF using GIFPlayer through Image: uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Effects, FMX.StdCtrls, FMX.Controls.Presentation, FMX.GifUtils, FMX.Objects; procedure FormCreate(Sender: TObject); private { Private declarations } FGifPlayer: TGifPlayer; public { Public declarations } end; var Form1: TForm1; implementation {$R *.fmx} procedure TForm1.FormCreate(Sender: TObject); begin FGifPlayer := TGifPlayer.Create(Self); FGifPlayer.Image := Image1; FGifPlayer.LoadFromFile('youfilename.gif'); FGifPlayer.Play; end; The library .PAS is in the project folder. Code of library: interface uses System.Classes, System.SysUtils, System.Types, System.UITypes, FMX.Types, FMX.Objects, FMX.Graphics, System.Generics.Collections; const alphaTransparent = $00; GifSignature: array [0 .. 2] of Byte = ($47, $49, $46); // GIF VerSignature87a: array [0 .. 2] of Byte = ($38, $37, $61); // 87a VerSignature89a: array [0 .. 2] of Byte = ($38, $39, $61); // 89a GIF_DISPOSAL_UNSPECIFIED = 0; GIF_DISPOSAL_LEAVE = 1; GIF_DISPOSAL_BACKGROUND = 2; GIF_DISPOSAL_PREVIOUS = 3; type TGifVer = (verUnknow, ver87a, ver89a); TInternalColor = packed record case Integer of 0: ( {$IFDEF BIGENDIAN} R, G, B, A: Byte; {$ELSE} B, G, R, A: Byte; {$ENDIF} ); 1: (Color: TAlphaColor; ); end; {$POINTERMATH ON} PInternalColor = ^TInternalColor; {$POINTERMATH OFF} TGifRGB = packed record R: Byte; G: Byte; B: Byte; end; TGIFHeader = packed record Signature: array [0 .. 2] of Byte; // * Header Signature (always "GIF") */ Version: array [0 .. 2] of Byte; // * GIF format version("87a" or "89a") */ // Logical Screen Descriptor ScreenWidth: word; // * Width of Display Screen in Pixels */ ScreenHeight: word; // * Height of Display Screen in Pixels */ Packedbit: Byte; // * Screen and Color Map Information */ BackgroundColor: Byte; // * Background Color Index */ AspectRatio: Byte; // * Pixel Aspect Ratio */ end; TGifImageDescriptor = packed record Left: word; // * X position of image on the display */ Top: word; // * Y position of image on the display */ Width: word; // * Width of the image in pixels */ Height: word; // * Height of the image in pixels */ Packedbit: Byte; // * Image and Color Table Data Information */ end; TGifGraphicsControlExtension = packed record BlockSize: Byte; // * Size of remaining fields (always 04h) */ Packedbit: Byte; // * Method of graphics disposal to use */ DelayTime: word; // * Hundredths of seconds to wait */ ColorIndex: Byte; // * Transparent Color Index */ Terminator: Byte; // * Block Terminator (always 0) */ end; TGifReader = class; TPalette = TArray<TInternalColor>; TGifFrameItem = class; TGifFrameList = TObjectList<TGifFrameItem>; { TGifReader } TGifReader = class(TObject) protected FHeader: TGIFHeader; FPalette: TPalette; FScreenWidth: Integer; FScreenHeight: Integer; FInterlace: Boolean; FBitsPerPixel: Byte; FBackgroundColorIndex: Byte; FResolution: Byte; FGifVer: TGifVer; public function Read(Stream: TStream; var AFrameList: TGifFrameList): Boolean; overload; virtual; function Read(FileName: string; var AFrameList: TGifFrameList): Boolean; overload; virtual; function ReadRes(Instance: THandle; ResName: string; ResType: PChar; var AFrameList: TGifFrameList): Boolean; overload; virtual; function ReadRes(Instance: THandle; ResId: Integer; ResType: PChar; var AFrameList: TGifFrameList): Boolean; overload; virtual; function Check(Stream: TStream): Boolean; overload; virtual; function Check(FileName: string): Boolean; overload; virtual; public constructor Create; virtual; destructor Destroy; override; property Header: TGIFHeader read FHeader; property ScreenWidth: Integer read FScreenWidth; property ScreenHeight: Integer read FScreenHeight; property Interlace: Boolean read FInterlace; property BitsPerPixel: Byte read FBitsPerPixel; property Background: Byte read FBackgroundColorIndex; property Resolution: Byte read FResolution; property GifVer: TGifVer read FGifVer; end; TGifFrameItem = class FDisposalMethod: Integer; FPos: TPoint; FTime: Integer; FDisbitmap: TBitmap; fBackColor : TalphaColor; public destructor Destroy; override; property Bitmap : TBitmap read FDisbitmap; end; TGifPlayer = class(TComponent) private FImage: TImage; FGifFrameList: TGifFrameList; FTimer: TTimer; FActiveFrameIndex: Integer; FSpeedup: Single; FScreenHeight: Integer; FScreenWidth: Integer; procedure SetImage(const Value: TImage); procedure TimerProc(Sender: TObject); function GetIsPlaying: Boolean; procedure SetActiveFrameIndex(const Value: Integer); procedure SetSpeedup(const Value: Single); protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure LoadFromFile(AFileName: string); procedure LoadFromStream(AStream: TStream); procedure LoadFromResById(Instance: THandle; ResId: Integer; ResType: PChar); procedure LoadFromResByName(Instance: THandle; ResName: string; ResType: PChar); procedure Play(); procedure Pause(); procedure stop(); // property Image: TImage read FImage write SetImage; property IsPlaying: Boolean read GetIsPlaying; property Speedup: Single read FSpeedup write SetSpeedup; property ActiveFrameIndex: Integer read FActiveFrameIndex write SetActiveFrameIndex; property ScreenWidth: Integer read FScreenWidth; property ScreenHeight: Integer read FScreenHeight; end; implementation uses Math; function swap16(x: UInt16): UInt16; inline; begin Result := ((x and $FF) shl 8) or ((x and $FF00) shr 8); end; function swap32(x: UInt32): UInt32; inline; begin Result := ((x and $FF) shl 24) or ((x and $FF00) shl 8) or ((x and $FF0000) shr 8) or ((x and $FF000000) shr 24); end; function LEtoN(Value: word): word; overload; begin Result := swap16(Value); end; function LEtoN(Value: Dword): Dword; overload; begin Result := swap32(Value); end; procedure MergeBitmap(const Source, Dest: TBitmap; SrcRect: TRect; DestX, DestY: Integer); var I, J, MoveBytes: Integer; SrcData, DestData: TBitmapData; lpColorSrc, lpColorDst: PInternalColor; begin With Dest do begin if Map(TMapAccess.Write, DestData) then try if Source.Map(TMapAccess.Read, SrcData) then try if SrcRect.Left < 0 then begin Dec(DestX, SrcRect.Left); SrcRect.Left := 0; end; if SrcRect.Top < 0 then begin Dec(DestY, SrcRect.Top); SrcRect.Top := 0; end; SrcRect.Right := Min(SrcRect.Right, Source.Width); SrcRect.Bottom := Min(SrcRect.Bottom, Source.Height); if DestX < 0 then begin Dec(SrcRect.Left, DestX); DestX := 0; end; if DestY < 0 then begin Dec(SrcRect.Top, DestY); DestY := 0; end; if DestX + SrcRect.Width > Width then SrcRect.Width := Width - DestX; if DestY + SrcRect.Height > Height then SrcRect.Height := Height - DestY; if (SrcRect.Left < SrcRect.Right) and (SrcRect.Top < SrcRect.Bottom) then begin MoveBytes := SrcRect.Width * SrcData.BytesPerPixel; for I := 0 to SrcRect.Height - 1 do begin lpColorSrc := SrcData.GetPixelAddr(SrcRect.Left, SrcRect.Top + I); lpColorDst := DestData.GetPixelAddr(DestX, DestY + I); for J := 0 to SrcRect.Width - 1 do if lpColorSrc[J].A <> 0 then begin lpColorDst[J] := lpColorSrc[J]; end; end; end; finally Source.Unmap(SrcData); end; finally Unmap(DestData); end; end; end; { TGifReader } function TGifReader.Read(FileName: string; var AFrameList: TGifFrameList): Boolean; var fs: TFileStream; begin Result := False; fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try Result := Read(fs, AFrameList); except end; fs.DisposeOf; end; function TGifReader.ReadRes(Instance: THandle; ResName: string; ResType: PChar; var AFrameList: TGifFrameList): Boolean; var res: TResourceStream; begin res := TResourceStream.Create(HInstance, ResName, ResType); Result := Read(res, AFrameList); res.DisposeOf; end; function TGifReader.ReadRes(Instance: THandle; ResId: Integer; ResType: PChar; var AFrameList: TGifFrameList): Boolean; var res: TResourceStream; begin res := TResourceStream.CreateFromID(HInstance, ResId, ResType); Result := Read(res, AFrameList); res.DisposeOf; end; function TGifReader.Read(Stream: TStream; var AFrameList: TGifFrameList): Boolean; var LDescriptor: TGifImageDescriptor; LGraphicsCtrlExt: TGifGraphicsControlExtension; LIsTransparent: Boolean; LGraphCtrlExt: Boolean; LFrameWidth: Integer; LFrameHeight: Integer; LLocalPalette: TPalette; LScanLineBuf: TBytes; procedure ReadPalette(Stream: TStream; Size: Integer; var APalette: TPalette); Var RGBEntry: TGifRGB; I: Integer; c: TInternalColor; begin SetLength(APalette, Size); For I := 0 To Size - 1 Do Begin Stream.Read(RGBEntry, SizeOf(RGBEntry)); With APalette[I] do begin R := RGBEntry.R or (RGBEntry.R shl 8); G := RGBEntry.G or (RGBEntry.G shl 8); B := RGBEntry.B or (RGBEntry.B shl 8); A := $FF; end; End; end; function ProcHeader: Boolean; var c: TInternalColor; begin Result := False; With FHeader do begin if (CompareMem(@Signature, @GifSignature, 3)) and (CompareMem(@Version, @VerSignature87a, 3)) or (CompareMem(@Version, @VerSignature89a, 3)) then begin FScreenWidth := FHeader.ScreenWidth; FScreenHeight := FHeader.ScreenHeight; FResolution := Packedbit and $70 shr 5 + 1; FBitsPerPixel := Packedbit and 7 + 1; FBackgroundColorIndex := BackgroundColor; if CompareMem(@Version, @VerSignature87a, 3) then FGifVer := ver87a else if CompareMem(@Version, @VerSignature89a, 3) then FGifVer := ver89a; Result := True; end else Raise Exception.Create('Unknown GIF image format'); end; end; function ProcFrame: Boolean; var LineSize: Integer; LBackColorIndex: Integer; begin Result := False; With LDescriptor do begin LFrameWidth := Width; LFrameHeight := Height; FInterlace := ((Packedbit and $40) = $40); end; if LGraphCtrlExt then begin LIsTransparent := (LGraphicsCtrlExt.Packedbit and $01) <> 0; If LIsTransparent then LBackColorIndex := LGraphicsCtrlExt.ColorIndex; end else begin LIsTransparent := FBackgroundColorIndex <> 0; LBackColorIndex := FBackgroundColorIndex; end; LineSize := LFrameWidth * (LFrameHeight + 1); SetLength(LScanLineBuf, LineSize); If LIsTransparent then begin LLocalPalette[LBackColorIndex].A := alphaTransparent; end; Result := True; end; function ReadAndProcBlock(Stream: TStream): Byte; var Introducer, Labels, SkipByte: Byte; begin Stream.Read(Introducer, 1); if Introducer = $21 then begin Stream.Read(Labels, 1); Case Labels of $FE, $FF: // Comment Extension block or Application Extension block while True do begin Stream.Read(SkipByte, 1); if SkipByte = 0 then Break; Stream.Seek(Int64( SkipByte), soFromCurrent); end; $F9: // Graphics Control Extension block begin Stream.Read(LGraphicsCtrlExt, SizeOf(LGraphicsCtrlExt)); LGraphCtrlExt := True; end; $01: // Plain Text Extension block begin Stream.Read(SkipByte, 1); Stream.Seek(Int64( SkipByte), soFromCurrent); while True do begin Stream.Read(SkipByte, 1); if SkipByte = 0 then Break; Stream.Seek(Int64( SkipByte), soFromCurrent); end; end; end; end; Result := Introducer; end; function ReadScanLine(Stream: TStream; AScanLine: PByte): Boolean; var OldPos, UnpackedSize, PackedSize: longint; I: Integer; Data, Bits, Code: Cardinal; SourcePtr: PByte; InCode: Cardinal; CodeSize: Cardinal; CodeMask: Cardinal; FreeCode: Cardinal; OldCode: Cardinal; Prefix: array [0 .. 4095] of Cardinal; Suffix, Stack: array [0 .. 4095] of Byte; StackPointer: PByte; Target: PByte; DataComp: TBytes; B, FInitialCodeSize, FirstChar: Byte; ClearCode, EOICode: word; begin DataComp := nil; try try Stream.Read(FInitialCodeSize, 1); OldPos := Stream.Position; PackedSize := 0; Repeat Stream.Read(B, 1); if B > 0 then begin Inc(PackedSize, B); Stream.Seek(Int64(B), soFromCurrent); CodeMask := (1 shl CodeSize) - 1; end; until B = 0; SetLength(DataComp, 2 * PackedSize); SourcePtr := @DataComp[0]; Stream.Position := OldPos; Repeat Stream.Read(B, 1); if B > 0 then begin Stream.ReadBuffer(SourcePtr^, B); Inc(SourcePtr, B); end; until B = 0; SourcePtr := @DataComp[0]; Target := AScanLine; CodeSize := FInitialCodeSize + 1; ClearCode := 1 shl FInitialCodeSize; EOICode := ClearCode + 1; FreeCode := ClearCode + 2; OldCode := 4096; CodeMask := (1 shl CodeSize) - 1; UnpackedSize := LFrameWidth * LFrameHeight; for I := 0 to ClearCode - 1 do begin Prefix[I] := 4096; Suffix[I] := I; end; StackPointer := @Stack; FirstChar := 0; Data := 0; Bits := 0; while (UnpackedSize > 0) and (PackedSize > 0) do begin Inc(Data, SourcePtr^ shl Bits); Inc(Bits, 8); while Bits >= CodeSize do begin Code := Data and CodeMask; Data := Data shr CodeSize; Dec(Bits, CodeSize); if Code = EOICode then Break; if Code = ClearCode then begin CodeSize := FInitialCodeSize + 1; CodeMask := (1 shl CodeSize) - 1; FreeCode := ClearCode + 2; OldCode := 4096; Continue; end; if Code > FreeCode then Break; if OldCode = 4096 then begin FirstChar := Suffix[Code]; Target^ := FirstChar; Inc(Target); Dec(UnpackedSize); OldCode := Code; Continue; end; InCode := Code; if Code = FreeCode then begin StackPointer^ := FirstChar; Inc(StackPointer); Code := OldCode; end; while Code > ClearCode do begin StackPointer^ := Suffix[Code]; Inc(StackPointer); Code := Prefix[Code]; end; FirstChar := Suffix[Code]; StackPointer^ := FirstChar; Inc(StackPointer); Prefix[FreeCode] := OldCode; Suffix[FreeCode] := FirstChar; if (FreeCode = CodeMask) and (CodeSize < 12) then begin Inc(CodeSize); CodeMask := (1 shl CodeSize) - 1; end; if FreeCode < 4095 then Inc(FreeCode); OldCode := InCode; repeat Dec(StackPointer); Target^ := StackPointer^; Inc(Target); Dec(UnpackedSize); until StackPointer = @Stack; end; Inc(SourcePtr); Dec(PackedSize); end; finally DataComp := nil; end; except end; Result := True; end; function WriteScanLine(var Img: TBitmap; AScanLine: PByte): Boolean; Var Row, Col: Integer; Pass, Every: Byte; P: PByte; function IsMultiple(NumberA, NumberB: Integer): Boolean; begin Result := (NumberA >= NumberB) and (NumberB > 0) and (NumberA mod NumberB = 0); end; var PLine: PInternalColor; Data: TBitmapData; begin Result := False; P := AScanLine; if Img.Map(TMapAccess.Write, Data) then begin try If FInterlace then begin For Pass := 1 to 4 do begin Case Pass of 1: begin Row := 0; Every := 8; end; 2: begin Row := 4; Every := 8; end; 3: begin Row := 2; Every := 4; end; 4: begin Row := 1; Every := 2; end; end; Repeat PLine := Data.GetScanline(Row); for Col := 0 to Img.Width - 1 do begin PLine[Col] := LLocalPalette[P^]; Inc(P); end; Inc(Row, Every); until Row >= Img.Height; end; end else begin for Row := 0 to Img.Height - 1 do begin PLine := Data.GetScanline(Row); for Col := 0 to Img.Width - 1 do begin PLine[Col] := LLocalPalette[P^]; Inc(P); end; end; end; Result := True; finally Img.Unmap(Data); end; end; end; procedure RenderFrame(const Index : integer; const aFrames : array of TGifFrameItem; const aDisplay : TBitmap); var I, First, Last: Integer; begin Last := Index; First := Max(0, Last); aDisplay.Clear(aFrames[Index].fBackColor); while First > 0 do begin if (fScreenWidth = aFrames[First].Bitmap.Width) and (fScreenHeight = aFrames[First].Bitmap.Height) then begin if (aFrames[First].FDisposalMethod = GIF_DISPOSAL_BACKGROUND) and (First < Last) then Break; end; Dec(First); end; for I := First to Last - 1 do begin case aFrames[I].FDisposalMethod of GIF_DISPOSAL_UNSPECIFIED, GIF_DISPOSAL_LEAVE: begin // Copy previous raw frame onto screen MergeBitmap(aFrames[i].Bitmap, aDisplay, aFrames[i].Bitmap.Bounds, aFrames[i].FPos.X, aFrames[i].FPos.Y); end; GIF_DISPOSAL_BACKGROUND: if (I > First) then begin // Restore background color aDisplay.ClearRect(TRectF.Create(aFrames[i].FPos.X, aFrames[i].FPos.Y, aFrames[i].FPos.X + aFrames[i].Bitmap.Width, aFrames[i].FPos.Y + aFrames[i].Bitmap.Height), aFrames[i].fBackColor); end; GIF_DISPOSAL_PREVIOUS: ; // Do nothing - previous state is already on screen end; end; MergeBitmap(aFrames[Index].Bitmap, aDisplay, aFrames[Index].Bitmap.Bounds, aFrames[Index].FPos.X, aFrames[Index].FPos.Y); end; var Introducer: Byte; ColorTableSize: Integer; tmp: TBitmap; LFrame: TGifFrameItem; FrameIndex: Integer; I: Integer; LBC : integer; LFrames : array of TGifFrameItem; rendered : array of TBitmap; begin Result := False; if not Check(Stream) then Exit; AFrameList.Clear; FGifVer := verUnknow; FPalette := nil; LScanLineBuf := nil; try Stream.Position := 0; Stream.Read(FHeader, SizeOf(FHeader)); {$IFDEF BIGENDIAN} with FHeader do begin ScreenWidth := LEtoN(ScreenWidth); ScreenHeight := LEtoN(ScreenHeight); end; {$ENDIF} if (FHeader.Packedbit and $80) = $80 then begin ColorTableSize := FHeader.Packedbit and 7 + 1; ReadPalette(Stream, 1 shl ColorTableSize, FPalette); end; if not ProcHeader then Exit; FrameIndex := 0; SetLength(LFrames, 0); while True do begin LLocalPalette := nil; Repeat Introducer := ReadAndProcBlock(Stream); until (Introducer in [$2C, $3B]); if Introducer = $3B then Break; Stream.Read(LDescriptor, SizeOf(LDescriptor)); {$IFDEF BIGENDIAN} with FDescriptor do begin Left := LEtoN(Left); Top := LEtoN(Top); Width := LEtoN(Width); Height := LEtoN(Height); end; {$ENDIF} if (LDescriptor.Packedbit and $80) <> 0 then begin ColorTableSize := LDescriptor.Packedbit and 7 + 1; ReadPalette(Stream, 1 shl ColorTableSize, LLocalPalette); end else begin LLocalPalette := Copy(FPalette, 0, Length(FPalette)); end; if not ProcFrame then Exit; LFrame := TGifFrameItem.Create; LFrame.FTime := 10 * LGraphicsCtrlExt.DelayTime; LFrame.FDisbitmap := TBitmap.Create(LFrameWidth, LFrameHeight); LFrame.FPos := Point(LDescriptor.Left, LDescriptor.Top); LFrame.FDisposalMethod := 7 and (LGraphicsCtrlExt.Packedbit shr 2); if not ReadScanLine(Stream, @LScanLineBuf[0]) then Exit; if not WriteScanLine(LFrame.FDisbitmap, @LScanLineBuf[0]) then Exit; if LGraphCtrlExt then begin LIsTransparent := (LGraphicsCtrlExt.Packedbit and $01) <> 0; If LIsTransparent then LBC := LGraphicsCtrlExt.ColorIndex else LBC := FBackgroundColorIndex; end else LBC := FBackgroundColorIndex; LFrame.fBackColor := LLocalPalette[LBC].Color; Inc(FrameIndex); SetLength(LFrames, FrameIndex); LFrames[FrameIndex - 1] := LFrame; end; SetLength(rendered, Length(LFrames)); for I := 0 to Length(LFrames) - 1 do begin tmp := TBitmap.Create(FScreenWidth, FScreenHeight); RenderFrame(I, LFrames, tmp); rendered[i] := tmp; end; for I := 0 to Length(LFrames) - 1 do begin LFrames[i].Bitmap.Assign(rendered[i]); FreeAndNil(rendered[i]); AFrameList.Add(LFrames[i]); end; Result := True; finally LLocalPalette := nil; LScanLineBuf := nil; rendered := nil; LFrames := nil; end; end; function TGifReader.Check(Stream: TStream): Boolean; var OldPos: Int64; begin try OldPos := Stream.Position; Stream.Read(FHeader, SizeOf(FHeader)); Result := (CompareMem(@FHeader.Signature, @GifSignature, 3)) and (CompareMem(@FHeader.Version, @VerSignature87a, 3)) or (CompareMem(@FHeader.Version, @VerSignature89a, 3)); Stream.Position := OldPos; except Result := False; end; end; function TGifReader.Check(FileName: string): Boolean; var fs: TFileStream; begin Result := False; fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try Result := Check(fs); except end; fs.DisposeOf; end; constructor TGifReader.Create; begin inherited Create; end; destructor TGifReader.Destroy; begin inherited Destroy; end; { TGifFrameItem } destructor TGifFrameItem.Destroy; begin if FDisbitmap <> nil then begin FDisbitmap.DisposeOf; FDisbitmap := nil; end; inherited Destroy; end; { TGifPlayer } constructor TGifPlayer.Create(AOwner: TComponent); begin inherited Create(AOwner); FGifFrameList := TGifFrameList.Create(); FTimer := TTimer.Create(Self); FTimer.Enabled := False; FTimer.OnTimer := TimerProc; FSpeedup := 1.0; end; destructor TGifPlayer.Destroy; begin FTimer.Enabled := False; FGifFrameList.DisposeOf; FGifFrameList := nil; inherited Destroy; end; function TGifPlayer.GetIsPlaying: Boolean; begin Result := FTimer.Enabled; end; procedure TGifPlayer.LoadFromFile(AFileName: string); var gr: TGifReader; begin gr := TGifReader.Create; gr.Read(AFileName, FGifFrameList); FScreenWidth := gr.ScreenWidth; FScreenHeight := gr.ScreenHeight; gr.DisposeOf; ActiveFrameIndex := 0; end; procedure TGifPlayer.LoadFromResById(Instance: THandle; ResId: Integer; ResType: PChar); var gr: TGifReader; begin gr := TGifReader.Create; gr.ReadRes(Instance, ResId, ResType, FGifFrameList); FScreenWidth := gr.ScreenWidth; FScreenHeight := gr.ScreenHeight; gr.DisposeOf; ActiveFrameIndex := 0; end; procedure TGifPlayer.LoadFromResByName(Instance: THandle; ResName: string; ResType: PChar); var gr: TGifReader; begin gr := TGifReader.Create; gr.ReadRes(Instance, ResName, ResType, FGifFrameList); FScreenWidth := gr.ScreenWidth; FScreenHeight := gr.ScreenHeight; gr.DisposeOf; ActiveFrameIndex := 0; end; procedure TGifPlayer.LoadFromStream(AStream: TStream); var gr: TGifReader; begin gr := TGifReader.Create; gr.Read(AStream, FGifFrameList); FScreenWidth := gr.ScreenWidth; FScreenHeight := gr.ScreenHeight; gr.DisposeOf; ActiveFrameIndex := 0; end; procedure TGifPlayer.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if Operation = opRemove then begin if AComponent = FImage then FImage := nil; end; end; procedure TGifPlayer.Pause; begin FTimer.Enabled := False; end; procedure TGifPlayer.Play; begin if not IsPlaying then begin ActiveFrameIndex := FActiveFrameIndex; FTimer.Enabled := True; end; end; procedure TGifPlayer.SetActiveFrameIndex(const Value: Integer); var lInterval: Integer; begin // if (FActiveFrameIndex <> Value) then begin FActiveFrameIndex := Value; if (FActiveFrameIndex < 0) or (FActiveFrameIndex >= FGifFrameList.Count) then FActiveFrameIndex := -1; if (FActiveFrameIndex >= 0) and (FActiveFrameIndex < FGifFrameList.Count) then begin if FImage <> nil then begin FImage.Bitmap.Assign(FGifFrameList[FActiveFrameIndex].FDisbitmap); end; lInterval := FGifFrameList[FActiveFrameIndex].FTime; if lInterval = 0 then lInterval := 100; lInterval := Trunc(lInterval / FSpeedup); if lInterval <= 3 then lInterval := 3; FTimer.Interval := lInterval; end else begin FImage.Bitmap.SetSize(0, 0); FTimer.Interval := 0; end; end; end; procedure TGifPlayer.SetImage(const Value: TImage); begin FImage := Value; if FImage <> nil then FImage.FreeNotification(Self); end; procedure TGifPlayer.SetSpeedup(const Value: Single); begin if FSpeedup <> Value then begin FSpeedup := Value; if FSpeedup <= 0.001 then FSpeedup := 0.001; end; end; procedure TGifPlayer.stop; begin Pause; FActiveFrameIndex := 0; end; procedure TGifPlayer.TimerProc(Sender: TObject); var Interval: Integer; begin if ([csDesigning, csDestroying, csLoading] * ComponentState) <> [] then Exit; FTimer.Enabled := False; if ActiveFrameIndex < (FGifFrameList.Count - 1) then ActiveFrameIndex := FActiveFrameIndex + 1 else ActiveFrameIndex := 0; FTimer.Enabled := True; end; end.
Read More