-
Постов
222 -
Зарегистрирован
-
Посещение
-
Победитель дней
5
Сообщения, опубликованные Вадим Смоленский
-
-
Год назад в одной из веток проскочила ссылка на китайский сайт (http://www.raysoftware.cn/?p=559), где предлагалось готовое решение для показа анимированных гифок средствами FireMonkey на любых платформах. Сейчас эта ссылка, как и весь сайт raysoftware.cn, упорно не открывается; по счастью, контент сохранился в гугловском кэше. Я скопировал оттуда код юнита и перевел гуглом все китайские комментарии на английский, добавив их в скобках. Там был еще сопроводительный текст, в котором автор излагал мотивы, побудившие его взяться за эту проблему; каких-то важных технических деталей я в этом тексте не увидел.
Привожу весь юнит ниже и очень надеюсь, что кто-нибудь из продвинутых коллег объяснит мне, как именно этим кодом можно воспользоваться, чтобы показать пользователю анимированный файл в формате GIF. Моей программерской квалификации, к сожалению, не хватает.
Спойлерunit FMX.GifUtils; 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; // 是否是交织的 (Whether it is intertwined) property BitsPerPixel: Byte read FBitsPerPixel; // 颜色位 (Color bit) property Background: Byte read FBackgroundColorIndex; // 背景色 (Background color) property Resolution: Byte read FResolution; // property GifVer: TGifVer read FGifVer; // 版本,枚举类型 (Version, enumeration type) end; TGifFrameItem = class FDisposalMethod: Integer; FPos: TPoint; FTime: Integer; FDisbitmap: TBitmap; public destructor Destroy; override; 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; { 不知道为什么Windows下和Android中的Canvas.DrawBitmap对透明处理有区别, 写这个函数来弥补这个区别 I don't know why the Canvas.DrawBitmap between Windows and Android is different for transparent processing. Write this function to make up for this difference } 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; // 读取调色板 (Reading palette) 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; // 处理文件头,把文件头解析到对象的属性 // (Process file headers and parse file headers into object properties) 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; // 全局颜色表的大小,Packedbit+1就是颜色表的位数 (The size of the global color table, Packedbit+1 is the number of bits in the color table) 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; // 处理一帧 (Handle a frame) function ProcFrame: Boolean; var LineSize: Integer; LBackColorIndex: Integer; begin Result := False; With LDescriptor do begin LFrameWidth := Width; LFrameHeight := Height; FInterlace := ((Packedbit and $40) = $40); // 交织标志 (Intertwined logo) 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); // 如果有透明,就把透明色的调色板中的颜色的Alpha值改成透明的 // (If transparent, change the alpha value of the color in the transparent palette to transparent) If LIsTransparent then begin LLocalPalette[LBackColorIndex].A := alphaTransparent; end; Result := True; end; // 处理块 (Processing block) 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; // 把一帧图像解析到ScanLine (Analyze a frame of image to ScanLine) 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 // 读取目录大小 (Read directory size) Stream.Read(FInitialCodeSize, 1); // 找到压缩表的结束位置 (Find the end of the compressed table) 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); // 读取压缩表 (Read the compression table) 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; // 解压LZW (Unzip LZW) 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; // 把ScanLine写到我们常用的图像 (Write ScanLine to our usual image) 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 it is intertwined) 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; PLine := Data.GetScanline(Row); Repeat 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; var Introducer: Byte; ColorTableSize: Integer; tmp: TBitmap; LFrame: TGifFrameItem; FrameIndex: Integer; I: Integer; begin Result := False; if not Check(Stream) then Exit; AFrameList.Clear; FGifVer := verUnknow; FPalette := nil; LScanLineBuf := nil; try Stream.Position := 0; // 读文件头 (Read file header) Stream.Read(FHeader, SizeOf(FHeader)); // 字节序 (Byte order) {$IFDEF BIGENDIAN} with FHeader do begin ScreenWidth := LEtoN(ScreenWidth); ScreenHeight := LEtoN(ScreenHeight); end; {$ENDIF} // 如果有全局的调色板 (If there is a global palette) if (FHeader.Packedbit and $80) = $80 then begin ColorTableSize := FHeader.Packedbit and 7 + 1; ReadPalette(Stream, 1 shl ColorTableSize, FPalette); end; // 处理头 (Processing head) if not ProcHeader then Exit; FrameIndex := 0; while True do begin LLocalPalette := nil; Repeat Introducer := ReadAndProcBlock(Stream); until (Introducer in [$2C, $3B]); // 2C每一帧的标识,3B文件结尾标志 (2C identification of each frame, 3B file end marker) if Introducer = $3B then Break; // 描述符 (Descriptor) 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 you have a local palette, use the local palette, otherwise copy the global palette) 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; // 创建图片 (Create a picture) LFrame := TGifFrameItem.Create; LFrame.FTime := 10 * LGraphicsCtrlExt.DelayTime; LFrame.FDisbitmap := TBitmap.Create(FScreenWidth, FScreenHeight); tmp := TBitmap.Create(LFrameWidth, LFrameHeight); LFrame.FPos := Point(LDescriptor.Left, LDescriptor.Top); LFrame.FDisposalMethod := 7 and (LGraphicsCtrlExt.Packedbit shr 2); // 读取ScanLine (Read ScanLine) if not ReadScanLine(Stream, @LScanLineBuf[0]) then Exit; // 写ScanLine (Write ScanLine) if not WriteScanLine(tmp, @LScanLineBuf[0]) then Exit; if FrameIndex = 0 then begin // 第0个强制视为 DisposalMethod = GIF_DISPOSAL_UNSPECIFIED (The 0th mandatory as DisposalMethod = GIF_DISPOSAL_UNSPECIFIED) LFrame.FDisbitmap.Clear(LLocalPalette[FBackgroundColorIndex].Color); MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth, LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y); // CoverData(LFrame.FDisbitmap, tmp, Bounds(LFrame.FPos.X, LFrame.FPos.Y, // LFrameWidth, LFrameHeight), Rect(0, 0, LFrameWidth, LFrameHeight)); end else begin case AFrameList[AFrameList.Count - 1].FDisposalMethod of GIF_DISPOSAL_UNSPECIFIED, // 不处理 (Do not handle) GIF_DISPOSAL_LEAVE: // 不处置图形,把图形从当前位置移去,重绘背景,在背景基础上画新的一帧 (Does not deal with graphics, remove the graphics from the current position, redraw the background, draw a new frame based on the background) begin LFrame.FDisbitmap.CopyFromBitmap(AFrameList[AFrameList.Count - 1] .FDisbitmap); MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth, LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y); end; GIF_DISPOSAL_BACKGROUND: // 恢复到背景色 (Revert to background color) begin LFrame.FDisbitmap.Clear (LLocalPalette[FBackgroundColorIndex].Color); MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth, LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y); end; GIF_DISPOSAL_PREVIOUS: // 回复到先前状态 (Revert to previous status) begin // 向前追溯到关键帧,如果没用就是第0帧 (Trace back to the keyframe, if it is not used is the 0th frame) for I := AFrameList.Count - 1 downto 0 do begin if (AFrameList[I].FDisposalMethod = GIF_DISPOSAL_BACKGROUND) then Break; end; if I < 0 then I := 0; LFrame.FDisbitmap.CopyFromBitmap(AFrameList[I].FDisbitmap); MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth, LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y); end; 4 .. 7: // 自定义处理,咋处理,不知道。。。 (Custom processing, processing, do not know. . .) begin end; end; end; AFrameList.Add(LFrame); // tmp.SaveToFile(Format('d:\test%d.png', [FrameIndex])); // LFrame.FDisbitmap.SaveToFile(Format('d:\test%d.png', [FrameIndex])); tmp.DisposeOf; Inc(FrameIndex); end; Result := True; finally LLocalPalette := nil; LScanLineBuf := 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.
-
Похоже, никто на форуме этой темой не владеет. Нужно бы спросить непосредственно в Embarcadero - но как? Моя подписка на апдейты истекла в декабре; насколько я понимаю, право обращения в поддержку истекло тогда же. Существует ли способ для таких, как я, получить ответ на один-единственный, но жизненно важный вопрос по функциям RAD Studio?
-
33 минуты назад, wamaco сказал:
Лучше приложите проект! Мы разберем его на "косточки" и укажем, где ошибка!
Проект гигантский, как его приложишь... Уповаю лишь на то, что с таким феноменом кто-нибудь уже сталкивался.
-
Проект для Windows, автономная БД SQLite, никаких клиент-серверных дел, компоненты и операции самые простые: SQL-запрос в TFDQuery, вызов метода Open. Всё работает нормально, но отдельные пользователи жалуются на эпизодические непредсказуемые падения при поиске. Интересно, что после каждого такого падения всё опять функционирует нормально, но потом приложение не удается нормально закрыть, приходится вызывать диспетчер задач.
Стабильно воспроизвести не могут ни пользователи, ни я сам. Мне удалось это считанные несколько раз - я лишь смог убедиться через отладчик, что проблема при закрытии связана именно с базой данных: вставлял в обработчик FormCloseQuery оператор TFDConnection.Close - и программа пару раз упала именно на этом операторе.
Найти корень зла пока не удалось. Показалось только, что проблема возникает лишь тогда, когда поиск приводит к слишком большому (несколько тысяч) числу записей в TFDQuery.
Может, стоит поменять какие-нибудь установки в TFDConnection или TFDQuery ?
-
Упаковываю свое приложение в appx при помощи кнопки Deploy в Deployment Manager. При этом в разделе Опций "Manifest File" выставлено "Auto Generate". В итоге получается файл AppxManifest.xml; насколько я понимаю, этот манифест также включается в состав итогового пакета appx.
Пробую загрузить получившийся appx в Microsoft Store. Грузится очень долго и в итоге выдает ошибку: "You don't have permissions to specify the following namespaces in the appx manifest file of the package MyApp.appx: restricted namespace: http://schemas.microsoft.com/appx/manifest/foundation/windows10/restrictedcapabilities"
В файле AppxManifest.xml действительно отыскивается такой фрагмент. Убираю его, заодно убираю фрагмент <Capabilities> ... </Capabilities> (если не убрать, получившийся xml даже не отобразится в браузере), переименовываю в MyApp.manifest, меняю установку для манифеста на "Custom", указываю имя. Всё повторяю. Результат ровно тот же.
Полностью меняю содержимое MyApp.manifest, беря шаблон отсюда. Всё повторяю. Результат опять тот же. Опять магазину не нравится фрагмент манифеста насчет restricted capabilities, которого теперь, по идее, там быть не должно.
Такое ощущение, что при формировании пакета appx не имеют никакого значения установки по поводу манифеста. Он всегда запихивается в appx в некоем дефолтном варианте, повлиять на который невозможно.
Или все-таки возможно?
-
В ходе дальнейших экспериментов поменял CSIDL_APPDATA на CSIDL_COMMON_APPDATA, и проблема ушла. Все файлы ложатся в папку C:\ProgramData\MyApp и прекрасно видны из любого места.
Так что да, всё дело было в особом статусе папки AppData. Хотя и выглядело странно, конечно.
-
1 час назад, wamaco сказал:
Попробуйте выполнить
attrib -S -H /S /C:\...\AppData\MyApp
Будете смеяться, но эта папка не видна даже из Command Prompt. При попытке, например, вызвать cd ...MyApp выдается "The system cannot find the path specified".
А из приложения, повторюсь, всё прекрасно открывается. Да сами можете попробовать, на каком-нибудь пустом приложении. Дело нехитрое.
Возможно, это и мегафича для тех, кто хочет понадежнее всё спрятать от дураков-юзеров, а равно от хакеров. Но у меня задача прямо противоположная.
-
9 минут назад, wamaco сказал:
AppData скрытая папка же...
В том и дело, что AppData в Проводнике прекрасно открывается, и все папки, что в ней лежат, прекрасно видно - за вычетом вот этой, только что созданной AppData\MyApp.
-
При упаковке Windows-приложения в appx все дополнительные файлы приходится класть в одну папку с исполнимым файлом, ибо Deployment Manager, судя по всему, не предусматривает возможности сразу положить их в AppData. Но я все-таки хочу, чтобы некоторые файлы были легко доступны пользователям, поэтому организовал приложение так, что оно при первом запуске создает новый каталог в AppData:
MyDirectory:=GetSpecialFolderPath(CSIDL_APPDATA)+'\MyApp'; CreateDir(MyDirectory); TDirectory.SetAttributes(MyDirectory,[TFileAttribute.faNormal]);
После этого в созданный каталог переносятся некоторые файлы, и всё работает хорошо, за исключением одного момента: этот новый каталог невозможно открыть, например, в Проводнике. Из самого приложения легко можно открыть диалоговое окно и увидеть в нем этот каталог и все файлы; можно их читать и в них писать, но вне приложения этот каталог невидим. Всё равно что не существует.
Мне казалось, что присвоение каталогу атрибута faNormal дожно все проблемы решить. Увы, не решает. В чем тут закавыка?
-
Задал этот же вопрос на www.experts-exchange.com, там посоветовали определять адрес иначе:
ExtractFilePath(ParamStr(0))
Прекрасно работает.
Мне заодно напомнили банальную истину: текущий каталог - это вовсе не обязательно каталог, в котором лежит исполнимый файл. Даже в момент запуска.
-
Устанавливая и запуская свое Windows-приложение, предназначенное для Microsoft Store и запакованное в appx, наткнулся на интересный феномен. Чтобы узнать адрес текущего каталога, я всегда использовал функцию SysUtils.GetCurrentDir. Полученный полный адрес был мне нужен, например, чтобы показывать в TWebBrowser файлы хелпов (относительные адреса там почему-то не прокатывают). Раньше адресом текущего каталога всегда был адрес, где лежит исполнимый файл - условно говоря, C:\Program Files\MyApp. Теперь, когда пакет создается по принципам UWP, исполнимый файл и прочее хозяйство кладется в каталог C:\Program Files\WindowsApps\MyApp_1.0.0.0_x86__sp51hrchc9zqj. При этом функция GetCurrentDir почему-то возвращает совершенно другой адрес, а именно C:\WINDOWS\system32. Соответственно, TWebBrowser ничего не показывает.
Функция SysUtils.GetDir ведет себя так же.
Как быть?
-
Обнаружилась еще одна проблема. Если запаковывать в appx слишком много файлов (у меня было более трехсот - в основном, картинки, используемые в хелпах), то в ходе выполнения процедуры deploy вся среда виснет. Приходится закрывать через Task Manager. Хорошо еще, что я смог снизить количество файлов до двухсот без каких-либо потерь (объединил картинки в блоки), а то не знаю, как бы вышел из положения. Экспериментально установить точную границу поленился - возможно, она равна 256 файлам. Так или иначе, проблема есть, и хорошо было бы от нее в будущем избавиться.
-
24 минуты назад, wamaco сказал:
Совершенно верно!
Благодарю вас за решительный и однозначный ответ!
Последнее, что осталось уяснить: есть ли какой-нибудь способ программным образом узнать из приложения, что оно является UWP-приложением?
Можно было бы, конечно, заложиться на наличие или отсутствие в папке определенных файлов - но пользователи бывают изобретательны на всякую дурость.
-
6 минут назад, wamaco сказал:
Да
Замечательно! Но правильно ли я понимаю, что UWP-приложение, которое у меня получится, будет работать только под Windows 10, а для пользователей семерок и восьмерок придется держать отдельный дистрибутив?
-
Вообще, не могу пока понять, какому принципу должно следовать размещение файлов в приложениях UWP. Раньше я всегда хранил файлы, куда могли писать пользователи, в отдельной папке (AppData), где всегда гарантирован доступ. Теперь же в разных местах (например, здесь) читаю, что приложения UWP имеют доступ к любым файлам. Коли так, то теперь никаких отдельных папок городить и не надо, можно всё валить в одну кучу вместе с исполнимым файлом. Правильно?
-
2 часа назад, wamaco сказал:
Получилось?
Пока не понял. Один файл добавляется легко. Но хотелось бы уметь добавить целую папку со всем ее содержимым, а не расписывать каждый файл отдельно. У меня их там десятки, если не сотни.
Еще не вполне понятна графа "Remote path". Если я хочу, чтобы файл был положен в папку, где по умолчанию будут храниться данные моего приложения (типа <user>\AppData\Roaming\MyApp), то должен быть какой-то макрос для этого дела.
-
А-а-а, еще есть Project => Deployment
И там как раз можно добавлять файлы. Не замечал раньше. Попробую...
-
5 минут назад, wamaco сказал:
деплой же...
А что деплой? Если вызвать Project => Deploy ... , то молча построится пакет appx, безо всяких дополнительных вопросов.
-
В RAD Studio, начиная с Berlin, предусмотрена возможность создавать пакеты appx для загрузки приложений в Microsoft Store. К сожалению, материалов на эту тему пока немного, толковая ссылка нашлась лишь одна:
https://community.embarcadero.com/blogs/entry/appx-development-for-windows-10-store
Там толково объяснено, как создать appx для приложения из одного исполнимого файла. Я попробовал, всё получилось. Но как быть, если пакет должен содержать и другие файлы? В моем случае это файл базы данных, целая папка html-файлов для хелпов, и т.п. Где я должен их указать? Логично было бы предположить, что за это ответственен манифест (Project => Options => Application => Manifest File), который можно кастомизировать. Но сколько я ни гуглил, не смог найти ничего о структуре этого манифеста применительно к файлам. Похоже, манифест здесь все-таки ни при чем.
Раньше я всё это делал в Inno Setup. Как поступать теперь - непонятно...
-
Коллеги! Хотел бы еще раз привлечь ваше внимание к проблеме, недавнее обсуждение которой, к сожалению, заглохло. Не был бы столь настойчив, но это касается всех из нас, кто работает с Windows. Речь о дефекте платформы FMX, выражающемся в том, что щелчок по иконке в панели задач не приводит к сворачиванию приложения, как это задумано. Пользователь sargon предложил следующее решение:
WM_SYSCOMMAND: begin if wParam = SC_MINIMIZE then PlatformWin.MinimizeApp else if wParam = SC_RESTORE then PlatformWin.RestoreApp; DefWindowProc(HWND, uMsg, wParam, LPARAM); sleep(50); // у FMX какая-то беда с потоками, иногда при нажатии по иконуе приложения в TaskBar окно не сворачивается а снова активируется, sleep уменьшает количество таких глюков Winapi.Windows.SetActiveWindow(FormToHwnd(LForm)); // после разворота активирует окно - проверил в Berlin и Tokyo 10.2.2 end;
Фрагмент нужно вставить в FMX.Platform.Win в функцию function WndProc(hwnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
Я последовал этому совету, но стало только хуже: перестало работать сворачивание даже при щелчке по системной кнопке "Minimize". С щелчком по иконке тоже никаких сдвигов. Что здесь может быть не так?
-
4 часа назад, ENERGY сказал:
GlobalUseGPUCanvas := true;
Была у меня эта строчка одно время вставлена. Пришлось убрать, ибо при запусках без aero (в частности, под Windows XP) она приводила к неприемлемым искажениям текста, выводимого на TImage.Bitmap.Canvas.
-
Ха! Нет, не по-старому функционирует приложение! Добавился новый баг, еще хуже. При щелчке по системной кнопке "Свернуть" никакого сворачивания не происходит. Убрал вставленный фрагмент - всё восстановилось. Что-то в этом фрагменте точно напутано. Давайте взглянем на него еще разок:
WM_SYSCOMMAND: begin if wParam = SC_MINIMIZE then PlatformWin.MinimizeApp else if wParam = SC_RESTORE then PlatformWin.RestoreApp; DefWindowProc(HWND, uMsg, wParam, LPARAM); sleep(50); // у FMX какая-то беда с потоками, иногда при нажатии по иконуе приложения в TaskBar окно не сворачивается а снова активируется, sleep уменьшает количество таких глюков Winapi.Windows.SetActiveWindow(FormToHwnd(LForm)); // после разворота активирует окно - проверил в Berlin и Tokyo 10.2.2 end;
Что тут не так?
-
Методом вставленной синтаксической ошибки установил, что подхватывается файл, положенный мной в папку проекта. То бишь, исправленный файл, содержащий секцию WM_SYSCOMMAND: begin ... end
Файлы FMX.Platform.Win.dcu из указанных папок удалил и теперь их нигде не наблюдаю.
Приложение, однако, функционирует по-старому. Похоже, что-то не так с рекомендованной вставкой.
-
Нет, что-то не получается, всё выходит по-старому.
Есть ли способ проверить, какая редакция FMX.Platform.Win у меня подхватывается?
Обработка анимированных GIF по рецепту китайского коллеги
в Анимация
Опубликовано
Всё отлично заработало, спасибо за инструкции. Особенно радует, что можно менять скорость анимации (TGifPlayer.SetupSpeed) и ставить ее на паузу (TGifPlayer.Pause). Правда, для этого в исходном юните кое-что пришлось переместить из private в public.
У Сисун (так зовут китайского умельца, если я правильно транскрибировал Wǔ Xīsōng) заслуживает самой глубокой благодарности.