function TFPrintOptions.SaveImageDPI(
const vstrImagePath:
String;
const vpntImage: TPicture;
const dpiResolution: Single = 300.0;
const compressionQuality: Integer = 100): Boolean;
//save bmp/png/jpeg/tiff with DPI information, jpeg with compression level
var
strDateiendung:
string;
pntBitmap: TBitmap;
Bitmap: TGPBitmap;
clsidEncoder: TGUID;
EncoderResult: Integer;
EncoderParameters: TEncoderParameters;
QualityUL: ULONG;
IsJpeg: Boolean;
function GetEncoder(
const AFileExt:
string;
out pClsid: TGUID): Integer;
begin
Result := -1;
if AFileExt = '
.BMP'
then
begin
Result := GetEncoderClsid('
image/bmp', pClsid)
end
else if AFileExt = '
.PNG'
then
begin
Result := GetEncoderClsid('
image/png', pClsid)
end
else if (AFileExt = '
.TIF')
or (AFileExt = '
.TIFF')
then
begin
Result := GetEncoderClsid('
image/tiff', pClsid)
end
else if (AFileExt = '
.JPG')
or (AFileExt = '
.JPEG')
then
begin
Result := GetEncoderClsid('
image/jpeg', pClsid);
IsJpeg := True;
end;
end;
begin
Result := False;
pntBitmap := TBitmap.Create;
QualityUL := compressionQuality;
//1...100
try
try
pntBitmap.Assign(vpntImage);
Bitmap := TGPBitmap.Create(pntBitmap.Handle, pntBitmap.Palette);
try
Bitmap.SetResolution(dpiResolution, dpiResolution);
strDateiendung := UpperCase(ExtractFileExt(vstrImagePath));
EncoderResult := GetEncoder(strDateiendung, clsidEncoder);
if EncoderResult >= 0
then
begin
if IsJpeg
and (QualityUL > 0)
and (QualityUL <=100)
then
begin
EncoderParameters.Count := 1;
EncoderParameters.Parameter[0].Guid := EncoderQuality;
EncoderParameters.Parameter[0].Type_ := EncoderParameterValueTypeLong;
EncoderParameters.Parameter[0].NumberOfValues := 1;
EncoderParameters.Parameter[0].Value := @QualityUL;
Result := Bitmap.Save(vstrImagePath, clsidEncoder, @EncoderParameters) = TStatus.Ok;
end else begin
Result := Bitmap.Save(vstrImagePath, clsidEncoder) = TStatus.Ok;
end;
end;
finally
Bitmap.Free;
end;
except
on E:
Exception do
begin
raise Exception.Create('
Error at saving Graphic File ' + vstrImagePath + '
: ' + E.ClassName + '
: ' + E.
Message);
end;
end;
finally
pntBitmap.Free;
end;
end;