Как сделать калькулятор в Delphi?
Delphi - объектно-ориентированный язык программирования, разработанный компанией Borland в 1995 году. Он основан на языке программирования Pascal, но имеет более расширенные возможности и добавлены новые функции.
Как Delphi реализует многоплатформенную разработку?
Delphi является интегрированной средой разработки (IDE), которая позволяет разрабатывать программное обеспечение для различных платформ, включая Windows, macOS, Android и iOS. Delphi достигает многоплатформенности с помощью...
Сглажено изменять размер JPEG
{
Before importing an image (jpg) into a database,
I would like to resize it (reduce its size) and
generate the corresponding smaller file. How can I do this?
Load the JPEG into a bitmap, create a new bitmap
of the size that you want and pass them both into
SmoothResize then save it again ...
there's a neat routine JPEGDimensions that
gets the JPEG dimensions without actually loading the JPEG into a bitmap,
saves loads of time if you only need to test its size before resizing.
}
uses
JPEG;
type
TRGBArray = array
[Word] of
TRGBTriple;
pRGBArray = ^TRGBArray;
{---------------------------------------------------------------------------
-----------------------}
procedure
SmoothResize(Src, Dst: TBitmap);
var
x, y: Integer;
xP, yP: Integer;
xP2, yP2: Integer;
SrcLine1, SrcLine2: pRGBArray;
t3: Integer;
z, z2, iz2: Integer;
DstLine: pRGBArray;
DstGap: Integer;
w1, w2, w3, w4: Integer;
begin
Src.PixelFormat := pf24Bit;
Dst.PixelFormat := pf24Bit;
if
(Src.Width = Dst.Width) and
(Src.Height = Dst.Height) then
Dst.Assign(Src)
else
begin
DstLine := Dst.ScanLine[0];
DstGap := Integer(Dst.ScanLine[1]) - Integer(DstLine);
xP2 := MulDiv(pred(Src.Width), $10000, Dst.Width);
yP2 := MulDiv(pred(Src.Height), $10000, Dst.Height);
yP := 0;
for
y := 0 to
pred(Dst.Height) do
begin
xP := 0;
SrcLine1 := Src.ScanLine[yP shr
16];
if
(yP shr
16 < pred(Src.Height)) then
SrcLine2 := Src.ScanLine[succ(yP shr
16)]
else
SrcLine2 := Src.ScanLine[yP shr
16];
z2 := succ(yP and
$FFFF);
iz2 := succ((not
yp) and
$FFFF);
for
x := 0 to
pred(Dst.Width) do
begin
t3 := xP shr
16;
z := xP and
$FFFF;
w2 := MulDiv(z, iz2, $10000);
w1 := iz2 - w2;
w4 := MulDiv(z, z2, $10000);
w3 := z2 - w4;
DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 +
SrcLine1[t3 + 1].rgbtRed * w2 +
SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4) shr
16;
DstLine[x].rgbtGreen :=
(SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 + 1].rgbtGreen * w2 +
SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4) shr
16;
DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 +
SrcLine1[t3 + 1].rgbtBlue * w2 +
SrcLine2[t3].rgbtBlue * w3 +
SrcLine2[t3 + 1].rgbtBlue * w4) shr
16;
Inc(xP, xP2);
end
; {for}
Inc(yP, yP2);
DstLine := pRGBArray(Integer(DstLine) + DstGap);
end
; {for}
end
; {if}
end
; {SmoothResize}
{---------------------------------------------------------------------------
-----------------------}
function
LoadJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string
): Boolean;
var
JPEGImage: TJPEGImage;
begin
if
(FileName = '') then
// No FileName so nothing
Result := False //to load - return False...
else
begin
try
// Start of try except
JPEGImage := TJPEGImage.Create; // Create the JPEG image... try // now
try
// to load the file but
JPEGImage.LoadFromFile(FilePath + FileName);
// might fail...with an Exception.
Bitmap.Assign(JPEGImage);
// Assign the image to our bitmap.Result := True;
// Got it so return True.
finally
JPEGImage.Free; // ...must get rid of the JPEG image. finally
end
; {try}
except
Result := False; // Oops...never Loaded, so return False.
end
; {try}
end
; {if}
end
; {LoadJPEGPictureFile}
{---------------------------------------------------------------------------
-----------------------}
function
SaveJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string
;
Quality: Integer): Boolean;
begin
Result := True;
try
if
ForceDirectories(FilePath) then
begin
with
TJPegImage.Create do
begin
try
Assign(Bitmap);
CompressionQuality := Quality;
SaveToFile(FilePath + FileName);
finally
Free;
end
; {try}
end
; {with}
end
; {if}
except
raise
;
Result := False;
end
; {try}
end
; {SaveJPEGPictureFile}
{---------------------------------------------------------------------------
-----------------------}
procedure
ResizeImage(FileName: string
; MaxWidth: Integer);
var
OldBitmap: TBitmap;
NewBitmap: TBitmap;
aWidth: Integer;
begin
OldBitmap := TBitmap.Create;
try
if
LoadJPEGPictureFile(OldBitmap, ExtractFilePath(FileName),
ExtractFileName(FileName)) then
begin
aWidth := OldBitmap.Width;
if
(OldBitmap.Width > MaxWidth) then
begin
aWidth := MaxWidth;
NewBitmap := TBitmap.Create;
try
NewBitmap.Width := MaxWidth;
NewBitmap.Height := MulDiv(MaxWidth, OldBitmap.Height, OldBitmap.Width);
SmoothResize(OldBitmap, NewBitmap);
RenameFile(FileName, ChangeFileExt(FileName, '.$$$'));
if
SaveJPEGPictureFile(NewBitmap, ExtractFilePath(FileName),
ExtractFileName(FileName), 75) then
DeleteFile(ChangeFileExt(FileName, '.$$$'))
else
RenameFile(ChangeFileExt(FileName, '.$$$'), FileName);
finally
NewBitmap.Free;
end
; {try}
end
; {if}
end
; {if}
finally
OldBitmap.Free;
end
; {try}
end
;
{---------------------------------------------------------------------------
-----------------------}
function
JPEGDimensions(Filename : string
; var
X, Y : Word) : boolean;
var
SegmentPos : Integer;
SOIcount : Integer;
b : byte;
begin
Result := False;
with
TFileStream.Create(Filename, fmOpenRead or
fmShareDenyNone) do
begin
try
Position := 0;
Read
(X, 2);
if
(X <> $D8FF) then
exit;
SOIcount := 0;
Position := 0;
while
(Position + 7 < Size) do
begin
Read
(b, 1);
if
(b = $FF) then
begin
Read
(b, 1);
if
(b = $D8) then
inc(SOIcount);
if
(b = $DA) then
break;
end
; {if}
end
; {while}
if
(b <> $DA) then
exit;
SegmentPos := -1;
Position := 0;
while
(Position + 7 < Size) do
begin
Read
(b, 1);
if
(b = $FF) then
begin
Read
(b, 1);
if
(b in
[$C0, $C1, $C2]) then
begin
SegmentPos := Position;
dec(SOIcount);
if
(SOIcount = 0) then
break;
end
; {if}
end
; {if}
end
; {while}
if
(SegmentPos = -1) then
exit;
if
(Position + 7 > Size) then
exit;
Position := SegmentPos + 3;
Read
(Y, 2);
Read
(X, 2);
X := Swap(X);
Y := Swap(Y);
Result := true;
finally
Free;
end
; {try}
end
; {with}
end
; {JPEGDimensions}