02-17-2026, 04:09 PM
225MP? You're out of your mind. My code can squeeze that into a tiny PNG, but it'll take a solid minute. A DLL would be way faster, but I haven't gotten around to that yet. Why the monstrous image size?
or this faster (but 15000x15000 duration is 21 sec); 142KB
Code: (Select All)
' PNGExportAuto.bas lossless PNG export with automatic selection
' Smallest file size (reasonable): grayscale (1/2/4/8), indexed (1/2/4/8),
' otherwise RGB(24) / RGBA(32).
'
'
' Return codes:
' -1 OK
' 1 file exists
' 10 unsupported pixel mode
' 11 text screen
Option _Explicit
Const Z_OK = 0
' --- CRC table ---
Dim Shared PNGCRC_table(0 To 255) As _Unsigned Long
Dim Shared PNGCRC_table_computed As Long
Dim image As Long, t As Single
' create image here
image = _NewImage(15000, 15000, 256)
_Dest image
Cls , 199
Line (0, 0)-(6390, 4790), 15, BF
Circle (3200, 2400), 150, 4
Circle (3200, 12400), 100, 2
Print "Test PNG export (auto minimal)"
_Dest 0
Dim imgHandle As Long
imgHandle = image ' (0 = actual screen, can be used your image handle)
Dim res As Integer
t = Timer
res = PNGExportAuto%("test_output.png", imgHandle) 'save screen content to file test_output.png
Print "saved in: "; Timer - t
Select Case res
Case -1: Print "PNG saved OK!"
Case 1: Print "Error: file already exist."
Case 10: Print "Error: unsupported pixel mode."
Case 11: Print "Error: text screen."
Case Else: Print "Chyba: "; res
End Select
Sleep
System
' PNGExportAuto%
' Automatically detects the best lossless mode (min size).
Function PNGExportAuto% (file$, img As Long)
Dim pixSize As Integer
Dim w As Long, h As Long
Dim oldSrc As Long
Dim x As Long, y As Long
Dim idx As _Unsigned _Byte
Dim pix As _Unsigned Long
Dim rgba As _Unsigned Long
Dim r As _Unsigned _Byte, g As _Unsigned _Byte, b As _Unsigned _Byte, a As _Unsigned _Byte
Dim hasAlpha As _Byte
Dim isGray As _Byte
Dim palettePossible As _Byte
Dim colorCount As Long
Dim palDepth As Integer
Dim grayDepth As Integer
Dim imgUse As Long
Dim temp32 As Long
Dim freeTemp As _Byte
' hash for palette (max 256 values)
Const HASH_SIZE = 4096
Dim hashKey(0 To HASH_SIZE - 1) As _Unsigned Long
Dim hashVal(0 To HASH_SIZE - 1) As Integer
Dim hashUsed(0 To HASH_SIZE - 1) As _Byte
Dim mask As Long
Dim hpos As Long
Dim probe As Long
Dim found As _Byte
Dim newIndex As Integer
Dim colors(0 To 255) As _Unsigned Long
Dim alphas(0 To 255) As _Unsigned _Byte
Dim pixIndex As _Unsigned _Byte
Dim grayVal As _Unsigned _Byte
Dim p As Long
If _FileExists(file$) Then PNGExportAuto% = 1: Exit Function
pixSize = _PixelSize(img)
If pixSize = 0 Then PNGExportAuto% = 11: Exit Function
imgUse = img
freeTemp = 0
' Support for 2BPP images: flip to 32bit and continue (lossless for export)
If pixSize = 2 Then
temp32 = _CopyImage(img, 32)
If temp32 <= -2 Then
imgUse = temp32
freeTemp = -1
pixSize = _PixelSize(imgUse)
Else
PNGExportAuto% = 10
Exit Function
End If
End If
If pixSize <> 1 And pixSize <> 4 Then
If freeTemp Then _FreeImage imgUse
PNGExportAuto% = 10
Exit Function
End If
w = _Width(imgUse)
h = _Height(imgUse)
ReDim pixIndex(0) As _Unsigned _Byte
ReDim grayVal(0) As _Unsigned _Byte
ReDim pixIndex(0 To w * h - 1) As _Unsigned _Byte
ReDim grayVal(0 To w * h - 1) As _Unsigned _Byte
hasAlpha = 0
isGray = -1
palettePossible = -1
colorCount = 0
mask = HASH_SIZE - 1
oldSrc = _Source
_Source imgUse
p = 0
For y = 0 To h - 1
For x = 0 To w - 1
If pixSize = 1 Then
idx = Point(x, y)
rgba = _PaletteColor(idx, imgUse)
a = 255
Else
rgba = Point(x, y)
a = _Alpha32(rgba)
If a <> 255 Then hasAlpha = -1
End If
r = _Red32(rgba)
g = _Green32(rgba)
b = _Blue32(rgba)
grayVal(p) = r
If r <> g Or r <> b Then isGray = 0
If palettePossible Then
' vlož / najdi RGBA v hash tabulce
hpos = (rgba * 2654435761~&) And mask
probe = 0
found = 0
Do While hashUsed(hpos)
If hashKey(hpos) = rgba Then
found = -1
Exit Do
End If
hpos = (hpos + 1) And mask
probe = probe + 1
If probe >= HASH_SIZE Then Exit Do
Loop
If found Then
newIndex = hashVal(hpos)
pixIndex(p) = newIndex
Else
If colorCount >= 256 Then
palettePossible = 0
Else
hashUsed(hpos) = -1
hashKey(hpos) = rgba
hashVal(hpos) = colorCount
colors(colorCount) = rgba
alphas(colorCount) = a
pixIndex(p) = colorCount
colorCount = colorCount + 1
End If
End If
End If
p = p + 1
Next x
Next y
_Source oldSrc
' --- Volba nejmenšího bezeztrátového režimu ---
If hasAlpha = 0 Then
If isGray Then
grayDepth = PNGChooseGrayDepth%(colors(), colorCount)
PNGExportAuto% = PNGSaveGray%(file$, w, h, grayDepth, grayVal())
ElseIf palettePossible Then
palDepth = PNGChoosePalDepth%(colorCount)
PNGExportAuto% = PNGSaveIndexed%(file$, w, h, palDepth, colors(), alphas(), colorCount, pixIndex())
Else
PNGExportAuto% = PNGSaveDirect%(file$, imgUse, w, h, 2) ' RGB
End If
Else
If palettePossible Then
palDepth = PNGChoosePalDepth%(colorCount)
PNGExportAuto% = PNGSaveIndexed%(file$, w, h, palDepth, colors(), alphas(), colorCount, pixIndex())
ElseIf isGray Then
PNGExportAuto% = PNGSaveDirect%(file$, imgUse, w, h, 4) ' Gray+Alpha
Else
PNGExportAuto% = PNGSaveDirect%(file$, imgUse, w, h, 6) ' RGBA
End If
End If
If freeTemp Then _FreeImage imgUse
End Function
' PNGChoosePalDepth% (indexed): 1/2/4/8 podle počtu barev
Function PNGChoosePalDepth% (colorCount As Long)
If colorCount <= 2 Then
PNGChoosePalDepth% = 1
ElseIf colorCount <= 4 Then
PNGChoosePalDepth% = 2
ElseIf colorCount <= 16 Then
PNGChoosePalDepth% = 4
Else
PNGChoosePalDepth% = 8
End If
End Function
' PNGChooseGrayDepth% (grayscale, bez alfy): 1/2/4/8 pokud hodnoty sedí přesně
Function PNGChooseGrayDepth% (colors() As _Unsigned Long, colorCount As Long)
Dim i As Long
Dim v As Long
' Pokud jsme paletu vůbec nedělali (colorCount=0), jdeme na 8.
If colorCount <= 0 Then PNGChooseGrayDepth% = 8: Exit Function
' depth 1: jen 0 a 255
For i = 0 To colorCount - 1
v = _Red32(colors(i))
If v <> 0 And v <> 255 Then GoTo Try2
Next i
PNGChooseGrayDepth% = 1
Exit Function
Try2:
' depth 2: násobky 85
For i = 0 To colorCount - 1
v = _Red32(colors(i))
If (v Mod 85) <> 0 Then GoTo Try4
Next i
PNGChooseGrayDepth% = 2
Exit Function
Try4:
' depth 4: násobky 17
For i = 0 To colorCount - 1
v = _Red32(colors(i))
If (v Mod 17) <> 0 Then
PNGChooseGrayDepth% = 8
Exit Function
End If
Next i
PNGChooseGrayDepth% = 4
End Function
Function PNGSaveGray% (file$, w As Long, h As Long, depth As Integer, grayVal() As _Unsigned _Byte)
Dim f As Integer
Dim rowLen As Long
Dim scanSize As Long
Dim rawPos As Long
' mod 17
Dim rawBuf As _Unsigned _Byte
Dim row As _Unsigned _Byte
Dim prevRow As _Unsigned _Byte
Dim bestRow As _Unsigned _Byte
Dim workRow As _Unsigned _Byte
Dim x As Long, y As Long
Dim i As Long
Dim p As Long
Dim bpp As Long
Dim bytePos As Long
Dim v0 As Long, v1 As Long, v2 As Long, v3 As Long
Dim outByte As Long
Dim shift As Long
Dim filterType As _Unsigned _Byte
Dim raw$, comp$
Dim memBuf As _MEM
If _FileExists(file$) Then PNGSaveGray% = 1: Exit Function
rowLen = (w * depth + 7) \ 8
scanSize = h * (rowLen + 1)
ReDim rawBuf(0 To scanSize - 1) As _Unsigned _Byte
ReDim row(0 To rowLen - 1) As _Unsigned _Byte
ReDim prevRow(0 To rowLen - 1) As _Unsigned _Byte
ReDim bestRow(0 To rowLen - 1) As _Unsigned _Byte
ReDim workRow(0 To rowLen - 1) As _Unsigned _Byte
bpp = 1 ' filtry pracují po bajtech, u packovaných dat je bpp=1
f = FreeFile
Open file$ For Binary As #f
PNGWriteSignature f
PNGWriteIHDR f, w, h, depth, 0
rawPos = 0
p = 0
For y = 0 To h - 1
' naplň row (nefilterovaná data)
For i = 0 To rowLen - 1
row(i) = 0
Next i
If depth = 8 Then
For x = 0 To w - 1
row(x) = grayVal(p + x)
Next x
ElseIf depth = 4 Then
bytePos = 0
For x = 0 To w - 1 Step 2
v0 = grayVal(p + x) \ 17
v1 = 0
If x + 1 < w Then v1 = grayVal(p + x + 1) \ 17
row(bytePos) = (v0 * 16) Or v1
bytePos = bytePos + 1
Next x
ElseIf depth = 2 Then
bytePos = 0
For x = 0 To w - 1 Step 4
v0 = grayVal(p + x) \ 85
v1 = 0: v2 = 0: v3 = 0
If x + 1 < w Then v1 = grayVal(p + x + 1) \ 85
If x + 2 < w Then v2 = grayVal(p + x + 2) \ 85
If x + 3 < w Then v3 = grayVal(p + x + 3) \ 85
row(bytePos) = (v0 * 64) Or (v1 * 16) Or (v2 * 4) Or v3
bytePos = bytePos + 1
Next x
Else ' depth = 1
bytePos = 0
outByte = 0
shift = 7
For x = 0 To w - 1
If grayVal(p + x) <> 0 Then outByte = outByte Or (2 ^ shift)
shift = shift - 1
If shift < 0 Or x = w - 1 Then
row(bytePos) = outByte
bytePos = bytePos + 1
outByte = 0
shift = 7
End If
Next x
End If
' zvol filtr + zapiš
PNGApplyBestFilter row(), prevRow(), rowLen, bpp, bestRow(), workRow(), filterType
rawBuf(rawPos) = filterType
rawPos = rawPos + 1
For i = 0 To rowLen - 1
rawBuf(rawPos) = bestRow(i)
rawPos = rawPos + 1
Next i
' prevRow = row (nefilterovaný)
For i = 0 To rowLen - 1
prevRow(i) = row(i)
Next i
p = p + w
Next y
raw$ = Space$(scanSize)
memBuf = _Mem(rawBuf())
_MemGet memBuf, memBuf.OFFSET, raw$
_MemFree memBuf
comp$ = _Deflate$(raw$)
PNGWriteChunkStr f, "IDAT", comp$
PNGWriteIEND f
Close #f
PNGSaveGray% = -1
End Function
' PNGSaveIndexed% (ColorType=3, depth 1/2/4/8, PLTE + optionally tRNS)
Function PNGSaveIndexed% (file$, w As Long, h As Long, depth As Integer, colors() As _Unsigned Long, alphas() As _Unsigned _Byte, colorCount As Long, pixIndex() As _Unsigned _Byte)
Dim f As Integer
Dim trns As _Unsigned _Byte
Dim hasTRNS As _Byte
Dim lastNon255 As Long
Dim i As Long
Dim r As _Unsigned _Byte, g As _Unsigned _Byte, b As _Unsigned _Byte, a As _Unsigned _Byte
Dim rowLen As Long
Dim scanSize As Long
Dim rawPos As Long
Dim rawBuf As _Unsigned _Byte
Dim row As _Unsigned _Byte
Dim prevRow As _Unsigned _Byte
Dim bestRow As _Unsigned _Byte
Dim workRow As _Unsigned _Byte
Dim x As Long, y As Long
Dim p As Long
Dim bytePos As Long
Dim outByte As Long
Dim shift As Long
Dim v0 As Long, v1 As Long, v2 As Long, v3 As Long
Dim bpp As Long
Dim filterType As _Unsigned _Byte
Dim raw$, comp$
Dim memBuf As _MEM
If _FileExists(file$) Then PNGSaveIndexed% = 1: Exit Function
If colorCount <= 0 Then PNGSaveIndexed% = 10: Exit Function
' PLTE – used colors only
ReDim plte(0 To colorCount * 3 - 1) As _Unsigned _Byte
For i = 0 To colorCount - 1
r = _Red32(colors(i))
g = _Green32(colors(i))
b = _Blue32(colors(i))
plte(i * 3) = r
plte(i * 3 + 1) = g
plte(i * 3 + 2) = b
Next i
' tRNS – if it is need, trim trailing 255
hasTRNS = 0
lastNon255 = -1
For i = 0 To colorCount - 1
a = alphas(i)
If a <> 255 Then
hasTRNS = -1
lastNon255 = i
End If
Next i
If hasTRNS Then
ReDim trns(0 To lastNon255) As _Unsigned _Byte
For i = 0 To lastNon255
trns(i) = alphas(i)
Next i
End If
rowLen = (w * depth + 7) \ 8
scanSize = h * (rowLen + 1)
ReDim rawBuf(0 To scanSize - 1) As _Unsigned _Byte
ReDim row(0 To rowLen - 1) As _Unsigned _Byte
ReDim prevRow(0 To rowLen - 1) As _Unsigned _Byte
ReDim bestRow(0 To rowLen - 1) As _Unsigned _Byte
ReDim workRow(0 To rowLen - 1) As _Unsigned _Byte
bpp = 1
f = FreeFile
Open file$ For Binary As #f
PNGWriteSignature f
PNGWriteIHDR f, w, h, depth, 3
PNGWriteChunkBytes f, "PLTE", plte()
If hasTRNS Then PNGWriteChunkBytes f, "tRNS", trns()
rawPos = 0
p = 0
For y = 0 To h - 1
For i = 0 To rowLen - 1
row(i) = 0
Next i
If depth = 8 Then
For x = 0 To w - 1
row(x) = pixIndex(p + x)
Next x
ElseIf depth = 4 Then
bytePos = 0
For x = 0 To w - 1 Step 2
v0 = pixIndex(p + x) And &HF
v1 = 0
If x + 1 < w Then v1 = pixIndex(p + x + 1) And &HF
row(bytePos) = (v0 * 16) Or v1
bytePos = bytePos + 1
Next x
ElseIf depth = 2 Then
bytePos = 0
For x = 0 To w - 1 Step 4
v0 = pixIndex(p + x) And 3
v1 = 0: v2 = 0: v3 = 0
If x + 1 < w Then v1 = pixIndex(p + x + 1) And 3
If x + 2 < w Then v2 = pixIndex(p + x + 2) And 3
If x + 3 < w Then v3 = pixIndex(p + x + 3) And 3
row(bytePos) = (v0 * 64) Or (v1 * 16) Or (v2 * 4) Or v3
bytePos = bytePos + 1
Next x
Else ' depth = 1
bytePos = 0
outByte = 0
shift = 7
For x = 0 To w - 1
If (pixIndex(p + x) And 1) Then outByte = outByte Or (2 ^ shift)
shift = shift - 1
If shift < 0 Or x = w - 1 Then
row(bytePos) = outByte
bytePos = bytePos + 1
outByte = 0
shift = 7
End If
Next x
End If
PNGApplyBestFilter row(), prevRow(), rowLen, bpp, bestRow(), workRow(), filterType
rawBuf(rawPos) = filterType
rawPos = rawPos + 1
For i = 0 To rowLen - 1
rawBuf(rawPos) = bestRow(i)
rawPos = rawPos + 1
Next i
For i = 0 To rowLen - 1
prevRow(i) = row(i)
Next i
p = p + w
Next y
raw$ = Space$(scanSize)
memBuf = _Mem(rawBuf())
_MemGet memBuf, memBuf.OFFSET, raw$
_MemFree memBuf
comp$ = _Deflate$(raw$)
PNGWriteChunkStr f, "IDAT", comp$
PNGWriteIEND f
Close #f
PNGSaveIndexed% = -1
End Function
Function PNGSaveDirect% (file$, img As Long, w As Long, h As Long, colorType As Integer)
Dim f As Integer
Dim oldSrc As Long
Dim pixSize As Integer
Dim x As Long, y As Long
Dim idx As _Unsigned _Byte
Dim rgba As _Unsigned Long
Dim r As _Unsigned _Byte, g As _Unsigned _Byte, b As _Unsigned _Byte, a As _Unsigned _Byte
Dim gray As _Unsigned _Byte
Dim bytesPerPixel As Long
Dim rowLen As Long
Dim scanSize As Long
Dim rawPos As Long
Dim rawBuf As _Unsigned _Byte
Dim row As _Unsigned _Byte
Dim prevRow As _Unsigned _Byte
Dim bestRow As _Unsigned _Byte
Dim workRow As _Unsigned _Byte
Dim i As Long
Dim bpp As Long
Dim filterType As _Unsigned _Byte
Dim raw$, comp$
Dim memBuf As _MEM
If _FileExists(file$) Then PNGSaveDirect% = 1: Exit Function
If colorType = 2 Then
bytesPerPixel = 3
ElseIf colorType = 6 Then
bytesPerPixel = 4
ElseIf colorType = 4 Then
bytesPerPixel = 2
Else
PNGSaveDirect% = 10
Exit Function
End If
rowLen = w * bytesPerPixel
scanSize = h * (rowLen + 1)
ReDim rawBuf(0 To scanSize - 1) As _Unsigned _Byte
ReDim row(0 To rowLen - 1) As _Unsigned _Byte
ReDim prevRow(0 To rowLen - 1) As _Unsigned _Byte
ReDim bestRow(0 To rowLen - 1) As _Unsigned _Byte
ReDim workRow(0 To rowLen - 1) As _Unsigned _Byte
bpp = bytesPerPixel
f = FreeFile
Open file$ For Binary As #f
PNGWriteSignature f
PNGWriteIHDR f, w, h, 8, colorType
pixSize = _PixelSize(img)
oldSrc = _Source
_Source img
rawPos = 0
For y = 0 To h - 1
If colorType = 2 Then
i = 0
For x = 0 To w - 1
If pixSize = 1 Then
idx = Point(x, y)
rgba = _PaletteColor(idx, img)
a = 255
Else
rgba = Point(x, y)
a = _Alpha32(rgba)
End If
r = _Red32(rgba)
g = _Green32(rgba)
b = _Blue32(rgba)
row(i) = r
row(i + 1) = g
row(i + 2) = b
i = i + 3
Next x
ElseIf colorType = 6 Then
i = 0
For x = 0 To w - 1
If pixSize = 1 Then
idx = Point(x, y)
rgba = _PaletteColor(idx, img)
a = 255
Else
rgba = Point(x, y)
a = _Alpha32(rgba)
End If
r = _Red32(rgba)
g = _Green32(rgba)
b = _Blue32(rgba)
row(i) = r
row(i + 1) = g
row(i + 2) = b
row(i + 3) = a
i = i + 4
Next x
Else ' colorType = 4 (Gray+Alpha)
i = 0
For x = 0 To w - 1
If pixSize = 1 Then
idx = Point(x, y)
rgba = _PaletteColor(idx, img)
a = 255
Else
rgba = Point(x, y)
a = _Alpha32(rgba)
End If
gray = _Red32(rgba)
row(i) = gray
row(i + 1) = a
i = i + 2
Next x
End If
PNGApplyBestFilter row(), prevRow(), rowLen, bpp, bestRow(), workRow(), filterType
rawBuf(rawPos) = filterType
rawPos = rawPos + 1
For i = 0 To rowLen - 1
rawBuf(rawPos) = bestRow(i)
rawPos = rawPos + 1
Next i
For i = 0 To rowLen - 1
prevRow(i) = row(i)
Next i
Next y
_Source oldSrc
raw$ = Space$(scanSize)
memBuf = _Mem(rawBuf())
_MemGet memBuf, memBuf.OFFSET, raw$
_MemFree memBuf
comp$ = _Deflate$(raw$)
PNGWriteChunkStr f, "IDAT", comp$
PNGWriteIEND f
Close #f
PNGSaveDirect% = -1
End Function
'===========================================================================
' PNGApplyBestFilter (0..4) – heuristika "sum abs(signed byte)"
'===========================================================================
Sub PNGApplyBestFilter (row() As _Unsigned _Byte, prevRow() As _Unsigned _Byte, rowLen As Long, bpp As Long, bestRow() As _Unsigned _Byte, workRow() As _Unsigned _Byte, filterType As _Unsigned _Byte)
Dim t As Long
Dim i As Long
Dim bestSum As Long
Dim sum As Long
Dim diff As Long
Dim left As Long, up As Long, upLeft As Long
Dim avg As Long
Dim pr As Long
bestSum = 2147483647
filterType = 0
For t = 0 To 4
sum = 0
For i = 0 To rowLen - 1
If i >= bpp Then
left = row(i - bpp)
upLeft = prevRow(i - bpp)
Else
left = 0
upLeft = 0
End If
up = prevRow(i)
Select Case t
Case 0
diff = row(i)
Case 1 ' Sub
diff = (row(i) - left) And &HFF
Case 2 ' Up
diff = (row(i) - up) And &HFF
Case 3 ' Average
avg = (left + up) \ 2
diff = (row(i) - avg) And &HFF
Case 4 ' Paeth
pr = PNGPaethPredict&(left, up, upLeft)
diff = (row(i) - pr) And &HFF
End Select
workRow(i) = diff
' diff jako signed byte -> abs
If diff >= 128 Then diff = diff - 256
If diff < 0 Then diff = -diff
sum = sum + diff
Next i
If sum < bestSum Then
bestSum = sum
filterType = t
For i = 0 To rowLen - 1
bestRow(i) = workRow(i)
Next i
End If
Next t
End Sub
Function PNGPaethPredict& (a As Long, b As Long, c As Long)
Dim p As Long
Dim pa As Long, pb As Long, pc As Long
p = a + b - c
pa = p - a: If pa < 0 Then pa = -pa
pb = p - b: If pb < 0 Then pb = -pb
pc = p - c: If pc < 0 Then pc = -pc
If pa <= pb And pa <= pc Then
PNGPaethPredict& = a
ElseIf pb <= pc Then
PNGPaethPredict& = b
Else
PNGPaethPredict& = c
End If
End Function
'===========================================================================
' PNG zápis: signature / IHDR / chunk / IEND
'===========================================================================
Sub PNGWriteSignature (f As Integer)
Dim sig(0 To 7) As _Unsigned _Byte
sig(0) = &H89
sig(1) = &H50
sig(2) = &H4E
sig(3) = &H47
sig(4) = &HD
sig(5) = &HA
sig(6) = &H1A
sig(7) = &HA
Put #f, , sig()
End Sub
Sub PNGWriteIHDR (f As Integer, w As Long, h As Long, depth As _Unsigned _Byte, colorType As _Unsigned _Byte)
Dim hdr(0 To 12) As _Unsigned _Byte
Dim crc As _Unsigned Long
hdr(0) = (w \ 16777216) And &HFF
hdr(1) = (w \ 65536) And &HFF
hdr(2) = (w \ 256) And &HFF
hdr(3) = w And &HFF
hdr(4) = (h \ 16777216) And &HFF
hdr(5) = (h \ 65536) And &HFF
hdr(6) = (h \ 256) And &HFF
hdr(7) = h And &HFF
hdr(8) = depth
hdr(9) = colorType
hdr(10) = 0
hdr(11) = 0
hdr(12) = 0
PNGWriteChunkBytes f, "IHDR", hdr()
End Sub
Sub PNGWriteIEND (f As Integer)
PNGWriteChunkStr f, "IEND", ""
End Sub
Sub PNGWriteChunkBytes (f As Integer, id As String * 4, datas() As _Unsigned _Byte)
Dim lenData As _Unsigned Long
Dim lenBE As _Unsigned Long
Dim crc As _Unsigned Long
Dim z As Long
lenData = (UBound(datas) - LBound(datas) + 1)
lenBE = PNGSwapUL~&(lenData)
Put #f, , lenBE
Put #f, , id
Put #f, , datas()
crc = PNGCRCBytes~&(id, datas())
crc = PNGSwapUL~&(crc)
Put #f, , crc
End Sub
Sub PNGWriteChunkStr (f As Integer, id As String * 4, datas As String)
Dim lenData As _Unsigned Long
Dim lenBE As _Unsigned Long
Dim crc As _Unsigned Long
lenData = Len(datas)
lenBE = PNGSwapUL~&(lenData)
Put #f, , lenBE
Put #f, , id
If lenData > 0 Then Put #f, , datas
crc = PNGCRCString~&(id, datas)
crc = PNGSwapUL~&(crc)
Put #f, , crc
End Sub
Function PNGSwapUL~& (x As _Unsigned Long)
Dim b0 As _Unsigned Long, b1 As _Unsigned Long, b2 As _Unsigned Long, b3 As _Unsigned Long
b0 = (x And &HFF~&)
b1 = (x \ 256) And &HFF~&
b2 = (x \ 65536) And &HFF~&
b3 = (x \ 16777216) And &HFF~&
PNGSwapUL~& = b0 * 16777216~& + b1 * 65536~& + b2 * 256~& + b3
End Function
'===========================================================================
' CRC (rychlé, bez _MEM a bez kopírování velkých bufferů)
'===========================================================================
Sub PNGMakeCRCTable
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 k
PNGCRC_table(n) = c
Next n
PNGCRC_table_computed = 1
End Sub
Sub PNGCRCUpdateByte (crc As _Unsigned Long, b As _Unsigned _Byte)
If PNGCRC_table_computed = 0 Then PNGMakeCRCTable
crc = PNGCRC_table((crc Xor b) And &HFF) Xor (crc \ 256)
End Sub
Function PNGCRCBytes~& (id As String * 4, datas() As _Unsigned _Byte)
Dim crc As _Unsigned Long
Dim i As Long
Dim b As _Unsigned _Byte
crc = &HFFFFFFFF~&
For i = 1 To 4
b = Asc(id, i)
PNGCRCUpdateByte crc, b
Next i
For i = LBound(datas) To UBound(datas)
PNGCRCUpdateByte crc, datas(i)
Next i
PNGCRCBytes~& = Not crc
End Function
Function PNGCRCString~& (id As String * 4, datas As String)
Dim crc As _Unsigned Long
Dim i As Long
Dim b As _Unsigned _Byte
Dim n As Long
crc = &HFFFFFFFF~&
For i = 1 To 4
b = Asc(id, i)
PNGCRCUpdateByte crc, b
Next i
n = Len(datas)
For i = 1 To n
b = Asc(datas, i)
PNGCRCUpdateByte crc, b
Next i
PNGCRCString~& = Not crc
End Function
or this faster (but 15000x15000 duration is 21 sec); 142KB
Code: (Select All)
'
' PNGExportAuto.bas lossless PNG export with automatic selection (FAST)
'
' Auto chooses smallest reasonable lossless PNG:
' grayscale (1/2/4/8) when possible (no alpha)
' indexed (1/2/4/8) when <= 256 colors (with optional tRNS)
' otherwise RGB (24bit) / RGBA (32bit)
' and for gray+alpha uses ColorType=4 when applicable.
'
' Speed upgrades:
' - NO POINT (reads pixels via _MemImage + _MemCopy row-by-row)
' - Palette colors are precomputed once for 8-bit sources
' - No full-frame pixIndex()/grayVal() buffers
' - Scanlines go into rawBuf() via _MEM (no _MEM on variable-length strings)
' - Filter selection compromise: 0/1/2 always, Paeth only if sample suggests gain
'
' Return codes:
' -1 OK
' 1 file exists
' 10 unsupported pixel mode
' 11 text screen
'
Option _Explicit
Const Z_OK = 0
' --- CRC table ---
Dim Shared PNGCRC_table(0 To 255) As _Unsigned Long
Dim Shared PNGCRC_table_computed As Long
' --- abs table for fast filter scoring ---
Dim Shared PNGAbsTable(0 To 255) As _Unsigned _Byte
Dim Shared PNGAbsReady As _Byte
Dim image As Long
Dim t As Single
Dim imgHandle As Long
Dim res As Integer
image = _NewImage(15000, 15000, 256)
_Dest image
Cls , 199
Line (0, 0)-(6390, 4790), 15, BF
Circle (3200, 2400), 150, 4
Circle (3200, 12400), 100, 2
Print "Test PNG export (auto minimal, MEM fast)"
_Dest 0
imgHandle = image
t = Timer
res = PNGExportAuto%("test_outputX.png", imgHandle)
Print "saved in: "; Timer - t
Select Case res
Case -1: Print "PNG saved OK!"
Case 1: Print "Error: file already exist."
Case 10: Print "Error: unsupported pixel mode."
Case 11: Print "Error: text screen."
Case Else: Print "Error: "; res
End Select
Sleep
System
'
' FUNCTIONS / SUBS (at end)
'
Function PNGExportAuto% (file$, img As Long)
Dim pixSize As Integer
Dim w As Long, h As Long
Dim imgUse As Long
Dim temp32 As Long
Dim freeTemp As _Byte
Dim hasAlpha As _Byte
Dim isGray As _Byte
Dim grayCan1 As _Byte, grayCan2 As _Byte, grayCan4 As _Byte
Dim palettePossible As _Byte
Dim colorCount As Long
Dim palDepth As Integer
Dim grayDepth As Integer
' --- 8-bit source helpers ---
Dim palRGBA(0 To 255) As _Unsigned Long
Dim idxGray(0 To 255) As _Unsigned _Byte
Dim idxIsGray(0 To 255) As _Byte
Dim usedIdx(0 To 255) As _Byte
Dim idxToNew(0 To 255) As _Unsigned _Byte
' --- palette lists (for PLTE / tRNS) ---
Dim colors(0 To 255) As _Unsigned Long
Dim alphas(0 To 255) As _Unsigned _Byte
' --- hash for <=256 colors detection for 32-bit source ---
Const HASH_SIZE = 4096
Dim hashKey(0 To HASH_SIZE - 1) As _Unsigned Long
Dim hashVal(0 To HASH_SIZE - 1) As Integer
Dim hashUsed(0 To HASH_SIZE - 1) As _Byte
Dim mask As Long
Dim hpos As Long, probe As Long
Dim found As _Byte
' --- _MEM scanning row-by-row ---
Dim mImg As _MEM
Dim mRow As _MEM
Dim strideBytes As _Unsigned _Offset
Dim rowOff As _Unsigned _Offset
Dim row8 As _Unsigned _Byte
Dim row32 As _Unsigned Long
' --- loop vars ---
Dim x As Long, y As Long
Dim idx As _Unsigned _Byte
Dim rgba As _Unsigned Long
Dim r As _Unsigned _Byte, g As _Unsigned _Byte, b As _Unsigned _Byte, a As _Unsigned _Byte
Dim i As Long
If _FileExists(file$) Then PNGExportAuto% = 1: Exit Function
pixSize = _PixelSize(img)
If pixSize = 0 Then PNGExportAuto% = 11: Exit Function
imgUse = img
freeTemp = 0
' Support for 2BPP images: flip to 32bit and continue (lossless)
If pixSize = 2 Then
temp32 = _CopyImage(img, 32)
If temp32 <= -2 Then
imgUse = temp32
freeTemp = -1
pixSize = _PixelSize(imgUse)
Else
PNGExportAuto% = 10
Exit Function
End If
End If
If pixSize <> 1 And pixSize <> 4 Then
If freeTemp Then _FreeImage imgUse
PNGExportAuto% = 10
Exit Function
End If
w = _Width(imgUse)
h = _Height(imgUse)
hasAlpha = 0
isGray = -1
grayCan1 = -1: grayCan2 = -1: grayCan4 = -1
palettePossible = -1
colorCount = 0
' Precompute palette once for 8-bit images
If pixSize = 1 Then
For i = 0 To 255
palRGBA(i) = _PaletteColor(i, imgUse)
r = (palRGBA(i) \ 65536) And &HFF
g = (palRGBA(i) \ 256) And &HFF
b = palRGBA(i) And &HFF
idxGray(i) = r
If r = g And r = b Then idxIsGray(i) = -1 Else idxIsGray(i) = 0
usedIdx(i) = 0
idxToNew(i) = 0
Next i
palettePossible = -1
Else
mask = HASH_SIZE - 1
End If
' _MEM scan rows
mImg = _MemImage(imgUse)
strideBytes = w * pixSize
If pixSize = 1 Then
ReDim row8(0 To w - 1) As _Unsigned _Byte
mRow = _Mem(row8())
Else
ReDim row32(0 To w - 1) As _Unsigned Long
mRow = _Mem(row32())
End If
For y = 0 To h - 1
rowOff = mImg.OFFSET + y * strideBytes
_MemCopy mImg, rowOff, strideBytes To mRow, mRow.OFFSET
If pixSize = 1 Then
For x = 0 To w - 1
idx = row8(x)
If usedIdx(idx) = 0 Then usedIdx(idx) = -1
If isGray Then
If idxIsGray(idx) = 0 Then
isGray = 0
Else
r = idxGray(idx)
If r <> 0 And r <> 255 Then grayCan1 = 0
If (r Mod 85) <> 0 Then grayCan2 = 0
If (r Mod 17) <> 0 Then grayCan4 = 0
End If
End If
Next x
Else
For x = 0 To w - 1
rgba = row32(x)
a = (rgba \ 16777216) And &HFF
If a <> 255 Then hasAlpha = -1
r = (rgba \ 65536) And &HFF
g = (rgba \ 256) And &HFF
b = rgba And &HFF
If isGray Then
If r <> g Or r <> b Then
isGray = 0
Else
If r <> 0 And r <> 255 Then grayCan1 = 0
If (r Mod 85) <> 0 Then grayCan2 = 0
If (r Mod 17) <> 0 Then grayCan4 = 0
End If
End If
If palettePossible Then
hpos = (rgba * 2654435761~&) And mask
probe = 0
found = 0
Do While hashUsed(hpos)
If hashKey(hpos) = rgba Then
found = -1
Exit Do
End If
hpos = (hpos + 1) And mask
probe = probe + 1
If probe >= HASH_SIZE Then Exit Do
Loop
If found = 0 Then
If colorCount >= 256 Then
palettePossible = 0
Else
hashUsed(hpos) = -1
hashKey(hpos) = rgba
hashVal(hpos) = colorCount
colors(colorCount) = rgba
alphas(colorCount) = a
colorCount = colorCount + 1
End If
End If
End If
Next x
End If
Next y
_MemFree mRow
_MemFree mImg
' For pixSize=1: build compact palette lists + idxToNew mapping
If pixSize = 1 Then
colorCount = 0
For i = 0 To 255
If usedIdx(i) Then
idxToNew(i) = colorCount
colors(colorCount) = palRGBA(i)
alphas(colorCount) = 255
colorCount = colorCount + 1
End If
Next i
palettePossible = -1
End If
' Decide best mode
If hasAlpha = 0 Then
If isGray Then
If grayCan1 Then
grayDepth = 1
ElseIf grayCan2 Then
grayDepth = 2
ElseIf grayCan4 Then
grayDepth = 4
Else
grayDepth = 8
End If
PNGExportAuto% = PNGSaveGrayMem%(file$, imgUse, w, h, grayDepth, pixSize, palRGBA(), idxGray())
ElseIf palettePossible Then
palDepth = PNGChoosePalDepth%(colorCount)
PNGExportAuto% = PNGSaveIndexedMem%(file$, imgUse, w, h, palDepth, pixSize, palRGBA(), idxToNew(), colors(), alphas(), colorCount)
Else
PNGExportAuto% = PNGSaveDirectMem%(file$, imgUse, w, h, 2, pixSize, palRGBA()) ' RGB
End If
Else
If palettePossible Then
palDepth = PNGChoosePalDepth%(colorCount)
PNGExportAuto% = PNGSaveIndexedMem%(file$, imgUse, w, h, palDepth, pixSize, palRGBA(), idxToNew(), colors(), alphas(), colorCount)
ElseIf isGray Then
PNGExportAuto% = PNGSaveDirectMem%(file$, imgUse, w, h, 4, pixSize, palRGBA()) ' Gray+Alpha
Else
PNGExportAuto% = PNGSaveDirectMem%(file$, imgUse, w, h, 6, pixSize, palRGBA()) ' RGBA
End If
End If
If freeTemp Then _FreeImage imgUse
End Function
Function PNGChoosePalDepth% (colorCount As Long)
If colorCount <= 2 Then
PNGChoosePalDepth% = 1
ElseIf colorCount <= 4 Then
PNGChoosePalDepth% = 2
ElseIf colorCount <= 16 Then
PNGChoosePalDepth% = 4
Else
PNGChoosePalDepth% = 8
End If
End Function
'
' SAVE: DIRECT (ColorType 2/4/6), MEM fast, scanlines -> rawBuf()
'
Function PNGSaveDirectMem% (file$, img As Long, w As Long, h As Long, colorType As Integer, pixSize As Integer, palRGBA() As _Unsigned Long)
Dim f As Integer
Dim bytesPerPixel As Long
Dim rowLen As Long
Dim scanSize As Long
Dim rawPos As Long
Dim rawBuf As _Unsigned _Byte
Dim row As _Unsigned _Byte
Dim prevRow As _Unsigned _Byte
Dim bestRow As _Unsigned _Byte
Dim workRow As _Unsigned _Byte
Dim bpp As Long
Dim filterType As _Unsigned _Byte
Dim mImg As _MEM
Dim mSrcRow As _MEM
Dim strideBytes As _Unsigned _Offset
Dim rowOff As _Unsigned _Offset
Dim src8 As _Unsigned _Byte
Dim src32 As _Unsigned Long
Dim x As Long, y As Long
Dim i As Long
Dim idx As _Unsigned _Byte
Dim rgba As _Unsigned Long
Dim a As _Unsigned _Byte
Dim gray As _Unsigned _Byte
Dim raw As String
Dim comp As String
Dim memBuf As _MEM
Dim mBest As _MEM
Dim mRow As _MEM
Dim mPrev As _MEM
Dim mRaw As _MEM
If _FileExists(file$) Then PNGSaveDirectMem% = 1: Exit Function
If colorType = 2 Then
bytesPerPixel = 3
ElseIf colorType = 6 Then
bytesPerPixel = 4
ElseIf colorType = 4 Then
bytesPerPixel = 2
Else
PNGSaveDirectMem% = 10
Exit Function
End If
rowLen = w * bytesPerPixel
scanSize = h * (rowLen + 1)
ReDim rawBuf(0 To scanSize - 1) As _Unsigned _Byte
ReDim row(0 To rowLen - 1) As _Unsigned _Byte
ReDim prevRow(0 To rowLen - 1) As _Unsigned _Byte
ReDim bestRow(0 To rowLen - 1) As _Unsigned _Byte
ReDim workRow(0 To rowLen - 1) As _Unsigned _Byte
bpp = bytesPerPixel
f = FreeFile
Open file$ For Binary As #f
PNGWriteSignature f
PNGWriteIHDR f, w, h, 8, colorType
mImg = _MemImage(img)
strideBytes = w * pixSize
If pixSize = 1 Then
ReDim src8(0 To w - 1) As _Unsigned _Byte
mSrcRow = _Mem(src8())
Else
ReDim src32(0 To w - 1) As _Unsigned Long
mSrcRow = _Mem(src32())
End If
mBest = _Mem(bestRow())
mRow = _Mem(row())
mPrev = _Mem(prevRow())
mRaw = _Mem(rawBuf())
rawPos = 0
For y = 0 To h - 1
rowOff = mImg.OFFSET + y * strideBytes
_MemCopy mImg, rowOff, strideBytes To mSrcRow, mSrcRow.OFFSET
If colorType = 2 Then
i = 0
For x = 0 To w - 1
If pixSize = 1 Then
idx = src8(x)
rgba = palRGBA(idx)
Else
rgba = src32(x)
End If
row(i) = (rgba \ 65536) And &HFF
row(i + 1) = (rgba \ 256) And &HFF
row(i + 2) = rgba And &HFF
i = i + 3
Next x
ElseIf colorType = 6 Then
i = 0
For x = 0 To w - 1
If pixSize = 1 Then
idx = src8(x)
rgba = palRGBA(idx)
a = 255
Else
rgba = src32(x)
a = (rgba \ 16777216) And &HFF
End If
row(i) = (rgba \ 65536) And &HFF
row(i + 1) = (rgba \ 256) And &HFF
row(i + 2) = rgba And &HFF
row(i + 3) = a
i = i + 4
Next x
Else ' colorType = 4 (Gray+Alpha)
i = 0
For x = 0 To w - 1
If pixSize = 1 Then
idx = src8(x)
rgba = palRGBA(idx)
a = 255
Else
rgba = src32(x)
a = (rgba \ 16777216) And &HFF
End If
gray = (rgba \ 65536) And &HFF
row(i) = gray
row(i + 1) = a
i = i + 2
Next x
End If
PNGApplyBestFilter row(), prevRow(), rowLen, bpp, bestRow(), workRow(), filterType
rawBuf(rawPos) = filterType
rawPos = rawPos + 1
_MemCopy mBest, mBest.OFFSET, rowLen To mRaw, mRaw.OFFSET + rawPos
rawPos = rawPos + rowLen
_MemCopy mRow, mRow.OFFSET, rowLen To mPrev, mPrev.OFFSET
Next y
_MemFree mRaw
_MemFree mPrev
_MemFree mRow
_MemFree mBest
_MemFree mSrcRow
_MemFree mImg
raw$ = Space$(scanSize)
memBuf = _Mem(rawBuf())
_MemGet memBuf, memBuf.OFFSET, raw$
_MemFree memBuf
comp$ = _Deflate$(raw$)
PNGWriteChunkStr f, "IDAT", comp$
PNGWriteIEND f
Close #f
PNGSaveDirectMem% = -1
End Function
'
' SAVE: GRAY (ColorType 0, depth 1/2/4/8), MEM fast, scanlines -> rawBuf()
'
Function PNGSaveGrayMem% (file$, img As Long, w As Long, h As Long, depth As Integer, pixSize As Integer, palRGBA() As _Unsigned Long, idxGray() As _Unsigned _Byte)
Dim f As Integer
Dim rowLen As Long
Dim scanSize As Long
Dim rawPos As Long
Dim rawBuf As _Unsigned _Byte
Dim row As _Unsigned _Byte
Dim prevRow As _Unsigned _Byte
Dim bestRow As _Unsigned _Byte
Dim workRow As _Unsigned _Byte
Dim bpp As Long
Dim filterType As _Unsigned _Byte
Dim mImg As _MEM
Dim mSrcRow As _MEM
Dim strideBytes As _Unsigned _Offset
Dim rowOff As _Unsigned _Offset
Dim src8 As _Unsigned _Byte
Dim src32 As _Unsigned Long
Dim x As Long, y As Long
Dim i As Long
Dim idx As _Unsigned _Byte
Dim rgba As _Unsigned Long
Dim gray As _Unsigned _Byte
Dim bytePos As Long
Dim v0 As Long, v1 As Long, v2 As Long, v3 As Long
Dim outByte As Long
Dim shift As Long
Dim raw As String
Dim comp As String
Dim memBuf As _MEM
Dim mBest As _MEM
Dim mRow As _MEM
Dim mPrev As _MEM
Dim mRaw As _MEM
If _FileExists(file$) Then PNGSaveGrayMem% = 1: Exit Function
rowLen = (w * depth + 7) \ 8
scanSize = h * (rowLen + 1)
ReDim rawBuf(0 To scanSize - 1) As _Unsigned _Byte
ReDim row(0 To rowLen - 1) As _Unsigned _Byte
ReDim prevRow(0 To rowLen - 1) As _Unsigned _Byte
ReDim bestRow(0 To rowLen - 1) As _Unsigned _Byte
ReDim workRow(0 To rowLen - 1) As _Unsigned _Byte
bpp = 1
f = FreeFile
Open file$ For Binary As #f
PNGWriteSignature f
PNGWriteIHDR f, w, h, depth, 0
mImg = _MemImage(img)
strideBytes = w * pixSize
If pixSize = 1 Then
ReDim src8(0 To w - 1) As _Unsigned _Byte
mSrcRow = _Mem(src8())
Else
ReDim src32(0 To w - 1) As _Unsigned Long
mSrcRow = _Mem(src32())
End If
mBest = _Mem(bestRow())
mRow = _Mem(row())
mPrev = _Mem(prevRow())
mRaw = _Mem(rawBuf())
rawPos = 0
For y = 0 To h - 1
rowOff = mImg.OFFSET + y * strideBytes
_MemCopy mImg, rowOff, strideBytes To mSrcRow, mSrcRow.OFFSET
If depth = 8 Then
For x = 0 To w - 1
If pixSize = 1 Then
idx = src8(x)
row(x) = idxGray(idx)
Else
rgba = src32(x)
row(x) = (rgba \ 65536) And &HFF
End If
Next x
ElseIf depth = 4 Then
bytePos = 0
For x = 0 To w - 1 Step 2
If pixSize = 1 Then
v0 = idxGray(src8(x)) \ 17
v1 = 0
If x + 1 < w Then v1 = idxGray(src8(x + 1)) \ 17
Else
v0 = ((src32(x) \ 65536) And &HFF) \ 17
v1 = 0
If x + 1 < w Then v1 = ((src32(x + 1) \ 65536) And &HFF) \ 17
End If
row(bytePos) = (v0 * 16) Or v1
bytePos = bytePos + 1
Next x
ElseIf depth = 2 Then
bytePos = 0
For x = 0 To w - 1 Step 4
If pixSize = 1 Then
v0 = idxGray(src8(x)) \ 85
v1 = 0: v2 = 0: v3 = 0
If x + 1 < w Then v1 = idxGray(src8(x + 1)) \ 85
If x + 2 < w Then v2 = idxGray(src8(x + 2)) \ 85
If x + 3 < w Then v3 = idxGray(src8(x + 3)) \ 85
Else
v0 = ((src32(x) \ 65536) And &HFF) \ 85
v1 = 0: v2 = 0: v3 = 0
If x + 1 < w Then v1 = ((src32(x + 1) \ 65536) And &HFF) \ 85
If x + 2 < w Then v2 = ((src32(x + 2) \ 65536) And &HFF) \ 85
If x + 3 < w Then v3 = ((src32(x + 3) \ 65536) And &HFF) \ 85
End If
row(bytePos) = (v0 * 64) Or (v1 * 16) Or (v2 * 4) Or v3
bytePos = bytePos + 1
Next x
Else ' depth = 1
bytePos = 0
outByte = 0
shift = 7
For x = 0 To w - 1
If pixSize = 1 Then
gray = idxGray(src8(x))
Else
gray = (src32(x) \ 65536) And &HFF
End If
If gray <> 0 Then outByte = outByte Or (2 ^ shift)
shift = shift - 1
If shift < 0 Or x = w - 1 Then
row(bytePos) = outByte
bytePos = bytePos + 1
outByte = 0
shift = 7
End If
Next x
End If
PNGApplyBestFilter row(), prevRow(), rowLen, bpp, bestRow(), workRow(), filterType
rawBuf(rawPos) = filterType
rawPos = rawPos + 1
_MemCopy mBest, mBest.OFFSET, rowLen To mRaw, mRaw.OFFSET + rawPos
rawPos = rawPos + rowLen
_MemCopy mRow, mRow.OFFSET, rowLen To mPrev, mPrev.OFFSET
Next y
_MemFree mRaw
_MemFree mPrev
_MemFree mRow
_MemFree mBest
_MemFree mSrcRow
_MemFree mImg
raw$ = Space$(scanSize)
memBuf = _Mem(rawBuf())
_MemGet memBuf, memBuf.OFFSET, raw$
_MemFree memBuf
comp$ = _Deflate$(raw$)
PNGWriteChunkStr f, "IDAT", comp$
PNGWriteIEND f
Close #f
PNGSaveGrayMem% = -1
End Function
'
' SAVE: INDEXED (ColorType 3, depth 1/2/4/8) + optional tRNS, MEM fast
' scanlines -> rawBuf()
'
Function PNGSaveIndexedMem% (file$, img As Long, w As Long, h As Long, depth As Integer, pixSize As Integer, palRGBA() As _Unsigned Long, idxToNew() As _Unsigned _Byte, colors() As _Unsigned Long, alphas() As _Unsigned _Byte, colorCount As Long)
Dim f As Integer
Dim plte As _Unsigned _Byte
Dim trns As _Unsigned _Byte
Dim hasTRNS As _Byte
Dim lastNon255 As Long
Dim rowLen As Long
Dim scanSize As Long
Dim rawPos As Long
Dim rawBuf As _Unsigned _Byte
Dim row As _Unsigned _Byte
Dim prevRow As _Unsigned _Byte
Dim bestRow As _Unsigned _Byte
Dim workRow As _Unsigned _Byte
Dim bpp As Long
Dim filterType As _Unsigned _Byte
Dim mImg As _MEM
Dim mSrcRow As _MEM
Dim strideBytes As _Unsigned _Offset
Dim rowOff As _Unsigned _Offset
Dim src8 As _Unsigned _Byte
Dim src32 As _Unsigned Long
' hash for rgba->index for 32-bit indexed save
Const HASH_SIZE = 4096
Dim hashKey(0 To HASH_SIZE - 1) As _Unsigned Long
Dim hashVal(0 To HASH_SIZE - 1) As Integer
Dim hashUsed(0 To HASH_SIZE - 1) As _Byte
Dim mask As Long
Dim hpos As Long, probe As Long
Dim x As Long, y As Long
Dim i As Long
Dim rgba As _Unsigned Long
Dim bytePos As Long
Dim v0 As Long, v1 As Long, v2 As Long, v3 As Long
Dim outByte As Long
Dim shift As Long
Dim newIdx As _Unsigned _Byte
Dim raw As String
Dim comp As String
Dim memBuf As _MEM
Dim mBest As _MEM
Dim mRow As _MEM
Dim mPrev As _MEM
Dim mRaw As _MEM
If _FileExists(file$) Then PNGSaveIndexedMem% = 1: Exit Function
If colorCount <= 0 Then PNGSaveIndexedMem% = 10: Exit Function
' PLTE only used colors
ReDim plte(0 To colorCount * 3 - 1) As _Unsigned _Byte
For i = 0 To colorCount - 1
plte(i * 3) = (colors(i) \ 65536) And &HFF
plte(i * 3 + 1) = (colors(i) \ 256) And &HFF
plte(i * 3 + 2) = colors(i) And &HFF
Next i
' tRNS only if needed (trim trailing 255)
hasTRNS = 0
lastNon255 = -1
For i = 0 To colorCount - 1
If alphas(i) <> 255 Then
hasTRNS = -1
lastNon255 = i
End If
Next i
If hasTRNS Then
ReDim trns(0 To lastNon255) As _Unsigned _Byte
For i = 0 To lastNon255
trns(i) = alphas(i)
Next i
End If
rowLen = (w * depth + 7) \ 8
scanSize = h * (rowLen + 1)
ReDim rawBuf(0 To scanSize - 1) As _Unsigned _Byte
ReDim row(0 To rowLen - 1) As _Unsigned _Byte
ReDim prevRow(0 To rowLen - 1) As _Unsigned _Byte
ReDim bestRow(0 To rowLen - 1) As _Unsigned _Byte
ReDim workRow(0 To rowLen - 1) As _Unsigned _Byte
bpp = 1
f = FreeFile
Open file$ For Binary As #f
PNGWriteSignature f
PNGWriteIHDR f, w, h, depth, 3
PNGWriteChunkBytes f, "PLTE", plte()
If hasTRNS Then PNGWriteChunkBytes f, "tRNS", trns()
mImg = _MemImage(img)
strideBytes = w * pixSize
If pixSize = 1 Then
ReDim src8(0 To w - 1) As _Unsigned _Byte
mSrcRow = _Mem(src8())
Else
ReDim src32(0 To w - 1) As _Unsigned Long
mSrcRow = _Mem(src32())
mask = HASH_SIZE - 1
For i = 0 To colorCount - 1
rgba = colors(i)
hpos = (rgba * 2654435761~&) And mask
probe = 0
Do While hashUsed(hpos)
hpos = (hpos + 1) And mask
probe = probe + 1
If probe >= HASH_SIZE Then Exit Do
Loop
hashUsed(hpos) = -1
hashKey(hpos) = rgba
hashVal(hpos) = i
Next i
End If
mBest = _Mem(bestRow())
mRow = _Mem(row())
mPrev = _Mem(prevRow())
mRaw = _Mem(rawBuf())
rawPos = 0
For y = 0 To h - 1
rowOff = mImg.OFFSET + y * strideBytes
_MemCopy mImg, rowOff, strideBytes To mSrcRow, mSrcRow.OFFSET
If depth = 8 Then
For x = 0 To w - 1
If pixSize = 1 Then
row(x) = idxToNew(src8(x))
Else
rgba = src32(x)
hpos = (rgba * 2654435761~&) And mask
Do While hashUsed(hpos)
If hashKey(hpos) = rgba Then Exit Do
hpos = (hpos + 1) And mask
Loop
row(x) = hashVal(hpos)
End If
Next x
ElseIf depth = 4 Then
bytePos = 0
For x = 0 To w - 1 Step 2
If pixSize = 1 Then
v0 = idxToNew(src8(x)) And &HF
v1 = 0
If x + 1 < w Then v1 = idxToNew(src8(x + 1)) And &HF
Else
rgba = src32(x)
hpos = (rgba * 2654435761~&) And mask
Do While hashUsed(hpos)
If hashKey(hpos) = rgba Then Exit Do
hpos = (hpos + 1) And mask
Loop
v0 = hashVal(hpos) And &HF
v1 = 0
If x + 1 < w Then
rgba = src32(x + 1)
hpos = (rgba * 2654435761~&) And mask
Do While hashUsed(hpos)
If hashKey(hpos) = rgba Then Exit Do
hpos = (hpos + 1) And mask
Loop
v1 = hashVal(hpos) And &HF
End If
End If
row(bytePos) = (v0 * 16) Or v1
bytePos = bytePos + 1
Next x
ElseIf depth = 2 Then
bytePos = 0
For x = 0 To w - 1 Step 4
If pixSize = 1 Then
v0 = idxToNew(src8(x)) And 3
v1 = 0: v2 = 0: v3 = 0
If x + 1 < w Then v1 = idxToNew(src8(x + 1)) And 3
If x + 2 < w Then v2 = idxToNew(src8(x + 2)) And 3
If x + 3 < w Then v3 = idxToNew(src8(x + 3)) And 3
Else
rgba = src32(x)
hpos = (rgba * 2654435761~&) And mask
Do While hashUsed(hpos)
If hashKey(hpos) = rgba Then Exit Do
hpos = (hpos + 1) And mask
Loop
v0 = hashVal(hpos) And 3
v1 = 0: v2 = 0: v3 = 0
If x + 1 < w Then
rgba = src32(x + 1)
hpos = (rgba * 2654435761~&) And mask
Do While hashUsed(hpos)
If hashKey(hpos) = rgba Then Exit Do
hpos = (hpos + 1) And mask
Loop
v1 = hashVal(hpos) And 3
End If
If x + 2 < w Then
rgba = src32(x + 2)
hpos = (rgba * 2654435761~&) And mask
Do While hashUsed(hpos)
If hashKey(hpos) = rgba Then Exit Do
hpos = (hpos + 1) And mask
Loop
v2 = hashVal(hpos) And 3
End If
If x + 3 < w Then
rgba = src32(x + 3)
hpos = (rgba * 2654435761~&) And mask
Do While hashUsed(hpos)
If hashKey(hpos) = rgba Then Exit Do
hpos = (hpos + 1) And mask
Loop
v3 = hashVal(hpos) And 3
End If
End If
row(bytePos) = (v0 * 64) Or (v1 * 16) Or (v2 * 4) Or v3
bytePos = bytePos + 1
Next x
Else ' depth = 1
bytePos = 0
outByte = 0
shift = 7
For x = 0 To w - 1
If pixSize = 1 Then
newIdx = idxToNew(src8(x)) And 1
Else
rgba = src32(x)
hpos = (rgba * 2654435761~&) And mask
Do While hashUsed(hpos)
If hashKey(hpos) = rgba Then Exit Do
hpos = (hpos + 1) And mask
Loop
newIdx = hashVal(hpos) And 1
End If
If newIdx Then outByte = outByte Or (2 ^ shift)
shift = shift - 1
If shift < 0 Or x = w - 1 Then
row(bytePos) = outByte
bytePos = bytePos + 1
outByte = 0
shift = 7
End If
Next x
End If
PNGApplyBestFilter row(), prevRow(), rowLen, bpp, bestRow(), workRow(), filterType
rawBuf(rawPos) = filterType
rawPos = rawPos + 1
_MemCopy mBest, mBest.OFFSET, rowLen To mRaw, mRaw.OFFSET + rawPos
rawPos = rawPos + rowLen
_MemCopy mRow, mRow.OFFSET, rowLen To mPrev, mPrev.OFFSET
Next y
_MemFree mRaw
_MemFree mPrev
_MemFree mRow
_MemFree mBest
_MemFree mSrcRow
_MemFree mImg
raw$ = Space$(scanSize)
memBuf = _Mem(rawBuf())
_MemGet memBuf, memBuf.OFFSET, raw$
_MemFree memBuf
comp$ = _Deflate$(raw$)
PNGWriteChunkStr f, "IDAT", comp$
PNGWriteIEND f
Close #f
PNGSaveIndexedMem% = -1
End Function
'
' Filter selection (COMPROMISE):
' Always tries 0/1/2. Skips Average. Tries Paeth only if sample suggests gain.
' Uses abs lookup table (0..255) to avoid branches in hot loop.
'
Sub PNGInitAbsTable
Dim i As Long
For i = 0 To 255
If i < 128 Then
PNGAbsTable(i) = i
Else
PNGAbsTable(i) = 256 - i
End If
Next i
PNGAbsReady = -1
End Sub
Sub PNGApplyBestFilter (row() As _Unsigned _Byte, prevRow() As _Unsigned _Byte, rowLen As Long, bpp As Long, bestRow() As _Unsigned _Byte, workRow() As _Unsigned _Byte, filterType As _Unsigned _Byte)
Dim i As Long
Dim bestSum As Long
Dim sum As Long
Dim diff As Long
Dim left As Long
Dim up As Long
Dim upLeft As Long
Dim pr As Long
Dim sampleSum As Long
Dim approxFull As Long
Dim stepSize As Long
If PNGAbsReady = 0 Then PNGInitAbsTable
bestSum = 2147483647
filterType = 0
' Filter 0 (None)
sum = 0
For i = 0 To rowLen - 1
diff = row(i)
workRow(i) = diff
sum = sum + PNGAbsTable(diff)
Next i
bestSum = sum
filterType = 0
For i = 0 To rowLen - 1
bestRow(i) = workRow(i)
Next i
' Filter 1 (Sub)
sum = 0
For i = 0 To rowLen - 1
If i >= bpp Then left = row(i - bpp) Else left = 0
diff = (row(i) - left) And &HFF
workRow(i) = diff
sum = sum + PNGAbsTable(diff)
Next i
If sum < bestSum Then
bestSum = sum
filterType = 1
For i = 0 To rowLen - 1
bestRow(i) = workRow(i)
Next i
End If
' Filter 2 (Up)
sum = 0
For i = 0 To rowLen - 1
up = prevRow(i)
diff = (row(i) - up) And &HFF
workRow(i) = diff
sum = sum + PNGAbsTable(diff)
Next i
If sum < bestSum Then
bestSum = sum
filterType = 2
For i = 0 To rowLen - 1
bestRow(i) = workRow(i)
Next i
End If
' Filter 4 (Paeth) – only if it looks promising
If bpp >= 3 Then
stepSize = 4
sampleSum = 0
For i = 0 To rowLen - 1 Step stepSize
If i >= bpp Then
left = row(i - bpp)
upLeft = prevRow(i - bpp)
Else
left = 0
upLeft = 0
End If
up = prevRow(i)
pr = PNGPaethPredict&(left, up, upLeft)
diff = (row(i) - pr) And &HFF
sampleSum = sampleSum + PNGAbsTable(diff)
Next i
approxFull = sampleSum * stepSize
' approxFull must look ~8% better than bestSum to pay for full Paeth
If approxFull * 100 < bestSum * 92 Then
sum = 0
For i = 0 To rowLen - 1
If i >= bpp Then
left = row(i - bpp)
upLeft = prevRow(i - bpp)
Else
left = 0
upLeft = 0
End If
up = prevRow(i)
pr = PNGPaethPredict&(left, up, upLeft)
diff = (row(i) - pr) And &HFF
workRow(i) = diff
sum = sum + PNGAbsTable(diff)
Next i
If sum < bestSum Then
bestSum = sum
filterType = 4
For i = 0 To rowLen - 1
bestRow(i) = workRow(i)
Next i
End If
End If
End If
End Sub
Function PNGPaethPredict& (a As Long, b As Long, c As Long)
Dim p As Long
Dim pa As Long, pb As Long, pc As Long
p = a + b - c
pa = p - a: If pa < 0 Then pa = -pa
pb = p - b: If pb < 0 Then pb = -pb
pc = p - c: If pc < 0 Then pc = -pc
If pa <= pb And pa <= pc Then
PNGPaethPredict& = a
ElseIf pb <= pc Then
PNGPaethPredict& = b
Else
PNGPaethPredict& = c
End If
End Function
'
' PNG write: signature / IHDR / chunk / IEND
'
Sub PNGWriteSignature (f As Integer)
Dim sig(0 To 7) As _Unsigned _Byte
sig(0) = &H89
sig(1) = &H50
sig(2) = &H4E
sig(3) = &H47
sig(4) = &HD
sig(5) = &HA
sig(6) = &H1A
sig(7) = &HA
Put #f, , sig()
End Sub
Sub PNGWriteIHDR (f As Integer, w As Long, h As Long, depth As _Unsigned _Byte, colorType As _Unsigned _Byte)
Dim hdr(0 To 12) As _Unsigned _Byte
hdr(0) = (w \ 16777216) And &HFF
hdr(1) = (w \ 65536) And &HFF
hdr(2) = (w \ 256) And &HFF
hdr(3) = w And &HFF
hdr(4) = (h \ 16777216) And &HFF
hdr(5) = (h \ 65536) And &HFF
hdr(6) = (h \ 256) And &HFF
hdr(7) = h And &HFF
hdr(8) = depth
hdr(9) = colorType
hdr(10) = 0
hdr(11) = 0
hdr(12) = 0
PNGWriteChunkBytes f, "IHDR", hdr()
End Sub
Sub PNGWriteIEND (f As Integer)
PNGWriteChunkStr f, "IEND", ""
End Sub
Sub PNGWriteChunkBytes (f As Integer, id As String * 4, datas() As _Unsigned _Byte)
Dim lenData As _Unsigned Long
Dim lenBE As _Unsigned Long
Dim crc As _Unsigned Long
lenData = (UBound(datas) - LBound(datas) + 1)
lenBE = PNGSwapUL~&(lenData)
Put #f, , lenBE
Put #f, , id
Put #f, , datas()
crc = PNGCRCBytes~&(id, datas())
crc = PNGSwapUL~&(crc)
Put #f, , crc
End Sub
Sub PNGWriteChunkStr (f As Integer, id As String * 4, datas As String)
Dim lenData As _Unsigned Long
Dim lenBE As _Unsigned Long
Dim crc As _Unsigned Long
lenData = Len(datas)
lenBE = PNGSwapUL~&(lenData)
Put #f, , lenBE
Put #f, , id
If lenData > 0 Then Put #f, , datas
crc = PNGCRCString~&(id, datas)
crc = PNGSwapUL~&(crc)
Put #f, , crc
End Sub
Function PNGSwapUL~& (x As _Unsigned Long)
Dim b0 As _Unsigned Long, b1 As _Unsigned Long, b2 As _Unsigned Long, b3 As _Unsigned Long
b0 = (x And &HFF~&)
b1 = (x \ 256) And &HFF~&
b2 = (x \ 65536) And &HFF~&
b3 = (x \ 16777216) And &HFF~&
PNGSwapUL~& = b0 * 16777216~& + b1 * 65536~& + b2 * 256~& + b3
End Function
'
' CRC (fast)
'
Sub PNGMakeCRCTable
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 k
PNGCRC_table(n) = c
Next n
PNGCRC_table_computed = 1
End Sub
Sub PNGCRCUpdateByte (crc As _Unsigned Long, b As _Unsigned _Byte)
If PNGCRC_table_computed = 0 Then PNGMakeCRCTable
crc = PNGCRC_table((crc Xor b) And &HFF) Xor (crc \ 256)
End Sub
Function PNGCRCBytes~& (id As String * 4, datas() As _Unsigned _Byte)
Dim crc As _Unsigned Long
Dim i As Long
Dim b As _Unsigned _Byte
crc = &HFFFFFFFF~&
For i = 1 To 4
b = Asc(id, i)
PNGCRCUpdateByte crc, b
Next i
For i = LBound(datas) To UBound(datas)
PNGCRCUpdateByte crc, datas(i)
Next i
PNGCRCBytes~& = Not crc
End Function
Function PNGCRCString~& (id As String * 4, datas As String)
Dim crc As _Unsigned Long
Dim i As Long
Dim b As _Unsigned _Byte
Dim n As Long
crc = &HFFFFFFFF~&
For i = 1 To 4
b = Asc(id, i)
PNGCRCUpdateByte crc, b
Next i
n = Len(datas)
For i = 1 To n
b = Asc(datas, i)
PNGCRCUpdateByte crc, b
Next i
PNGCRCString~& = Not crc
End Function