11-17-2025, 07:11 PM
Thanks @SMcNeill for this.
He published a program for saving PNG format. I use it as a source and thanks to this these two programs were created:
1) The first one - a program for saving images in animated PNG format (or APNG). It has only the basics, it does not support some things, it will be worked on. But the important thing is that with it you can create animated PNG, which then will open and play in any Internet browser.
2) _LoadImage loads static PNGs and you would only see the first frame of the animation. That's why there is also a viewer for this PNG format, perhaps it should be able to handle all of them, but if something doesn't work (very possible), write to me here, we'll take a look.
The attachments include APNG (PNG) files with animations. The ball and the text in the window are the results of the first program, the animated back image is a file downloaded from the FreeBasic forum.
There are static png files in the ZIP file, I don't know which file I extracted them from, but the program for saving as is will allow you to try to create your own animated PNG from them.
Save APNG:
Load APNG:
![[Image: APNG-Test.png]](https://i.ibb.co/VXyqnXM/APNG-Test.png)
![[Image: APNG-Test2.png]](https://i.ibb.co/5ggn5ZRS/APNG-Test2.png)
![[Image: NewAPNG.png]](https://i.ibb.co/6c9H9WXc/NewAPNG.png)
He published a program for saving PNG format. I use it as a source and thanks to this these two programs were created:
1) The first one - a program for saving images in animated PNG format (or APNG). It has only the basics, it does not support some things, it will be worked on. But the important thing is that with it you can create animated PNG, which then will open and play in any Internet browser.
2) _LoadImage loads static PNGs and you would only see the first frame of the animation. That's why there is also a viewer for this PNG format, perhaps it should be able to handle all of them, but if something doesn't work (very possible), write to me here, we'll take a look.
The attachments include APNG (PNG) files with animations. The ball and the text in the window are the results of the first program, the animated back image is a file downloaded from the FreeBasic forum.
There are static png files in the ZIP file, I don't know which file I extracted them from, but the program for saving as is will allow you to try to create your own animated PNG from them.
Save APNG:
Code: (Select All)
Const Z_OK = 0
Const Z_NO_COMPRESSION = 0
Const Z_BEST_SPEED = 1
Const Z_BEST_COMPRESSION = 9
Const Z_DEFAULT_COMPRESSION = -1
'These are used for PNG import and export, and are needed for the PNGCRC check
'If you only want ZLib for something else, these variables could be removed if necessary.
Dim Shared PNGCRC_table(0 To 255) As _Unsigned Long
Dim Shared PNGCRC_table_computed As Long: PNGCRC_table_computed = 0
Dim Shared PNGCRC As _Unsigned Long
Dim Shared PNGOptions As PNG_Options_Type
'I put the types and their info here at the end of the library, so that I wouldn't have to scroll past
'the stupid things a million times, just to get to my code!
Type ChunkType
Ancillary As _Unsigned _Byte
Private As _Unsigned _Byte
Reserved As _Unsigned _Byte
SafeToCopy As _Unsigned _Byte
End Type
Type PNGChunkLayout
Length As _Unsigned Long 'Need to convert this number with the ConvertUL~& function
Type As ChunkType
End Type
Type PNGImageHeaderType
'Can't just read width and height as _unsigned longs.
'Must convert them to QB64 format with the ConvertUL~& function.
Width As _Unsigned Long 'Need to convert this number with the ConvertUL~& function
Height As _Unsigned Long 'Need to convert this number with the ConvertUL~& function
Depth As _Unsigned _Byte
ColorType As _Unsigned _Byte
Compression As _Unsigned _Byte
Filter As _Unsigned _Byte
Interlace As _Unsigned _Byte
End Type
Type PNG_Options_Type
Alpha As _Unsigned _Byte
Screen As Long
Color As Integer
GrabMode As _Unsigned _Byte
x1 As _Unsigned Integer
y1 As _Unsigned Integer
x2 As _Unsigned Integer
y2 As _Unsigned Integer
AutoReset As _Unsigned _Byte
End Type
Dim frames(19) As Long
Dim delaynum(19) As Integer
Dim delayden(19) As Integer
For v = 0 To 19
If v < 9 Then n$ = "0" + LTrim$(Str$(v + 1)) Else n$ = LTrim$(Str$(v + 1))
im$ = "apngframe" + n$ + ".png"
frames(v) = _LoadImage(im$, 32)
delaynum(v) = 3
delayden(v) = 100
Next v
outFile$ = "APNG_Test2.png"
If _FileExists(outFile$) Then Kill outFile$
status = APNGExport2(outFile$, frames(), 20, delaynum(), delayden(), 0)
If status = -1 Then Print "File crated correctly. Open this file: "; outFile$; " in your internet browser!" Else Print "something fail!"
Sub Update_PNGCRC (PNGCRC As _Unsigned Long, buf As _MEM)
'PNGCRC is updated by reference
Dim n As _Unsigned _Offset
If 0 = PNGCRC_table_computed Then Make_PNGCRC_Table
n = 0
While n < buf.SIZE
PNGCRC = PNGCRC_table((PNGCRC Xor _MemGet(buf, buf.OFFSET + n, _Unsigned _Byte)) And &HFF) Xor PNGCRC \ 2 ^ 8
n = n + 1
Wend
End Sub
Function ConvertUL~& (x As _Unsigned Long)
ConvertUL = x \ 2 ^ 24 Or x * 2 ^ 24 Or (x And &HFF0000) \ 2 ^ 8 Or (x And &HFF00~&) * 2 ^ 8
End Function
Sub Make_PNGCRC_Table
Dim c As _Unsigned Long
Dim n As Long, k As Long
For n = 0 To 255
c = n
For k = 0 To 7
If c And 1 Then
c = &HEDB88320 Xor c \ 2
Else
c = c \ 2
End If
Next
PNGCRC_table(n) = c
Next
PNGCRC_table_computed = 1
End Sub
Sub PNGAutoReset
PNGOptions.Alpha = 0
PNGOptions.Screen = 0
PNGOptions.GrabMode = 0
PNGOptions.x1 = 0
PNGOptions.y1 = 0
PNGOptions.x2 = 0
PNGOptions.y2 = 0
End Sub
FUNCTION APNGExport2% (file$, frames() AS LONG, frameCount AS LONG, _
delayNum() AS INTEGER, delayDen() AS INTEGER, _
loopCount AS LONG)
Dim PNGImageHeader As PNGImageHeaderType
Dim PNGFileSignature As _Unsigned _Integer64
Dim f As Integer
Dim firstImg As Long
Dim width As Long, height As Long
Dim colorMode As Integer ' 256 nebo 32
Dim hasAlpha As _Byte
Dim mode As Integer ' 0 = RGB, 32 = RGBA
Dim iFrame As Long
Dim temp As String
Dim lUL As _Unsigned Long
Dim crc As _Unsigned Long
Dim oldSrc As Long
' Bez framů nemáme co dělat
If frameCount <= 0 Then
APNGExport2% = 0
Exit Function
End If
firstImg = frames(0)
' Zjisteni barevne hloubky z prvniho framu
Select Case _PixelSize(firstImg)
Case 0
APNGExport2% = 11 ' text screen, nic
Exit Function
Case 1
colorMode = 256
Case 4
colorMode = 32
Case Else
APNGExport2% = 10 ' nepodporovany rezim
Exit Function
End Select
width = _Width(firstImg)
height = _Height(firstImg)
' Detekce alfy jako v PNGExport (jen pro 32bit)
hasAlpha = 0
If colorMode = 32 Then
Dim m As _MEM
Dim o As _Offset
Dim a As _Unsigned _Byte
m = _MemImage(firstImg)
o = 0
Do While o + 3 < m.SIZE
a = _MemGet(m, m.OFFSET + o + 3, _Unsigned _Byte)
If a <> 255 Then
hasAlpha = 1
Exit Do
End If
o = o + 4
Loop
_MemFree m
End If
' Pokud soubor existuje, vrat chybu
If _FileExists(file$) Then
APNGExport2% = 1
Exit Function
End If
f = FreeFile
Open file$ For Binary As #f
oldSrc = _Source
'-------------------------------------------------
' 1) PNG signature
'-------------------------------------------------
PNGFileSignature = 727905341920923785 ' 89 50 4E 47 0D 0A 1A 0A
Put #f, , PNGFileSignature
'-------------------------------------------------
' 2) IHDR chunk
'-------------------------------------------------
lUL = ConvertUL~&(13)
Put #f, , lUL
temp$ = "IHDR"
Put #f, , temp$
PNGImageHeader.Width = ConvertUL~&(width)
PNGImageHeader.Height = ConvertUL~&(height)
PNGImageHeader.Depth = 8
' ColorType:
' 2 = RGB, 6 = RGBA, 3 = paletovy
If colorMode = 256 Then
PNGImageHeader.ColorType = 3
Else
If hasAlpha Then
PNGImageHeader.ColorType = 6
mode = 32
Else
PNGImageHeader.ColorType = 2
mode = 0
End If
End If
PNGImageHeader.Compression = 0
PNGImageHeader.Filter = 0
PNGImageHeader.Interlace = 0
Put #f, , PNGImageHeader
' CRC pro IHDR
Dim mIHDR As _MEM
Dim ihdrBytes(0 To Len(PNGImageHeader) - 1) As _Unsigned _Byte
Dim j As Long
mIHDR = _Mem(PNGImageHeader)
For j = 0 To Len(PNGImageHeader) - 1
ihdrBytes(j) = _MemGet(mIHDR, mIHDR.OFFSET + j, _Unsigned _Byte)
Next
_MemFree mIHDR
crc = PNGCRCDataCheck~&("IHDR", ihdrBytes())
lUL = ConvertUL~&(crc)
Put #f, , lUL
'-------------------------------------------------
' 3) acTL chunk (Animation Control)
'-------------------------------------------------
' acTL data: 4 bytes num_frames, 4 bytes num_plays
Dim acTLData(0 To 7) As _Unsigned _Byte
Dim v As _Unsigned Long
' num_frames
v = frameCount
acTLData(0) = (v \ 16777216) And &HFF
acTLData(1) = (v \ 65536) And &HFF
acTLData(2) = (v \ 256) And &HFF
acTLData(3) = v And &HFF
' num_plays (0 = nekonecne)
v = loopCount
acTLData(4) = (v \ 16777216) And &HFF
acTLData(5) = (v \ 65536) And &HFF
acTLData(6) = (v \ 256) And &HFF
acTLData(7) = v And &HFF
lUL = ConvertUL~&(8)
Put #f, , lUL
temp$ = "acTL"
Put #f, , temp$
Put #f, , acTLData()
crc = PNGCRCDataCheck~&("acTL", acTLData())
lUL = ConvertUL~&(crc)
Put #f, , lUL
'-------------------------------------------------
' 4) PLTE (if 256 colors)
'-------------------------------------------------
If colorMode = 256 Then
Dim pal(255 * 3 + 2) As _Unsigned _Byte
For j = 0 To 255
pal(j * 3) = _Red(j)
pal(j * 3 + 1) = _Green(j)
pal(j * 3 + 2) = _Blue(j)
Next
lUL = ConvertUL~&(255 * 3 + 3) ' (as 256 * 3)
Put #f, , lUL
temp$ = "PLTE"
Put #f, , temp$
Put #f, , pal()
crc = PNGCRCDataCheck~&("PLTE", pal())
lUL = ConvertUL~&(crc)
Put #f, , lUL
End If
'-------------------------------------------------
' 5) Frame loop: fcTL + IDAT/fdAT
'-------------------------------------------------
Dim seqNum As _Unsigned Long
seqNum = 0
' Pomocne promenne pro data jednoho framu
Dim FileSize As _Unsigned Long
Dim z As _Unsigned Long
Dim y As Long, x As Long
Dim FileBuff As _Unsigned _Byte
Dim mBuf As _MEM
Dim raw As String
Dim comp As String
Dim pix As _Unsigned Long
Dim dn As Integer, dd As Integer
Dim fcTLData(0 To 25) As _Unsigned _Byte
Dim fdATHeader(0 To 3) As _Unsigned _Byte
For iFrame = 0 To frameCount - 1
'---------------- fcTL chunk ----------------
' fcTL data: 4 seq_num, 4 w, 4 h, 4 x_off, 4 y_off,
' 2 delay_num, 2 delay_den, 1 dispose_op, 1 blend_op
' seq_num (big-endian)
v = seqNum
fcTLData(0) = (v \ 16777216) And &HFF
fcTLData(1) = (v \ 65536) And &HFF
fcTLData(2) = (v \ 256) And &HFF
fcTLData(3) = v And &HFF
' width
v = width
fcTLData(4) = (v \ 16777216) And &HFF
fcTLData(5) = (v \ 65536) And &HFF
fcTLData(6) = (v \ 256) And &HFF
fcTLData(7) = v And &HFF
' height
v = height
fcTLData(8) = (v \ 16777216) And &HFF
fcTLData(9) = (v \ 65536) And &HFF
fcTLData(10) = (v \ 256) And &HFF
fcTLData(11) = v And &HFF
' x_offset, y_offset = 0
fcTLData(12) = 0
fcTLData(13) = 0
fcTLData(14) = 0
fcTLData(15) = 0
fcTLData(16) = 0
fcTLData(17) = 0
fcTLData(18) = 0
fcTLData(19) = 0
' delay_num, delay_den
dn = delayNum(iFrame)
dd = delayDen(iFrame)
If dd = 0 Then dd = 100
fcTLData(20) = (dn \ 256) And &HFF
fcTLData(21) = dn And &HFF
fcTLData(22) = (dd \ 256) And &HFF
fcTLData(23) = dd And &HFF
' dispose_op (0 = NONE), blend_op (0 = SOURCE)
fcTLData(24) = 0
fcTLData(25) = 0
' délka fcTL: 26 bajtů
lUL = ConvertUL~&(26)
Put #f, , lUL
temp$ = "fcTL"
Put #f, , temp$
Put #f, , fcTLData()
crc = PNGCRCDataCheck~&("fcTL", fcTLData())
lUL = ConvertUL~&(crc)
Put #f, , lUL
seqNum = seqNum + 1
'---------------- Frame pixel data ----------------
' Vyrobime buffer jako v PNGExport
If colorMode = 256 Then
FileSize = height * (width + 1)
Else
If hasAlpha Then
FileSize = height * (4 * width + 1)
Else
FileSize = height * (3 * width + 1)
End If
End If
ReDim FileBuff(0 To FileSize - 1) As _Unsigned _Byte
z = 0
_Source frames(iFrame)
For y = 0 To height - 1
FileBuff(z) = 0 ' filter type 0
z = z + 1
For x = 0 To width - 1
If colorMode = 256 Then
FileBuff(z) = Point(x, y)
z = z + 1
Else
pix = Point(x, y)
FileBuff(z) = _Red32(pix)
FileBuff(z + 1) = _Green32(pix)
FileBuff(z + 2) = _Blue32(pix)
If hasAlpha Then
FileBuff(z + 3) = _Alpha32(pix)
z = z + 4
Else
z = z + 3
End If
End If
Next
Next
' Z bufru udelame string, deflate
raw$ = Space$(FileSize)
mBuf = _Mem(FileBuff())
_MemGet mBuf, mBuf.OFFSET, raw$
_MemFree mBuf
comp$ = _Deflate$(raw$)
'---------------- IDAT nebo fdAT ----------------
If iFrame = 0 Then
' prvni frame: IDAT
lUL = ConvertUL~&(Len(comp$))
Put #f, , lUL
temp$ = "IDAT"
Put #f, , temp$
Put #f, , comp$
crc = PNGCRCStringCheck~&("IDAT", comp$)
lUL = ConvertUL~&(crc)
Put #f, , lUL
Else
' dalsi framy: fdAT
' fdAT payload = 4 bytes seq_num (big-endian) + compressed data
v = seqNum
fdATHeader(0) = (v \ 16777216) And &HFF
fdATHeader(1) = (v \ 65536) And &HFF
fdATHeader(2) = (v \ 256) And &HFF
fdATHeader(3) = v And &HFF
lUL = ConvertUL~&(Len(comp$) + 4)
Put #f, , lUL
temp$ = "fdAT"
Put #f, , temp$
Put #f, , fdATHeader()
Put #f, , comp$
' CRC pres "fdAT" + 4 bajty seqNum + comp$
Dim payload As String
payload = Chr$(fdATHeader(0)) + Chr$(fdATHeader(1)) + Chr$(fdATHeader(2)) + Chr$(fdATHeader(3)) + comp$
crc = PNGCRCStringCheck~&("fdAT", payload$)
lUL = ConvertUL~&(crc)
Put #f, , lUL
seqNum = seqNum + 1
End If
Next
'-------------------------------------------------
' 6) IEND
'-------------------------------------------------
lUL = ConvertUL~&(0)
Put #f, , lUL
temp$ = "IEND"
Put #f, , temp$
crc = PNGCRCStringCheck~&("IEND", "")
lUL = ConvertUL~&(crc)
Put #f, , lUL
Close #f
_Source oldSrc
APNGExport2% = -1
End Function
Function PNGCRCStringCheck~& (id As String * 4, dta$)
Dim m As _MEM
Dim text(0 To Len(dta$) - 1) As _Unsigned _Byte
PNGCRC = -1
For z = 0 To Len(dta$) - 1: text(z) = Asc(dta$, z + 1): Next
m = _Mem(id): Update_PNGCRC PNGCRC, m: _MemFree m
m = _Mem(text()): Update_PNGCRC PNGCRC, m: _MemFree m
PNGCRCStringCheck~& = Not PNGCRC
End Function
Function PNGCRCDataCheck~& (id As String * 4, dta() As _Unsigned _Byte)
Dim m As _MEM
Dim temp(0 To 3) As _Unsigned _Byte
PNGCRC = -1
For z = 1 To 4: temp(z - 1) = Asc(id, z): Next
m = _Mem(temp()): Update_PNGCRC PNGCRC, m: _MemFree m
m = _Mem(dta()): Update_PNGCRC PNGCRC, m: _MemFree m
PNGCRCDataCheck~& = Not PNGCRC
End Function
Load APNG:
Code: (Select All)
Type APNG_FrameCtrl
seqNum As _Unsigned Long
width As Long
height As Long
xOffset As Long
yOffset As Long
delayNum As Integer
delayDen As Integer
disposeOp As _Unsigned _Byte
blendOp As _Unsigned _Byte
End Type
inFile$ = "APNG_test2.png"
ReDim frames(0) As Long
ReDim delaynum(0) As Integer
ReDim delayden(0) As Integer
Screen _NewImage(800, 600, 32)
s = APNGImport(inFile$, frames(), delaynum(), delayden(), loopcount)
If s > 0 Then
plays = 0
Do
For l = 0 To s - 1
_PutImage (0, 0), frames(l)
_Display
If delaynum(l) > 0 And delayden(l) > 0 Then
_Limit delayden(l) / delaynum(l)
Else
_Delay 0.05
End If
Cls
Next
If loopcount > 0 Then
plays = plays + 1
If plays >= loopcount Then Exit Do
End If
Loop Until _KeyHit = 27
End If
Function APNGImport& (file$, frames() As Long, delayNum() As Integer, delayDen() As Integer, loopCount As Long)
Dim f As Integer
Dim sig As _Unsigned _Integer64
Dim chunkLen As _Unsigned Long
Dim chunkType As String * 4
Dim done As _Byte
Dim ihdrRead As _Byte
Dim acTLRead As _Byte
Dim imgWidth As Long, imgHeight As Long
Dim bitDepth As _Unsigned _Byte
Dim colorType As _Unsigned _Byte
Dim compression As _Unsigned _Byte
Dim filterMethod As _Unsigned _Byte
Dim interlace As _Unsigned _Byte
Dim numFrames As Long
Dim numPlays As Long
Dim i As Long
' Buffery pro komprimovaná data frame-ů
Dim compData As String
Dim frameCtrl As APNG_FrameCtrl
Dim curFrameIndex As Long
' Paleta pro colorType=3
Dim palR(0 To 255) As _Unsigned _Byte
Dim palG(0 To 255) As _Unsigned _Byte
Dim palB(0 To 255) As _Unsigned _Byte
Dim palPresent As _Byte
Dim tmpCRC As _Unsigned Long
APNGImport& = 0
loopCount = 0
acTLRead = 0
ihdrRead = 0
If Not _FileExists(file$) Then
APNGImport& = -1
Exit Function
End If
f = FreeFile
Open file$ For Binary As #f
' PNG signatura
Get #f, , sig
If sig <> 727905341920923785## Then
Close #f
APNGImport& = -2
Exit Function
End If
done = 0
' default: PNG bez animace = 1 frame
numFrames = 1
ReDim compData(0 To 0) As String
ReDim frameCtrl(0 To 0) As APNG_FrameCtrl
ReDim frames(0 To 0) As Long
ReDim delayNum(0 To 0) As Integer
ReDim delayDen(0 To 0) As Integer
curFrameIndex = 0
Dim fcBuf(0 To 25) As _Unsigned _Byte
Dim fdHeader(0 To 3) As _Unsigned _Byte
Dim fdData As String
Do While Not done
If EOF(f) Then Exit Do
ReadChunkHeader f, chunkLen, chunkType
Select Case chunkType
Case "IHDR"
Dim ihdrRaw(0 To 12) As _Unsigned _Byte
Get #f, , ihdrRaw()
imgWidth = ihdrRaw(0) * 16777216& + ihdrRaw(1) * 65536& + ihdrRaw(2) * 256& + ihdrRaw(3)
imgHeight = ihdrRaw(4) * 16777216& + ihdrRaw(5) * 65536& + ihdrRaw(6) * 256& + ihdrRaw(7)
bitDepth = ihdrRaw(8)
colorType = ihdrRaw(9)
compression = ihdrRaw(10)
filterMethod = ihdrRaw(11)
interlace = ihdrRaw(12)
Get #f, , tmpCRC
ihdrRead = -1
' Podporujeme jen 8bit a bez interlace
If bitDepth <> 8 Then
Close #f
APNGImport& = -10
Exit Function
End If
If interlace <> 0 Then
Close #f
APNGImport& = -9
Exit Function
End If
Case "acTL"
Dim acTLBuf(0 To 7) As _Unsigned _Byte
Get #f, , acTLBuf()
Get #f, , tmpCRC
numFrames = acTLBuf(0) * 16777216& + acTLBuf(1) * 65536& + acTLBuf(2) * 256& + acTLBuf(3)
numPlays = acTLBuf(4) * 16777216& + acTLBuf(5) * 65536& + acTLBuf(6) * 256& + acTLBuf(7)
loopCount = numPlays
If numFrames <= 0 Then
Close #f
APNGImport& = -3
Exit Function
End If
ReDim compData(0 To numFrames - 1) As String
ReDim frameCtrl(0 To numFrames - 1) As APNG_FrameCtrl
ReDim frames(0 To numFrames - 1) As Long
ReDim delayNum(0 To numFrames - 1) As Integer
ReDim delayDen(0 To numFrames - 1) As Integer
curFrameIndex = -1
acTLRead = -1
Case "PLTE"
Dim palBuf As _Unsigned _Byte
ReDim palBuf(0 To chunkLen - 1) As _Unsigned _Byte
Get #f, , palBuf()
For i = 0 To 255
If i * 3 + 2 > chunkLen - 1 Then Exit For
palR(i) = palBuf(i * 3)
palG(i) = palBuf(i * 3 + 1)
palB(i) = palBuf(i * 3 + 2)
Next
palPresent = -1
Get #f, , tmpCRC
Case "fcTL"
If acTLRead = 0 Then
' není acTL -> ignorujeme jako neAPNG
If chunkLen > 0 Then Seek #f, Seek(f) + chunkLen
Get #f, , tmpCRC
Else
Get #f, , fcBuf()
Get #f, , tmpCRC
curFrameIndex = curFrameIndex + 1
If curFrameIndex < 0 Or curFrameIndex > UBound(frameCtrl) Then
Close #f
APNGImport& = -4
Exit Function
End If
frameCtrl(curFrameIndex).seqNum = BE32(fcBuf(), 0)
frameCtrl(curFrameIndex).width = BE32(fcBuf(), 4)
frameCtrl(curFrameIndex).height = BE32(fcBuf(), 8)
frameCtrl(curFrameIndex).xOffset = BE32(fcBuf(), 12)
frameCtrl(curFrameIndex).yOffset = BE32(fcBuf(), 16)
frameCtrl(curFrameIndex).delayNum = fcBuf(20) * 256 + fcBuf(21)
frameCtrl(curFrameIndex).delayDen = fcBuf(22) * 256 + fcBuf(23)
If frameCtrl(curFrameIndex).delayDen = 0 Then frameCtrl(curFrameIndex).delayDen = 100
frameCtrl(curFrameIndex).disposeOp = fcBuf(24)
frameCtrl(curFrameIndex).blendOp = fcBuf(25)
delayNum(curFrameIndex) = frameCtrl(curFrameIndex).delayNum
delayDen(curFrameIndex) = frameCtrl(curFrameIndex).delayDen
End If
Case "IDAT"
Dim idatData As String
idatData = String$(chunkLen, Chr$(0))
Get #f, , idatData
Get #f, , tmpCRC
If curFrameIndex < 0 Then
curFrameIndex = 0
End If
compData(curFrameIndex) = compData(curFrameIndex) + idatData
Case "fdAT"
If acTLRead = 0 Then
' ne-APNG: ignorovat
If chunkLen > 0 Then Seek #f, Seek(f) + chunkLen
Get #f, , tmpCRC
Else
Get #f, , fdHeader()
fdData = String$(chunkLen - 4, Chr$(0))
Get #f, , fdData
Get #f, , tmpCRC
If curFrameIndex < 0 Then
Close #f
APNGImport& = -5
Exit Function
End If
compData(curFrameIndex) = compData(curFrameIndex) + fdData
End If
Case "IEND"
Get #f, , tmpCRC
done = -1
Case Else
If chunkLen > 0 Then Seek #f, Seek(f) + chunkLen
Get #f, , tmpCRC
End Select
Loop
Close #f
' Pokud není acTL, je to obyč PNG
If acTLRead = 0 Then
numFrames = 1
frameCtrl(0).width = imgWidth
frameCtrl(0).height = imgHeight
frameCtrl(0).xOffset = 0
frameCtrl(0).yOffset = 0
delayNum(0) = 0
delayDen(0) = 0
End If
' ------------------------------
' Dekompres + filtry + vykreslení do _MemImage
' ------------------------------
Dim bytesPerPixel As Integer
Dim frameW As Long, frameH As Long
Select Case colorType
Case 0 ' grayscale
bytesPerPixel = 1
Case 2 ' RGB
bytesPerPixel = 3
Case 3 ' paleta
bytesPerPixel = 1
Case 4 ' gray+alpha
bytesPerPixel = 2
Case 6 ' RGBA
bytesPerPixel = 4
Case Else
APNGImport& = -6
Exit Function
End Select
Dim cmp As String, raw As String
For i = 0 To numFrames - 1
frameW = frameCtrl(i).width
frameH = frameCtrl(i).height
If frameW = 0 Then frameW = imgWidth
If frameH = 0 Then frameH = imgHeight
cmp$ = compData(i)
If Len(cmp$) = 0 Then
APNGImport& = -7
Exit Function
End If
raw$ = _Inflate$(cmp$)
Dim rowLen As Long
rowLen = frameW * bytesPerPixel
Dim rowF As _Unsigned _Byte
Dim rowU As _Unsigned _Byte
Dim prevRow As _Unsigned _Byte
ReDim rowF(0 To rowLen - 1) As _Unsigned _Byte
ReDim rowU(0 To rowLen - 1) As _Unsigned _Byte
ReDim prevRow(0 To rowLen - 1) As _Unsigned _Byte
Dim idx As Long
idx = 0
frames(i) = _NewImage(imgWidth, imgHeight, 32)
Dim m As _MEM
m = _MemImage(frames(i))
Dim row As Long, col As Long
Dim r As Integer, g As Integer, b As Integer, a As Integer
Dim pIndex As Integer
Dim fType As Integer
Dim j As Long
Dim pix As _Unsigned Long
Dim dstOffset As _Unsigned Long
For row = 0 To frameH - 1
If idx >= Len(raw$) Then Exit For
fType = Asc(raw$, idx + 1)
idx = idx + 1
' načíst filtrovaná data
For j = 0 To rowLen - 1
If idx < Len(raw$) Then
rowF(j) = Asc(raw$, idx + 1)
Else
rowF(j) = 0
End If
idx = idx + 1
Next
' aplikace filtru
Dim aB As Long, bB As Long, cB As Long
Dim p As Long, pa As Long, pb As Long, pc As Long
Dim pr As Long
Select Case fType
Case 0 ' None
For j = 0 To rowLen - 1
rowU(j) = rowF(j)
Next
Case 1 ' Sub
For j = 0 To rowLen - 1
If j >= bytesPerPixel Then
aB = rowU(j - bytesPerPixel)
Else
aB = 0
End If
rowU(j) = (rowF(j) + aB) And &HFF
Next
Case 2 ' Up
For j = 0 To rowLen - 1
rowU(j) = (rowF(j) + prevRow(j)) And &HFF
Next
Case 3 ' Average
For j = 0 To rowLen - 1
If j >= bytesPerPixel Then
aB = rowU(j - bytesPerPixel)
Else
aB = 0
End If
bB = prevRow(j)
rowU(j) = (rowF(j) + ((aB + bB) \ 2)) And &HFF
Next
Case 4 ' Paeth
For j = 0 To rowLen - 1
If j >= bytesPerPixel Then
aB = rowU(j - bytesPerPixel)
cB = prevRow(j - bytesPerPixel)
Else
aB = 0
cB = 0
End If
bB = prevRow(j)
p = aB + bB - cB
pa = Abs(p - aB)
pb = Abs(p - bB)
pc = Abs(p - cB)
If pa <= pb And pa <= pc Then
pr = aB
ElseIf pb <= pc Then
pr = bB
Else
pr = cB
End If
rowU(j) = (rowF(j) + pr) And &HFF
Next
Case Else
For j = 0 To rowLen - 1
rowU(j) = rowF(j)
Next
End Select
' uložit pro další řádek
For j = 0 To rowLen - 1
prevRow(j) = rowU(j)
Next
' rozparsovat pixely z rowU a zapsat do canvasu s offsetem
Dim k As Long
k = 0
For col = 0 To frameW - 1
Select Case colorType
Case 0 ' grayscale
g = rowU(k)
r = g: b = g: a = 255
k = k + 1
Case 2 ' RGB
r = rowU(k)
g = rowU(k + 1)
b = rowU(k + 2)
a = 255
k = k + 3
Case 3 ' palette
pIndex = rowU(k)
k = k + 1
r = palR(pIndex)
g = palG(pIndex)
b = palB(pIndex)
a = 255
Case 4 ' gray+alpha
g = rowU(k)
a = rowU(k + 1)
r = g: b = g
k = k + 2
Case 6 ' RGBA
r = rowU(k)
g = rowU(k + 1)
b = rowU(k + 2)
a = rowU(k + 3)
k = k + 4
End Select
Dim dstX As Long, dstY As Long
dstX = frameCtrl(i).xOffset + col
dstY = frameCtrl(i).yOffset + row
If dstX >= 0 And dstX < imgWidth And dstY >= 0 And dstY < imgHeight Then
dstOffset = (dstY * imgWidth + dstX) * 4
pix = _RGBA32(r, g, b, a)
_MemPut m, m.OFFSET + dstOffset, pix
End If
Next col
Next row
_MemFree m
Next i
_Dest 0
APNGImport& = numFrames
End Function
Function BE32~& (b() As _Unsigned _Byte, start As Long)
BE32 = b(start) * 16777216~& + b(start + 1) * 65536~& + b(start + 2) * 256~& + b(start + 3)
End Function
Function ConvertUL~& (x As _Unsigned Long)
ConvertUL = x \ 2 ^ 24 Or x * 2 ^ 24 Or (x And &HFF0000) \ 2 ^ 8 Or (x And &HFF00~&) * 2 ^ 8
End Function
Sub ReadChunkHeader (f As Integer, lengthUL As _Unsigned Long, cType As String * 4)
Dim l As _Unsigned Long
Get #f, , l
lengthUL = ConvertUL~&(l)
Get #f, , cType
End Sub
![[Image: x16-01.png]](https://i.ibb.co/KcsL0mKJ/x16-01.png)
![[Image: x16-02.png]](https://i.ibb.co/FL1Xs1F6/x16-02.png)
... I'm going to have an update soon. It's actually mostly done but I'm waiting for the next Commander X16 ROM update as some of the new stuff is slated to upcoming ROM features on the X16.