paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-09 20:49:35 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ Added jpeg support via jpeglib

Browse Source
This commit is contained in:
michael 2004-02-07 23:17:59 +00:00
parent 456433d7d2
commit 32e3cf93ee
4 changed files with 549 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
fcl/image/Makefile
View File

@ -1,8 +1,8 @@
#
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/01/05]
# Don't edit, this file is generated by FPCMake Version 1.1 [2003/09/24]
#
default: all
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx
override PATH:=$(subst \,/,$(PATH))
ifeq ($(findstring ;,$(PATH)),)
inUnix=1
@ -10,7 +10,6 @@ SEARCHPATH:=$(filter-out .,$(subst :, ,$(PATH)))
else
SEARCHPATH:=$(subst ;, ,$(PATH))
endif
SEARCHPATH+=$(patsubst %/,%,$(subst \,/,$(dir $(MAKE))))
PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(SEARCHPATH))))
ifeq ($(PWD),)
PWD:=$(strip $(wildcard $(addsuffix /pwd,$(SEARCHPATH))))
@ -205,7 +204,7 @@ UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
endif
PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
override PACKAGE_NAME=fcl
override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm ellipses
override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg.pas fpwritejpeg.pas ellipses
ifeq ($(OS_TARGET),linux)
override TARGET_UNITS+=freetypeh freetype ftfont
endif
@ -301,17 +300,9 @@ endif
endif
ifndef INSTALL_BINDIR
ifdef UNIXINSTALLDIR
ifdef CROSSCOMPILE
INSTALL_BINDIR:=$(INSTALL_BASEDIR)/cross/$(FULL_TARGET)/bin
else
INSTALL_BINDIR:=$(INSTALL_PREFIX)/bin
endif
else
ifdef CROSSCOMPILE
INSTALL_BINDIR:=$(INSTALL_BASEDIR)/cross/$(FULL_TARGET)/bin
else
INSTALL_BINDIR:=$(INSTALL_BASEDIR)/bin
endif
ifdef INSTALL_FPCPACKAGE
INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(OS_TARGET)
endif
@ -443,14 +434,6 @@ STATICLIBPREFIX=
FPCMADE=fpcmade.dos
ZIPSUFFIX=go32
endif
ifeq ($(OS_TARGET),watcom)
STATICLIBPREFIX=
FPCMADE=fpcmade.wat
ZIPSUFFIX=watc
OEXT=.obj
ASMEXT=.asm
SHAREDLIBEXT=.dll
endif
ifeq ($(OS_TARGET),linux)
EXEEXT=
HASSHAREDLIB=1
@ -553,11 +536,6 @@ STATICLIBPREFIX=
FPCMADE=fpcmade.dos
ZIPSUFFIX=go32
endif
ifeq ($(OS_TARGET),watcom)
STATICLIBPREFIX=
FPCMADE=fpcmade.dos
ZIPSUFFIX=watcom
endif
ifeq ($(OS_TARGET),linux)
EXEEXT=
HASSHAREDLIB=1
@ -746,11 +724,7 @@ endif
endif
export MVPROG
ifndef ECHOREDIR
ifndef inUnix
ECHOREDIR=echo
else
ECHOREDIR=$(ECHO)
endif
ECHOREDIR:=$(subst /,$(PATHSEP),$(ECHO))
endif
ifndef COPY
COPY:=$(CPPROG) -fp
@ -821,16 +795,14 @@ TARPROG:=$(firstword $(TARPROG))
endif
endif
export TARPROG
ASNAME=$(BINUTILSPREFIX)as
LDNAME=$(BINUTILSPREFIX)ld
ARNAME=$(BINUTILSPREFIX)ar
RCNAME=$(BINUTILSPREFIX)rc
ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
ifeq ($(OS_TARGET),win32)
ASNAME=as
LDNAME=ld
ARNAME=ar
endif
RCNAME=rc
ifeq ($(OS_TARGET),win32)
ASNAME=asw
LDNAME=ldw
ARNAME=arw
endif
ifndef ASPROG
ifdef CROSSBINDIR
@ -982,18 +954,6 @@ REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
endif
endif
ifeq ($(OS_TARGET),netbsd)
ifeq ($(CPU_TARGET),powerpc)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
endif
endif
ifeq ($(OS_TARGET),netbsd)
ifeq ($(CPU_TARGET),sparc)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
endif
endif
ifeq ($(OS_TARGET),amiga)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
@ -1072,12 +1032,6 @@ REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
endif
endif
ifeq ($(OS_TARGET),watcom)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
endif
endif
ifdef REQUIRE_PACKAGES_RTL
PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/$(OS_TARGET)/Makefile.fpc,$(PACKAGESDIR))))))
ifneq ($(PACKAGEDIR_RTL),)
@ -1139,14 +1093,6 @@ endif
ifeq ($(OS_SOURCE),openbsd)
override FPCOPT+=-FD$(NEW_BINUTILS_PATH)
endif
ifndef CROSSBOOTSTRAP
ifneq ($(BINUTILSPREFIX),)
override FPCOPT+=-XP$(BINUTILSPREFIX) -Xc
endif
ifneq ($(BINUTILSPREFIX),)
override FPCOPT+=-Xr$(RLINKPATH)
endif
endif
ifdef UNITDIR
override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
endif
@ -1271,7 +1217,7 @@ endif
.PHONY: fpc_examples
ifdef TARGET_EXAMPLES
HASEXAMPLES=1
override EXAMPLESOURCEFILES:=$(wildcard $(addsuffix .pp,$(TARGET_EXAMPLES)) $(addsuffix .pas,$(TARGET_EXAMPLES)) $(addsuffix .dpr,$(TARGET_EXAMPLES)))
override EXAMPLESOURCEFILES:=$(wildcard $(addsuffix .pp,$(TARGET_EXAMPLES)) $(addsuffix .pas,$(TARGET_EXAMPLES)))
override EXAMPLEFILES:=$(addsuffix $(EXEEXT),$(TARGET_EXAMPLES))
override EXAMPLEOFILES:=$(addsuffix $(OEXT),$(TARGET_EXAMPLES)) $(addprefix $(STATICLIBPREFIX),$(addsuffix $(STATICLIBEXT),$(TARGET_EXAMPLES)))
override CLEANEXEFILES+=$(EXAMPLEFILES) $(EXAMPLEOFILES)
@ -1296,7 +1242,7 @@ fpc_debug:
$(MAKE) all DEBUG=1
fpc_release:
$(MAKE) all RELEASE=1
.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .dpr .pp .rc .res
.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp .rc .res
%$(PPUEXT): %.pp
$(COMPILER) $<
$(EXECPPAS)
@ -1309,14 +1255,10 @@ fpc_release:
%$(EXEEXT): %.pas
$(COMPILER) $<
$(EXECPPAS)
%$(EXEEXT): %.dpr
$(COMPILER) $<
$(EXECPPAS)
%.res: %.rc
windres -i $< -o $@
vpath %.pp $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
vpath %.pas $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
vpath %.dpr $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
vpath %$(PPUEXT) $(COMPILER_UNITTARGETDIR)
.PHONY: fpc_install fpc_sourceinstall fpc_exampleinstall
ifdef INSTALL_UNITS

