This is the "SaveImage" routine from the Wiki, changed by me to try to make it faster, but it seems to be a failure with big pictures. For stuff larger than 1920x1080 might have to set even greater string buffers for "d$" and "r$". It was quite fast on my old Toshiba laptop purchased in December 2006 with 1024x768 resolution.
The "DIM" declarations are to ensure it works in "OPTION _EXPLICIT" mode.
!Needs testing!
The "DIM" declarations are to ensure it works in "OPTION _EXPLICIT" mode.
!Needs testing!
Code: (Select All)
''from QB64 wiki
''modifications by mnrvovrfc
''this uses MID$() in replacement up to greatly speed up
'' the reading of the screen,
'' it avoids concatenation of strings as much as possible
'' which is notoriously slow when millions of bytes are involved
Sub SaveImage (image As Long, filename As String)
Dim ld As Long, lr As Long, lx As Long
Dim bytesperpixel&, bpp&, lastsource&, px&, py&, cv&, c&, f&, x&, y&, b$, d$, r$, padder$, rrr$, filename2$
bytesperpixel& = _PixelSize(image&)
If bytesperpixel& = 0 Then Print "Text modes unsupported!": End
If bytesperpixel& = 1 Then bpp& = 8 Else bpp& = 24
x& = _Width(image&)
y& = _Height(image&)
b$ = "BM????QB64????" + MKL$(40) + MKL$(x&) + MKL$(y&) + MKI$(1) + MKI$(bpp&) + MKL$(0) + "????" + String$(16, 0) 'partial BMP header info(???? to be filled later)
If bytesperpixel& = 1 Then
For c& = 0 To 255 ' read BGR color settings from JPG image + 1 byte spacer(CHR$(0))
cv& = _PaletteColor(c&, image&) ' color attribute to read.
b$ = b$ + Chr$(_Blue32(cv&)) + Chr$(_Green32(cv&)) + Chr$(_Red32(cv&)) + Chr$(0) 'spacer byte
Next
End If
Mid$(b$, 11, 4) = MKL$(Len(b$)) ' image pixel data offset(BMP header)
d$ = Space$(50000000)
ld = 1
lastsource& = _Source
_Source image&
If ((x& * 3) Mod 4) Then padder$ = String$(4 - ((x& * 3) Mod 4), 0)
For py& = y& - 1 To 0 Step -1 ' read JPG image pixel color data
r$ = Space$(10000000)
lr = 1
For px& = 0 To x& - 1
c& = Point(px&, py&) 'POINT 32 bit values are large LONG values
If bytesperpixel& = 1 Then
rrr$ = Chr$(c&)
Else
rrr$ = Left$(MKL$(c&), 3)
End If
lx = Len(rrr$)
Mid$(r$, lr, lx) = rrr$
lr = lr + lx
Next px&
r$ = Left$(r$, lr - 1)
rrr$ = r$ + padder$
lx = Len(rrr$)
Mid$(d$, ld, lx) = rrr$
ld = ld + lx
Next py&
_Source lastsource&
d$ = Left$(d$, ld - 1)
Mid$(b$, 35, 4) = MKL$(Len(d$)) ' image size(BMP header)
Mid$(b$, 3, 4) = MKL$(Len(b$) + Len(d$)) ' size of data file(BMP header)
filename2$ = filename$
If LCase$(Right$(filename$, 4)) <> ".bmp" Then filename2$ = filename$ + ".bmp"
f& = FreeFile
Open filename2$ For Output As #f&: Close #f& ' erases an existing file
Open filename2$ For Binary As #f&
Put #f&, , b$
Put #f&, , d$
Close #f&
End Sub