UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 140
Wohnort: Opel Stadt
|
 Verfasst am: 31.07.2025, 20:10 Titel: Animierte PNG Frames extrahieren 2025-07-31 beta [Windows] |
 |
|
| Code: |
'Coded by UEZ in cooperation with ChatGPT ;-) build 2025-07-31 beta
#include "crt.bi"
#include "file.bi"
#ifdef __FB_64BIT__
#inclib "gdiplus"
#include once "win/gdiplus-c.bi"
#else
#include once "win/gdiplus.bi"
Using Gdiplus
#endif
#include "dir.bi"
#define CRLF (Chr(13, 10))
' Initialize GDI+
Dim Shared gdipToken As ULONG_PTR
Dim Shared GDIp As GdiplusStartupInput
GDIp.GdiplusVersion = 1
If GdiplusStartup(@gdipToken, @GDIp, NULL) <> 0 Then End
' Save a GDI+ image to a file using appropriate encoder
Function _GDIPlus_ImageSaveToFile(hImage As Any Ptr, Filename As WString, JPGQual As ULong = 85) As Boolean '...'
Dim As Single iW, iH
If GdipGetImageDimension(hImage, @iW, @iH) <> 0 Then Return 0
Dim As Byte iErr = 0
Dim As ULong count, size
GdipGetImageEncodersSize(@count, @size)
Dim As CLSID clsid
Dim As ImageCodecInfo Ptr pImageCodecInfo
pImageCodecInfo = Allocate(size)
GdipGetImageEncoders(count, size, pImageCodecInfo)
#define _MimeType(x) (*Cast(WString Ptr, pImageCodecInfo[x].MimeType))
#define FnSuffix (Right(Filename, 4))
For i As ULong = 0 To count - 1
' Select correct encoder based on file extension
If _MimeType(i) = "image/bmp" And FnSuffix = ".bmp" Then
If GdipSaveImageToFile(hImage, WStr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0 Then iErr += 1
ElseIf _MimeType(i) = "image/jpeg" And (FnSuffix = ".jpg" Or FnSuffix = ".jpe" Or Right(Filename, 5) = ".jpeg" Or Right(Filename, 5) = ".jfif") Then
' Handle JPEG with quality
JPGQual = IIf(JPGQual < 0, 0, IIf(JPGQual > 100, 100, JPGQual))
Dim tParams As EncoderParameters
Dim EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
tParams.Count = 1
CLSIDFromString(WStr(EncoderQuality), @tParams.Parameter(0).Guid)
With tParams.Parameter(0)
.NumberOfValues = 1
.Type = EncoderParameterValueTypeLong
.Value = VarPtr(JPGQual)
End With
If GdipSaveImageToFile(hImage, WStr(Filename), @pImageCodecInfo[i].Clsid, @tParams) <> 0 Then iErr += 1
ElseIf _MimeType(i) = "image/gif" And FnSuffix = ".gif" Then
If GdipSaveImageToFile(hImage, WStr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0 Then iErr += 1
ElseIf _MimeType(i) = "image/tiff" And (FnSuffix = ".tif" Or Right(Filename, 5) = ".tiff") Then
If GdipSaveImageToFile(hImage, WStr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0 Then iErr += 1
ElseIf _MimeType(i) = "image/png" And FnSuffix = ".png" Then
If GdipSaveImageToFile(hImage, WStr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0 Then iErr += 1
End If
Next
Deallocate(pImageCodecInfo)
If iErr > 0 Then Return False
Return True
End Function
Function _GDIPlus_BitmapCreateFromMemory3(aBinImage As UByte Ptr, iLen As ULong, bBitmap_GDI As BOOL = False, iCol_GDI As ULong = &hFF000000) As Any Ptr '...'
Dim As HGLOBAL hGlobal
Dim As LPSTREAM hStream
Dim As Any Ptr hImage_Stream
Dim As Any Ptr hMemory = GlobalAlloc(GMEM_MOVEABLE, iLen)
Dim As Any Ptr lpMemory = GlobalLock(hMemory)
RtlCopyMemory(lpMemory, @aBinImage[0], iLen)
GlobalUnlock(hMemory)
CreateStreamOnHGlobal(hMemory, False, @hStream)
GdipCreateBitmapFromStream(hStream, @hImage_Stream)
IUnknown_Release(hStream)
GlobalFree(hMemory)
If bBitmap_GDI = True Then
Dim hImage_GDI As Any Ptr
GdipCreateHBITMAPFromBitmap(hImage_Stream, @hImage_GDI, iCol_GDI)
GdipDisposeImage(hImage_Stream)
Return hImage_GDI
EndIf
Return hImage_Stream
End Function
'------------------------------------------------------------------------------
' CRC32 support: initialize table and calculate CRC over a byte stream
'------------------------------------------------------------------------------
Dim Shared As UInteger CRC_TABLE(0 To 255)
Dim Shared As Boolean CRC_TABLE_INITIALIZED = False
'----------------------------------------------------
' Initializes the CRC32 lookup table (only once)
' This speeds up CRC32 calculation by avoiding repeated bitwise computation
'----------------------------------------------------
Sub InitCRCTable() '...'
' Skip initialization if already done
If CRC_TABLE_INITIALIZED Then Exit Sub
' The CRC32 polynomial used in many implementations (standard)
Dim As UInteger poly = &hEDB88320
Dim As UInteger i, j, c
' Fill the table with 256 precomputed CRC values for all byte values (0–255)
For i = 0 To 255
c = i
For j = 0 To 7
' Shift bitwise and apply polynomial if needed
If (c And 1) Then
c = (c Shr 1) Xor poly
Else
c Shr= 1
End If
Next
' Store the result in the lookup table
CRC_TABLE(i) = c
Next
' Mark table as initialized
CRC_TABLE_INITIALIZED = True
End Sub
'----------------------------------------------------
' Calculates the CRC32 checksum over a byte stream
'----------------------------------------------------
Function CRC32(initial As UInteger, bufPtr As Any Ptr, length As UInteger) As UInteger '...'
' Ensure the CRC lookup table is initialized (only done once)
InitCRCTable()
' Cast the generic pointer to a byte pointer for array-style access
Dim As UByte Ptr b = bufPtr
' Initialize CRC value by XORing with 0xFFFFFFFF
Dim As UInteger c = initial Xor &hFFFFFFFF
' Process each byte in the buffer
For i As UInteger = 0 To length - 1
' Update CRC using lookup table and shift
c = CRC_TABLE((c Xor b[i]) And &hFF) Xor (c Shr 8)
Next
' Final XOR to get the resulting CRC value
Return c Xor &hFFFFFFFF
End Function
' Reads a big-endian 32-bit unsigned integer from file
Function ReadUInt32BE(ByRef hFile As Long) As UInteger '...'
Dim b(3) As UByte
Get #hFile, , b()
Return (b(0) Shl 24) Or (b(1) Shl 16) Or (b(2) Shl 8) Or b(3)
End Function
'--------------------------------------------
' Appends bytes from src() to dest()
'--------------------------------------------
Sub AppendBytes(dest() As UByte, src() As UByte) '...'
Dim oldLen As Integer
If UBound(dest) >= 0 Then
oldLen = UBound(dest) + 1
Else
oldLen = 0
End If
ReDim Preserve dest(oldLen + UBound(src))
For i As UInteger = 0 To UBound(src)
dest(oldLen + i) = src(i)
Next
End Sub
'--------------------------------------------
' Creates a full PNG chunk (length, type, data, CRC)
' Returns as Byte() to append to PNG
'--------------------------------------------
Sub GetChunkBytes(name_ As String, chunk() As UByte, result() As UByte)
Dim length As UInteger = UBound(chunk) - LBound(chunk) + 1
' Length (4 bytes, big-endian)
ReDim result(3)
result(0) = (length Shr 24) And &hFF
result(1) = (length Shr 16) And &hFF
result(2) = (length Shr 8) And &hFF
result(3) = (length ) And &hFF
' Chunk type (4 bytes)
Dim typeBytes(3) As UByte
For i As UByte = 0 To 3
typeBytes(i) = Asc(Mid(name_, i + 1, 1))
Next
AppendBytes(result(), typeBytes())
' Chunk data
If length > 0 Then AppendBytes(result(), chunk())
' CRC
Dim crcVal As UInteger = 0
crcVal = CRC32(crcVal, VarPtr(typeBytes(0)), 4)
If length > 0 Then crcVal = CRC32(crcVal, VarPtr(chunk(0)), length)
Dim crcBytes(3) As UByte
crcBytes(0) = (crcVal Shr 24) And &hFF
crcBytes(1) = (crcVal Shr 16) And &hFF
crcBytes(2) = (crcVal Shr 8) And &hFF
crcBytes(3) = (crcVal ) And &hFF
AppendBytes(result(), crcBytes())
End Sub
'----------------------------------------------------
' Writes a single PNG frame to memory: IHDR, IDAT, IEND
' Optionally recodes the image using GDI+ to fix offsets
'----------------------------------------------------
Sub WritePNGFrame_Memory(idx As Integer, ihdr() As UByte, idat() As UByte, delayMS As Integer, padLen As Integer, _
bRecodePNG As BOOL = False, fixedWidth As ULong = 0, fixedHeight As ULong = 0, x_offset As Long = 0, y_offset As Long = 0, _
sExtractedPath As String = ExePath & "\ExtractedFrames")
' Filename
Dim numStr As String = Right("000" & LTrim(Str(idx + 1)), padLen)
Dim filename As String = IIf(sExtractedPath <> "", sExtractedPath & "\Frame_" & numStr & "_" & delayMS & "ms.png", CurDir & "\Frame_" & numStr & "_" & delayMS & "ms.png")
' 1) PNG header
Dim sig(7) As UByte = { &h89, &h50, &h4E, &h47, &hD, &hA, &h1A, &hA }
Dim fullPNG() As UByte
' ReDim it to the size of the PNG signature and copy the signature bytes
ReDim fullPNG(7)
For i As Integer = 0 To 7
fullPNG(i) = sig(i)
Next
' 2) IHDR
Dim chunkIHDR() As UByte
GetChunkBytes("IHDR", ihdr(), chunkIHDR())
AppendBytes(fullPNG(), chunkIHDR())
' 3) IDAT
Dim chunkIDAT() As UByte
GetChunkBytes("IDAT", idat(), chunkIDAT())
AppendBytes(fullPNG(), chunkIDAT())
' 4) IEND
Dim emptyBuf(0) As UByte
Dim chunkIEND() As UByte
GetChunkBytes("IEND", emptyBuf(), chunkIEND())
AppendBytes(fullPNG(), chunkIEND())
' Optional recoding using memory (no temp file)
If bRecodePNG Then
' Load PNG directly from memory
Dim hStreamImage As Any Ptr
hStreamImage = _GDIPlus_BitmapCreateFromMemory3(@fullPNG(0), UBound(fullPNG) + 1)
If hStreamImage = 0 Then
printf("Error: failed to create image from memory!" & CRLF)
Exit Sub
End If
' Prepare canvas
Dim As Any Ptr hCanvas, hBitmap
Dim As Single iw, ih
GdipCreateBitmapFromScan0(fixedWidth, fixedHeight, 0, PixelFormat32bppARGB, 0, @hBitmap)
GdipGetImageGraphicsContext(hBitmap, @hCanvas)
GdipGetImageDimension(hStreamImage, @iw, @ih)
GdipDrawImageRect(hCanvas, hStreamImage, x_offset, y_offset, iw, ih)
' Save corrected PNG
If _GDIPlus_ImageSaveToFile(hBitmap, filename) = False Then
printf("Error: saving recoded PNG failed!" & CRLF)
End If
' Cleanup
GdipDisposeImage(hStreamImage)
GdipDeleteGraphics(hCanvas)
GdipDisposeImage(hBitmap)
Else
' Save directly without recoding
Dim hOut As Long = FreeFile()
Open filename For Binary As #hOut
Put #hOut, , fullPNG()
Close #hOut
End If
End Sub
Function ExtractAPNG(ByVal path As String, sExtractedPath As String = ExePath & "\ExtractedFrames", iDefaultDelay As UShort = 50) As Integer
' Check if the file exists
If FileExists(path) = 0 Then
printf("File not found: " & path & CRLF)
Return -1
End If
' --- Phase 1: Count fcTL chunks (animation frame control chunks) ---
Dim As Long iFileAPNG = FreeFile()
Open path For Binary As #iFileAPNG
Dim sig(7) As UByte : Get #iFileAPNG, , sig()
Dim As Long total = 0
Dim As UInteger iLen
Dim As String t
Do Until EOF(iFileAPNG)
' Read the length and type of the next chunk
iLen = ReadUInt32BE(iFileAPNG)
Dim tbuf(3) As UByte : Get #iFileAPNG, , tbuf()
t = Chr(tbuf(0), tbuf(1), tbuf(2), tbuf(3))
If t = "fcTL" Then total += 1
' Skip the chunk data and CRC
Seek #iFileAPNG, Seek(iFileAPNG) + iLen + 4
Loop
Close #iFileAPNG
' If less than 2 frames, it's not an animated PNG
If total < 2 Then
printf("No animation chunks found." & CRLF)
Return -2
End If
Dim As Integer AttrTester
If sExtractedPath <> "" AndAlso Dir(sExtractedPath, (fbReadOnly Or fbHidden Or fbSystem Or fbDirectory Or fbArchive), AttrTester) = "" Then
If MkDir(sExtractedPath) = -1 Then
printf("Unable to create " & sExtractedPath & CRLF)
Return -3
End If
End If
Dim As Long padLen = Len(Str(total)) ' Determine zero-padding length for filenames
' --- Phase 2: Parse and extract individual frames ---
iFileAPNG = FreeFile()
Open path For Binary As #iFileAPNG
' Skip the 8-byte PNG signature
Dim sig2(7) As UByte
Get #iFileAPNG, , sig2()
Dim As Boolean gotFirstFrameProcessed = False
Dim As Integer frameIdx = 0, curDelay = 50, bufLen
Dim As UByte bufAll(), ihdr(), temp()
Dim As Long w = 0, h = 0, i, num, den, skip, pLen
Dim As ULong fixedWidth, fixedHeight, current_x_offset, current_y_offset
Do Until EOF(iFileAPNG)
' Read chunk length and type
iLen = ReadUInt32BE(iFileAPNG)
If iLen > LOF(iFileAPNG) - Seek(iFileAPNG) Then
printf("Invalid chunk size at position " & Seek(iFileAPNG) & CRLF)
Close #iFileAPNG
Return -4
End If
Dim tbuf(3) As UByte
Get #iFileAPNG, , tbuf()
t = Chr(tbuf(0), tbuf(1), tbuf(2), tbuf(3))
Select Case t
Case "IHDR"
' Read IHDR chunk (image header)
ReDim ihdr(iLen - 1)
Get #iFileAPNG, , ihdr()
Seek #iFileAPNG, Seek(iFileAPNG) + 4 ' Skip CRC
Case "fcTL"
If iLen <> 26 Then
printf("Invalid fcTL chunk size." & CRLF)
Close #iFileAPNG
Return -4
End If
' If a previous frame exists, write it to a PNG file
If gotFirstFrameProcessed And bufLen > 0 Then
ReDim temp(bufLen - 1)
For i = 0 To bufLen - 1
temp(i) = bufAll(i)
Next
If w <> fixedWidth Or h <> fixedHeight Then
WritePNGFrame_Memory(frameIdx, ihdr(), temp(), curDelay, padLen, True, fixedWidth, fixedHeight, current_x_offset, current_y_offset)
Else
WritePNGFrame_Memory(frameIdx, ihdr(), temp(), curDelay, padLen)
End If
frameIdx += 1
End If
' Read frame control chunk (fcTL) - 26 bytes
Dim ctl(25) As UByte
Get #iFileAPNG, , ctl()
Seek #iFileAPNG, Seek(iFileAPNG) + 4 ' Skip CRC
' Parse frame width, height, and offset
w = (ctl(4) Shl 24) Or (ctl(5) Shl 16) Or (ctl(6) Shl 8) Or ctl(7)
h = (ctl(8) Shl 24) Or (ctl(9) Shl 16) Or (ctl(10) Shl 8) Or ctl(11)
current_x_offset = (ctl(12) Shl 24) Or (ctl(13) Shl 16) Or (ctl(14) Shl 8) Or ctl(15)
current_y_offset = (ctl(16) Shl 24) Or (ctl(17) Shl 16) Or (ctl(18) Shl 8) Or ctl(19)
If Not gotFirstFrameProcessed Then
gotFirstFrameProcessed = True
fixedWidth = w
fixedHeight = h
End If
' Update IHDR width and height
ihdr(0) = (w Shr 24) And &HFF
ihdr(1) = (w Shr 16) And &HFF
ihdr(2) = (w Shr 8) And &HFF
ihdr(3) = w And &HFF
ihdr(4) = (h Shr 24) And &HFF
ihdr(5) = (h Shr 16) And &HFF
ihdr(6) = (h Shr 8) And &HFF
ihdr(7) = h And &HFF
' Read delay numerator and denominator
num = (ctl(20) Shl 8) Or ctl(21)
den = (ctl(22) Shl 8) Or ctl(23)
If den = 0 Then den = iDefaultDelay ' Default denominator
curDelay = (num * 1000) \ den ' Convert to milliseconds
bufLen = 0 ' Reset image data buffer
Case "IDAT", "fdAT"
' Collect image data for this frame (either IDAT or fdAT)
Dim tmp(iLen - 1) As UByte
Get #iFileAPNG, , tmp()
skip = IIf(t = "fdAT", 4, 0) ' Skip sequence number for fdAT
pLen = iLen - skip
If bufLen = 0 Then
ReDim bufAll(pLen - 1)
Else
ReDim Preserve bufAll(bufLen + pLen - 1)
End If
For i = 0 To pLen - 1
bufAll(bufLen + i) = tmp(i + skip)
Next
bufLen += pLen
Seek #iFileAPNG, Seek(iFileAPNG) + 4 ' Skip CRC
Case "IEND"
' Finalize and write the last frame
If bufLen > 0 Then
Dim t2(bufLen - 1) As UByte
For i = 0 To bufLen - 1
t2(i) = bufAll(i)
Next
If w <> fixedWidth Or h <> fixedHeight Then
WritePNGFrame_Memory(frameIdx, ihdr(), t2(), curDelay, padLen, True, fixedWidth, fixedHeight, current_x_offset, current_y_offset)
Else
WritePNGFrame_Memory(frameIdx, ihdr(), t2(), curDelay, padLen)
End If
frameIdx += 1
End If
Exit Do
Case Else
' Skip unknown chunks
Seek #iFileAPNG, Seek(iFileAPNG) + iLen + 4
End Select
Loop
Close #iFileAPNG
Return frameIdx
End Function
Declare Function URLDownloadToFile2 Lib "urlmon" Alias "URLDownloadToFileA" ( _
ByVal pCaller As Any Ptr, _
ByVal szURL As ZString Ptr, _
ByVal szFileName As ZString Ptr, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Any Ptr _
) As Long
' ---------- MAIN ----------
'Download example file from internet and extract frames
Dim As String localFile
If Len(Command(1)) Then
localFile = Command(1)
Else
localFile = ExePath & "\Animated_PNG_example_bouncing_beach_ball.png"
If FileExists(localFile) = 0 Then
Dim As String url = "https://upload.wikimedia.org/wikipedia/commons/1/14/Animated_PNG_example_bouncing_beach_ball.png"
URLDownloadToFile2(NULL, StrPtr(url), StrPtr(localFile), 0, NULL)
End If
End If
If FileExists(localFile) = 0 Then
printf(localFile & " not found!" & CRLF)
Sleep
End 0
End If
Dim As ULong iFrameCount = ExtractAPNG(localFile)
If iFrameCount > 1 Then
printf("Done: " & iFrameCount & " frames extracted from > " & localFile & " <." & CRLF)
Else
printf("Something went wrong extracting frames from > " & localFile & " <!" & CRLF)
End If
GdiplusShutdown(gdipToken)
Sleep
|
Eine Test APNG Animation wird heruntergeladen und die Frames extrahiert.
_________________
Gruß,
UEZ |
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