2
fcl/image/Makefile.fpc
View File

@ -11,7 +11,7 @@ packages=paszlib
[target]
units=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm \
clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp \
fpreadbmp bmpcomn fpreadpnm fpwritepnm \
fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg.pas fpwritejpeg.pas \
ellipses
units_win32=freetypeh freetype ftfont
units_linux=freetypeh freetype ftfont

317
fcl/image/fpreadjpeg.pas Normal file
View File

@ -0,0 +1,317 @@
{ Copyright (C) 2003 Mattias Gaertner
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
ToDo:
- grayscale
- palette
}
unit FPReadJPEG;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FPImage, JPEGLib, JdAPImin, JDataSrc, JdAPIstd, JmoreCfg;
type
{ TFPReaderJPEG }
{ This is a FPImage reader for jpeg images. }
TFPReaderJPEG = class;
PFPJPEGProgressManager = ^TFPJPEGProgressManager;
TFPJPEGProgressManager = record
pub : jpeg_progress_mgr;
instance: TObject;
last_pass: Integer;
last_pct: Integer;
last_time: Integer;
last_scanline: Integer;
end;
TJPEGScale = (jsFullSize, jsHalf, jsQuarter, jsEighth);
TJPEGReadPerformance = (jpBestQuality, jpBestSpeed);
TFPReaderJPEG = class(TFPCustomImageReader)
private
FSmoothing: boolean;
FWidth: Integer;
FHeight: Integer;
FGrayscale: boolean;
FProgressiveEncoding: boolean;
FError: jpeg_error_mgr;
FProgressMgr: TFPJPEGProgressManager;
FInfo: jpeg_decompress_struct;
FScale: TJPEGScale;
FPerformance: TJPEGReadPerformance;
procedure SetPerformance(const AValue: TJPEGReadPerformance);
procedure SetSmoothing(const AValue: boolean);
protected
procedure InternalRead(Str: TStream; Img: TFPCustomImage); override;
function InternalCheck(Str: TStream): boolean; override;
public
constructor Create; override;
destructor Destroy; override;
property GrayScale: boolean read FGrayscale;
property ProgressiveEncoding: boolean read FProgressiveEncoding;
property Smoothing: boolean read FSmoothing write SetSmoothing;
property Performance: TJPEGReadPerformance read FPerformance write SetPerformance;
end;
implementation
procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
StartSize: integer);
var
NewLength: Integer;
ReadLen: Integer;
Buffer: string;
begin
if (SrcStream is TMemoryStream) or (SrcStream is TFileStream)
or (SrcStream is TStringStream)
then begin
// read as one block
DestStream.CopyFrom(SrcStream,SrcStream.Size-SrcStream.Position);
end else begin
// read exponential
if StartSize<=0 then StartSize:=1024;
SetLength(Buffer,StartSize);
NewLength:=0;
repeat
ReadLen:=SrcStream.Read(Buffer[NewLength+1],length(Buffer)-NewLength);
inc(NewLength,ReadLen);
if NewLength<length(Buffer) then break;
SetLength(Buffer,length(Buffer)*2);
until false;
if NewLength>0 then
DestStream.Write(Buffer[1],NewLength);
end;
end;
procedure JPEGError(CurInfo: j_common_ptr);
begin
if CurInfo=nil then exit;
writeln('JPEGError ',CurInfo^.err^.msg_code,' ');
raise Exception.CreateFmt('JPEG error',[CurInfo^.err^.msg_code]);
end;
procedure EmitMessage(CurInfo: j_common_ptr; msg_level: Integer);
begin
if CurInfo=nil then exit;
if msg_level=0 then ;
end;
procedure OutputMessage(CurInfo: j_common_ptr);
begin
if CurInfo=nil then exit;
end;
procedure FormatMessage(CurInfo: j_common_ptr; var buffer: string);
begin
if CurInfo=nil then exit;
writeln('FormatMessage ',buffer);
end;
procedure ResetErrorMgr(CurInfo: j_common_ptr);
begin
if CurInfo=nil then exit;
CurInfo^.err^.num_warnings := 0;
CurInfo^.err^.msg_code := 0;
end;
var
jpeg_std_error: jpeg_error_mgr;
procedure ProgressCallback(CurInfo: j_common_ptr);
begin
if CurInfo=nil then exit;
// ToDo
end;
{ TFPReaderJPEG }
procedure TFPReaderJPEG.SetSmoothing(const AValue: boolean);
begin
if FSmoothing=AValue then exit;
FSmoothing:=AValue;
end;
procedure TFPReaderJPEG.SetPerformance(const AValue: TJPEGReadPerformance);
begin
if FPerformance=AValue then exit;
FPerformance:=AValue;
end;
procedure TFPReaderJPEG.InternalRead(Str: TStream; Img: TFPCustomImage);
var
MemStream: TMemoryStream;
procedure SetSource;
begin
MemStream.Position:=0;
jpeg_stdio_src(@FInfo, @MemStream);
end;
procedure ReadHeader;
begin
jpeg_read_header(@FInfo, TRUE);
FWidth := FInfo.image_width;
FHeight := FInfo.image_height;
FGrayscale := FInfo.jpeg_color_space = JCS_GRAYSCALE;
FProgressiveEncoding := jpeg_has_multiple_scans(@FInfo);
end;
procedure InitReadingPixels;
begin
FInfo.scale_num := 1;
FInfo.scale_denom := 1;// shl Byte(FScale);
FInfo.do_block_smoothing := FSmoothing;
if FGrayscale then FInfo.out_color_space := JCS_GRAYSCALE;
if (FInfo.out_color_space = JCS_GRAYSCALE) then begin
FInfo.quantize_colors := True;
FInfo.desired_number_of_colors := 236;
end;
if FPerformance = jpBestSpeed then begin
FInfo.dct_method := JDCT_IFAST;
FInfo.two_pass_quantize := False;
FInfo.dither_mode := JDITHER_ORDERED;
// FInfo.do_fancy_upsampling := False; can create an AV inside jpeglib
end;
if FProgressiveEncoding then begin
FInfo.enable_2pass_quant := FInfo.two_pass_quantize;
FInfo.buffered_image := True;
end;
end;
procedure ReadPixels;
var
Continue: Boolean;
SampArray: JSAMPARRAY;
SampRow: JSAMPROW;
Color: TFPColor;
LinesRead: Cardinal;
x: Integer;
y: Integer;
begin
InitReadingPixels;
Continue:=true;
Progress(psStarting, 0, False, Rect(0,0,0,0), '', Continue);
if not Continue then exit;
jpeg_start_decompress(@FInfo);
Img.SetSize(FInfo.output_width,FInfo.output_height);
// read one line per call
GetMem(SampArray,SizeOf(JSAMPROW));
GetMem(SampRow,FInfo.output_width*FInfo.output_components);
SampArray^[0]:=SampRow;
try
Color.Alpha:=alphaOpaque;
y:=0;
while (FInfo.output_scanline < FInfo.output_height) do begin
LinesRead := jpeg_read_scanlines(@FInfo, SampArray, 1);
if LinesRead<1 then break;
for x:=0 to FInfo.output_width-1 do begin
Color.Red:=SampRow^[x*3+0] shl 8;
Color.Green:=SampRow^[x*3+1] shl 8;
Color.Blue:=SampRow^[x*3+2] shl 8;
Img.Colors[x,y]:=Color;
end;
inc(y);
end;
finally
FreeMem(SampRow);
FreeMem(SampArray);
end;
if FInfo.buffered_image then jpeg_finish_output(@FInfo);
jpeg_finish_decompress(@FInfo);
Progress(psEnding, 100, false, Rect(0,0,0,0), '', Continue);
end;
begin
FWidth:=0;
FHeight:=0;
MemStream:=nil;
FillChar(FInfo,SizeOf(FInfo),0);
try
if Str is TMemoryStream then
MemStream:=TMemoryStream(Str)
else begin
MemStream:=TMemoryStream.Create;
ReadCompleteStreamToStream(Str,MemStream,1024);
MemStream.Position:=0;
end;
if MemStream.Size > 0 then begin
FError:=jpeg_std_error;
FInfo.err := @FError;
jpeg_CreateDecompress(@FInfo, JPEG_LIB_VERSION, SizeOf(FInfo));
try
FProgressMgr.pub.progress_monitor := @ProgressCallback;
FProgressMgr.instance := Self;
FInfo.progress := @FProgressMgr;
SetSource;
ReadHeader;
ReadPixels;
finally
jpeg_Destroy_Decompress(@FInfo);
end;
end;
finally
if (MemStream<>nil) and (MemStream<>Str) then
MemStream.Free;
end;
end;
function TFPReaderJPEG.InternalCheck(Str: TStream): boolean;
begin
// ToDo: read header and check
Result:=false;
if Str=nil then exit;
Result:=true;
end;
constructor TFPReaderJPEG.Create;
begin
FScale:=jsFullSize;
FPerformance:=jpBestSpeed;
inherited Create;
end;
destructor TFPReaderJPEG.Destroy;
begin
inherited Destroy;
end;
initialization
with jpeg_std_error do begin
error_exit:=@JPEGError;
emit_message:=@EmitMessage;
output_message:=@OutputMessage;
format_message:=@FormatMessage;
reset_error_mgr:=@ResetErrorMgr;
end;
end.

