Category: Firemonkey

The ARC vs non-ARC situation adds yet another layer of complexity to creating cross platform code…

Interesting rant on the Delphi cross platform situation, for which this is a reminder to see how the current situation is after 2.5 years: [WayBack] The ARC vs non-ARC situation adds yet another layer of complexity to creating cross platform code. The Linux compiler uses ARC – while Windows and OSX don’t… – Lars Fosdal – Google+ –jeroen
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

Why uploaded photo is much smaller than saved – Delphi 10.3.2, firemonkey

I have Delphi 10.3.2 I do not understand this situations: 1) Uploading photo about 1M image1.Bitmap.LoadFromFile('test.jpg'); Then I save the same photo image1.Bitmap.SaveToFile('test_new.jpg'); and test_new.jpg is about 3M. Why ??? 2) I want to send a photo from the TImage (test1.jpg - 1MB) object using IdHTTP and POST request to server. I use the function Base64_Encoding_stream to encode image. Image size (string) after encoding the function is 20 MB! ? Why if the original file has 1MB ? function Base64_Encoding_stream(_image:Timage): string; var base64: TIdEncoderMIME; output: string; stream_image : TStream; begin try begin base64 := TIdEncoderMIME.Create(nil); stream_image := TMemoryStream.Create; _image.Bitmap.SaveToStream(stream_image); stream_image.Position := 0; output := TIdEncoderMIME.EncodeStream(stream_image); stream_image.Free; base64.Free; if not(output = '') then begin Result := output; end else begin Result := 'Error'; end; end; except begin Result := 'Error' end; end; end; .... img_encoded := Base64_Encoding_stream(Image1); ..... procedure Send(_json:String ); var lHTTP : TIdHTTP; PostData : TStringList; begin PostData := TStringList.Create; lHTTP := TIdHTTP.Create(nil); try PostData.Add('dane=' + _json ); lHTTP.Request.UserAgent := 'Mozilla/5.0 (Windows NT 6.1; WOW64; rv:12.0) Gecko/20100101 Firefox/12.0'; lHTTP.Request.Connection := 'keep-alive'; lHTTP.Request.ContentType := 'application/x-www-form-urlencoded'; lHTTP.Request.Charset := 'utf-8'; lHTTP.Request.Method := 'POST'; _dane := lHTTP.Post('http://......./add_photo.php',PostData); finally lHTTP.Free; PostData.Free; end;
Read More

macOS & Android 64 bit compile-ready support (update)

A while ago, we've posted a blog about macOS 64 bit support that has been added to our products. macOS 64 bit support has been added in RAD Studio Rio 10.3.2 and now with the 10.3.3 release, you can also target Android 64 bit. Unfortunately, there is no automatic installation for those 2 targets as there is no way for us to detect which version is installed and for which target(s) we need to compile. We aim for adding automatic installation support in RAD Studio 10.4. More information on how to add macOS and/or Android 64 bit support to your application is explained in the following blog post: https://www.tmssoftware.com/site/blog.asp?post=571
Read More

RAD Studio 10.3.3: iOS 13およびmacOS Catalinaサポート

7月にリリースした10.3.2では、Delphi向けmacOS 64-bitサポートを追加しました。10.3.3ではこれを拡張し、macOS Catalinaをサポートします。macOS Catalinaは、すべてのアプリが64-bit対応を要求される最初のmacOSバージョンとなります。Delphi macOS 64-bitサポートにより、公証サポートを含むmacOS App Storeをターゲットとした開発が可能になります。(read more)
Read More