203 lines
6.8 KiB
Text
203 lines
6.8 KiB
Text
|
|
Sub SaveBinaryPPM (imageHandle As Long, fileName As String)
|
|
Dim r As _Unsigned _Byte
|
|
Dim g As _Unsigned _Byte
|
|
Dim b As _Unsigned _Byte
|
|
Dim fileHandle As Integer
|
|
Dim w As _Unsigned Long
|
|
Dim h As _Unsigned Long
|
|
Dim head As String
|
|
Dim fileout As String
|
|
Dim image As _MEM
|
|
Dim filebuffer As _MEM
|
|
Dim inPosition As _Offset
|
|
Dim outPosition As _Offset
|
|
Dim length As _Offset
|
|
image = _MemImage(imageHandle)
|
|
inPosition = image.OFFSET
|
|
w = _Width(imageHandle)
|
|
h = _Height(imageHandle)
|
|
length = inPosition + w * h * 4
|
|
head = "P6" + Chr$(10)
|
|
head = head + "# Created with QB64" + Chr$(10)
|
|
head = head + LTrim$(str$(w) + tst(h)) + Chr$(10)
|
|
head = head + "255" + Chr$(10)
|
|
filebuffer = _MemNew(w * h * 3)
|
|
outPosition = filebuffer.OFFSET
|
|
Do
|
|
b = _MemGet(image, inPosition, _Unsigned _Byte)
|
|
g = _MemGet(image, inPosition + 1, _Unsigned _Byte)
|
|
r = _MemGet(image, inPosition + 2, _Unsigned _Byte)
|
|
_MemPut filebuffer, outPosition, r As _UNSIGNED _BYTE
|
|
_MemPut filebuffer, outPosition + 1, g As _UNSIGNED _BYTE
|
|
_MemPut filebuffer, outPosition + 2, b As _UNSIGNED _BYTE
|
|
inPosition = inPosition + 4
|
|
outPosition = outPosition + 3
|
|
Loop Until inPosition = length
|
|
fileout = Space$(w * h * 3)
|
|
_MemGet filebuffer, filebuffer.OFFSET, fileout
|
|
fileHandle = FreeFile
|
|
Open fileName For Binary As fileHandle
|
|
Put fileHandle, , head
|
|
Put fileHandle, , fileout
|
|
Close fileHandle
|
|
_MemFree image
|
|
_MemFree filebuffer
|
|
End Sub
|
|
|
|
Sub save24bitBmp (imageHandle As Long, fileName As String)
|
|
Dim oSource As Long
|
|
Dim ff As Long
|
|
Dim x As Long, y As Long
|
|
Dim header As String * 54
|
|
Dim outBytes As String * 3
|
|
Dim padding As String
|
|
oSource = _Source
|
|
_Source imageHandle
|
|
|
|
header = "BM" + MKL$(_Width * _Height * 3 + 54) +_
|
|
String$(4, 0) + MKL$(54) + MKL$(40) +_
|
|
MKL$(_Width) + MKL$(_Height) +_
|
|
MKI$(1) + MKI$(24) + MKL$(0) + MKL$(0) +_
|
|
MKL$(11811) + MKL$(11811) + MKL$(0) + MKL$(0)
|
|
|
|
If ((_Width * 3) Mod 4) Then padding$ = String$(4 - ((_width * 3) Mod 4), 0)
|
|
|
|
ff = FreeFile
|
|
Open fileName For Binary As ff
|
|
Put ff, , header
|
|
For y = _Height - 1 To 0 Step -1
|
|
For x = 0 To _Width - 1
|
|
outBytes = Left$(MKL$(Point(x, y)), 3)
|
|
Put #ff, , outBytes
|
|
Next
|
|
put #ff, , padding
|
|
Next
|
|
Close ff
|
|
_Source oSource
|
|
End Sub
|
|
|
|
Sub save8bitPNG (imagehandle As Long, filename As String)
|
|
Dim PngHeader As String
|
|
Dim IHDR As String
|
|
Dim IDAT As String
|
|
Dim IEND As String
|
|
Dim PLTE As String
|
|
Dim x As _Unsigned Long, y As _Unsigned Long
|
|
Dim colorvalue As _Unsigned Long
|
|
Dim chunksize As String
|
|
Dim ff As Long
|
|
Dim imageData As String
|
|
dim sourceMem as _mem
|
|
dim c As _Unsigned _byte
|
|
sourceMem = _memimage(imagehandle)
|
|
PngHeader = chr$(137) + "PNG" + Chr$(13) + Chr$(10) + Chr$(26) + Chr$(10)
|
|
IHDR = "IHDR" + MKL$(FlipBytes(_Width(imagehandle))) + MKL$(FlipBytes(_Height(imagehandle))) + Chr$(8) + Chr$(3) + String$(3, 0)
|
|
IHDR = MKL$(FlipBytes(&H0D)) + IHDR + MKL$(FlipBytes(crc32(IHDR)))
|
|
IEND = MKL$(0) + "IEND" + MKL$(FlipBytes(&HAE426082))
|
|
PLTE = "PLTE"
|
|
for c = 0 to 255
|
|
PLTE = PLTE + chr$(_Red32(_PaletteColor(c)))
|
|
PLTE = PLTE + chr$(_Green32(_PaletteColor(c)))
|
|
PLTE = PLTE + chr$(_Blue32(_PaletteColor(c)))
|
|
Next
|
|
PLTE = mkl$(FlipBytes(256 * 3)) + PLTE + MKL$(FlipBytes(crc32(PLTE)))
|
|
|
|
imageData = string$(_Height(imagehandle) * _Width(imagehandle) + _Height(imagehandle), 0)
|
|
|
|
For y = 0 To _Height(imagehandle) - 1
|
|
For x = 0 To _Width(imagehandle) - 1
|
|
c = _memget(sourceMem, sourceMem.OFFSET + bytecount + 0, _Unsigned _byte)
|
|
asc(imageData,bytecount + y + 2) = c
|
|
bytecount = bytecount + 1
|
|
Next x
|
|
Next y
|
|
_memfree sourceMem
|
|
IDAT = _Deflate$(imageData)
|
|
chunksize = MKL$(FlipBytes(Len(IDAT)))
|
|
IDAT = "IDAT" + IDAT
|
|
IDAT = IDAT + MKL$(FlipBytes(crc32(IDAT)))
|
|
IDAT = chunksize + IDAT
|
|
ff = FreeFile
|
|
Open filename For Output As ff: Close ff
|
|
Open filename For Binary As ff
|
|
Put ff, , PngHeader
|
|
Put ff, , IHDR
|
|
put ff, , PLTE
|
|
Put ff, , IDAT
|
|
Put ff, , IEND
|
|
Close ff
|
|
End Sub
|
|
|
|
Sub save32bitPNG (imagehandle As Long, filename As String)
|
|
Dim PngHeader As String
|
|
Dim IHDR As String
|
|
Dim IDAT As String
|
|
Dim IEND As String
|
|
Dim x As _Unsigned Long, y As _Unsigned Long
|
|
Dim colorvalue As _Unsigned Long
|
|
Dim chunksize As String
|
|
Dim ff As Long
|
|
Dim imageData As String
|
|
dim sourceMem as _mem
|
|
dim as _Unsigned _byte r, g, b
|
|
sourceMem = _memimage(imagehandle)
|
|
PngHeader = chr$(137) + "PNG" + Chr$(13) + Chr$(10) + Chr$(26) + Chr$(10)
|
|
IHDR = "IHDR" + MKL$(FlipBytes(_Width(imagehandle))) + MKL$(FlipBytes(_Height(imagehandle))) + Chr$(8) + Chr$(6) + String$(3, 0)
|
|
IHDR = MKL$(FlipBytes(&H0D)) + IHDR + MKL$(FlipBytes(crc32(IHDR)))
|
|
IEND = MKL$(0) + "IEND" + MKL$(FlipBytes(&HAE426082))
|
|
imageData = string$(_Height(imagehandle) * _Width(imagehandle) * 4 + _Height(imagehandle), 0)
|
|
|
|
For y = 0 To _Height(imagehandle) - 1
|
|
For x = 0 To _Width(imagehandle) - 1
|
|
b = _memget(sourceMem, sourceMem.OFFSET + bytecount + 0, _Unsigned _byte)
|
|
g = _memget(sourceMem, sourceMem.OFFSET + bytecount + 1, _Unsigned _byte)
|
|
r = _memget(sourceMem, sourceMem.OFFSET + bytecount + 2, _Unsigned _byte)
|
|
a = _memget(sourceMem, sourceMem.OFFSET + bytecount + 3, _Unsigned _byte)
|
|
|
|
asc(imageData,bytecount + y + 2) = r
|
|
asc(imageData,bytecount + y + 3) = g
|
|
asc(imageData,bytecount + y + 4) = b
|
|
asc(imageData,bytecount + y + 5) = a
|
|
bytecount = bytecount + 4
|
|
Next x
|
|
Next y
|
|
_memfree sourceMem
|
|
IDAT = _Deflate$(imageData)
|
|
chunksize = MKL$(FlipBytes(Len(IDAT)))
|
|
IDAT = "IDAT" + IDAT
|
|
IDAT = IDAT + MKL$(FlipBytes(crc32(IDAT)))
|
|
IDAT = chunksize + IDAT
|
|
ff = FreeFile
|
|
Open filename For Output As ff: Close ff
|
|
Open filename For Binary As ff
|
|
Put ff, , PngHeader
|
|
Put ff, , IHDR
|
|
Put ff, , IDAT
|
|
Put ff, , IEND
|
|
Close ff
|
|
End Sub
|
|
|
|
Function FlipBytes~& (value As _Unsigned Long)
|
|
FlipBytes~& = (value \ 16777216)_
|
|
Or (value * 16777216)_
|
|
Or ((value And 16711680) \ 256)_
|
|
Or ((value And 65280) * 256)
|
|
End Function
|
|
|
|
Function crc32~& (IN$)
|
|
Dim As _Unsigned Long CRC32_POLY, CRC
|
|
CRC32_POLY = &HEDB88320
|
|
CRC = &HFFFFFFFF
|
|
For I = 1 To Len(IN$)
|
|
CRC = CRC Xor Asc(IN$, I)
|
|
For J = 1 To 8
|
|
If CRC And 1 Then
|
|
CRC = (CRC \ 2) Xor CRC32_POLY
|
|
Else
|
|
CRC = CRC \ 2
|
|
End If
|
|
Next J
|
|
Next I
|
|
crc32~& = Not CRC
|
|
End Function
|