220
fcl/image/fpwritejpeg.pas Normal file
View File

@ -0,0 +1,220 @@
{ Copyright (C) 2003 Mattias Gaertner
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit FPWriteJPEG;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FPImage, JPEGLib, FPReadJPEG, JcAPIstd, JcAPImin, JDataDst,
JcParam, JError;
type
{ TFPWriterJPEG }
TFPJPEGCompressionQuality = 1..100; // 100 = best quality, 25 = pretty awful
TFPWriterJPEG = class(TFPCustomImageWriter)
private
FGrayscale: boolean;
FInfo: jpeg_compress_struct;
FError: jpeg_error_mgr;
FProgressiveEncoding: boolean;
FQuality: TFPJPEGCompressionQuality;
FProgressMgr: TFPJPEGProgressManager;
protected
procedure InternalWrite(Str: TStream; Img: TFPCustomImage); override;
public
constructor Create; override;
destructor Destroy; override;
property CompressionQuality: TFPJPEGCompressionQuality read FQuality write FQuality;
property ProgressiveEncoding: boolean read FProgressiveEncoding write FProgressiveEncoding;
property GrayScale: boolean read FGrayscale;
end;
implementation
procedure JPEGError(CurInfo: j_common_ptr);
begin
if CurInfo=nil then exit;
writeln('JPEGError ',CurInfo^.err^.msg_code,' ');
raise Exception.CreateFmt('JPEG error',[CurInfo^.err^.msg_code]);
end;
procedure EmitMessage(CurInfo: j_common_ptr; msg_level: Integer);
begin
if CurInfo=nil then exit;
if msg_level=0 then ;
end;
procedure OutputMessage(CurInfo: j_common_ptr);
begin
if CurInfo=nil then exit;
end;
procedure FormatMessage(CurInfo: j_common_ptr; var buffer: string);
begin
if CurInfo=nil then exit;
writeln('FormatMessage ',buffer);
end;
procedure ResetErrorMgr(CurInfo: j_common_ptr);
begin
if CurInfo=nil then exit;
CurInfo^.err^.num_warnings := 0;
CurInfo^.err^.msg_code := 0;
end;
var
jpeg_std_error: jpeg_error_mgr;
procedure ProgressCallback(CurInfo: j_common_ptr);
begin
if CurInfo=nil then exit;
// ToDo
end;
{ TFPWriterJPEG }
procedure TFPWriterJPEG.InternalWrite(Str: TStream; Img: TFPCustomImage);
var
MemStream: TMemoryStream;
Continue: Boolean;
procedure InitWriting;
begin
FillChar(FInfo, sizeof(FInfo), 0);
FError := jpeg_std_error;
FInfo.err := jerror.jpeg_std_error(FError);
jpeg_create_compress(@FInfo);
FProgressMgr.pub.progress_monitor := @ProgressCallback;
FProgressMgr.instance := Self;
FInfo.progress := @FProgressMgr;
end;
procedure SetDestination;
begin
if Str is TMemoryStream then
MemStream:=TMemoryStream(Str)
else
MemStream := TMemoryStream.Create;
jpeg_stdio_dest(@FInfo, @MemStream);
end;
procedure WriteHeader;
begin
FInfo.image_width := Img.Width;
FInfo.image_height := Img.Height;
FInfo.input_components := 3; // RGB has 3 components
FInfo.in_color_space := JCS_RGB;
if FGrayscale then
jpeg_set_colorspace(@FInfo, JCS_GRAYSCALE);
jpeg_set_defaults(@FInfo);
jpeg_set_quality(@FInfo, FQuality, True);
if ProgressiveEncoding then
jpeg_simple_progression(@FInfo);
end;
procedure WritePixels;
var
LinesWritten: Cardinal;
SampArray: JSAMPARRAY;
SampRow: JSAMPROW;
Color: TFPColor;
x: Integer;
y: Integer;
begin
Progress(psStarting, 0, False, Rect(0,0,0,0), '', Continue);
if not Continue then exit;
jpeg_start_compress(@FInfo, True);
// write one line per call
GetMem(SampArray,SizeOf(JSAMPROW));
GetMem(SampRow,FInfo.image_width*FInfo.input_components);
SampArray^[0]:=SampRow;
try
y:=0;
while (FInfo.next_scanline < FInfo.image_height) do begin
for x:=0 to FInfo.image_width-1 do begin
Color:=Img.Colors[x,y];
SampRow^[x*3+0]:=Color.Red shr 8;
SampRow^[x*3+1]:=Color.Green shr 8;
SampRow^[x*3+2]:=Color.Blue shr 8;
end;
LinesWritten := jpeg_write_scanlines(@FInfo, SampArray, 1);
if LinesWritten<1 then break;
inc(y);
end;
finally
FreeMem(SampRow);
FreeMem(SampArray);
end;
jpeg_finish_compress(@FInfo);
Progress(psEnding, 100, False, Rect(0,0,0,0), '', Continue);
end;
procedure EndWriting;
begin
jpeg_destroy_compress(@FInfo);
end;
begin
Continue := true;
MemStream:=nil;
try
InitWriting;
SetDestination;
WriteHeader;
WritePixels;
if MemStream<>Str then begin
MemStream.Position:=0;
Str.CopyFrom(MemStream,MemStream.Size);
end;
finally
EndWriting;
if MemStream<>Str then
MemStream.Free;
end;
end;
constructor TFPWriterJPEG.Create;
begin
inherited Create;
FQuality:=75;
end;
destructor TFPWriterJPEG.Destroy;
begin
inherited Destroy;
end;
initialization
with jpeg_std_error do begin
error_exit:=@JPEGError;
emit_message:=@EmitMessage;
output_message:=@OutputMessage;
format_message:=@FormatMessage;
reset_error_mgr:=@ResetErrorMgr;
end;
end.