Kompresi Citra dengan Delphi

Kompresi Citra adalah aplikasi kompresi data yang dilakukan terhadap citra digital dengan tujuan untuk mengurangi redundansi dari data-data yang terdapat dalam citra sehingga dapat disimpan atau ditransmisikan secara efisien.

Untuk membuat programnya, desain form seperti gambar di samping. Gunakan toolbar lalu klik kanan pada toolbar->newbutton->pada image index plih gambar sesuai tool yang akan di fungsikan.

Dibawah ini source code lengkapnya :

unit view;



interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ImgList, ToolWin, ComCtrls, ExtDlgs, ExtCtrls, IniFiles, JPEG, StdCtrls,
ShlObj;

type
TfrmVIEW = class(TForm)
dlgOPENPIC: TOpenPictureDialog;
sbrVIEW: TStatusBar;
tbrVIEW: TToolBar;
imlVIEW: TImageList;
tbnOpen: TToolButton;
tbnBROWSE: TToolButton;
tbnSAVE: TToolButton;
tbnSEP1: TToolButton;
tbnEIGHTH: TToolButton;
tbnQUARTER: TToolButton;
tbnHALF: TToolButton;
tbnFULL: TToolButton;
tbnAUTO: TToolButton;
tbnSEP2: TToolButton;
tbnCOMPRESS: TToolButton;
tbnSEP3: TToolButton;
tbnGRAY: TToolButton;
tbnLOCOLOR: TToolButton;
tbnHICOLOR: TToolButton;
tbnSEP4: TToolButton;
tbnQUALITY: TToolButton;
tbnSPEED: TToolButton;
tbnSEP6: TToolButton;
tbnFIRST: TToolButton;
tbnPREVIOUS: TToolButton;
tbnNEXT: TToolButton;
tbnLAST: TToolButton;
tbnLIST: TToolButton;
tbnEXIT: TToolButton;
cboFILES: TComboBox;
dlgSAVEPIC: TSavePictureDialog;
tbnDELETE: TToolButton;
procedure tbnEXITClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure tbnOpenClick(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure tbnLISTClick(Sender: TObject);
procedure tbnSAVEClick(Sender: TObject);
procedure tbnEIGHTHClick(Sender: TObject);
procedure tbnQUARTERClick(Sender: TObject);
procedure tbnHALFClick(Sender: TObject);
procedure tbnFULLClick(Sender: TObject);
procedure tbnAUTOClick(Sender: TObject);
procedure tbnBROWSEClick(Sender: TObject);
procedure tbnNEXTClick(Sender: TObject);
procedure tbnLASTClick(Sender: TObject);
procedure tbnFIRSTClick(Sender: TObject);
procedure tbnPREVIOUSClick(Sender: TObject);
procedure cboFILESClick(Sender: TObject);
procedure tbnGRAYClick(Sender: TObject);
procedure tbnLOCOLORClick(Sender: TObject);
procedure tbnHICOLORClick(Sender: TObject);
procedure tbnCOMPRESSClick(Sender: TObject);
procedure tbnDELETEClick(Sender: TObject);
private { Private declarations }
{enable or disable buttons that are needed when a picture is showing}
procedure ToggleButtons;
{recurse all specified jpg files on a drive or folder into the dropdown list}
function flngRecurseDrive(strDrive : string) : longint;
{find a folder using the browse for folder dialog}
function fstrBrowseFolder : string;
{get the number of colors supported by the video card}
function fintNumColors : integer;
{get the working area of the screen, excluding the taskbar}
function frctGetWorkArea : TRect;
{add a backslash to a path if necessary}
function fstrAddSlash(inString : string) : string;
{check on if a directory exists}
function fboolDirectoryExists(const Name: string): Boolean;
{put the current jpeg information on the status bar}
procedure pShowInfo;
{draw the picture of the current jpeg on the image box}
procedure pShowPicture;
{load a jpeg image}
function fboolLoadJpeg : boolean;
public { Public declarations }

end;

var
frmVIEW : TfrmVIEW; {form}
jpgCurrent : TJpegImage; {current picture}

implementation

{$R *.DFM}

{enable or disable buttons that are needed when a
picture is showing}
procedure TfrmView.ToggleButtons;
begin
{save button}
if tbnSAVE.Enabled then
tbnSAVE.Enabled := False
else
tbnSAVE.Enabled := True;
{eighth size button}
if tbnEIGHTH.Enabled then
tbnEIGHTH.Enabled := False
else
tbnEIGHTH.Enabled := True;
{quarter size button}
if tbnQUARTER.Enabled then
tbnQUARTER.Enabled := False
else
tbnQUARTER.Enabled := True;
{half size button}
if tbnHALF.Enabled then
tbnHALF.Enabled := False
else
tbnHALF.Enabled := True;
{full size button}
if tbnFULL.Enabled then
tbnFULL.Enabled := False
else
tbnFULL.Enabled := True;
{auto size button}
if tbnAUTO.Enabled then
tbnAUTO.Enabled := False
else
tbnAUTO.Enabled := True;
{compress button}
if tbnCOMPRESS.Enabled then
tbnCOMPRESS.Enabled := False
else
tbnCOMPRESS.Enabled := True;
{gray button}
if tbnGRAY.Enabled then
tbnGRAY.Enabled := False
else
tbnGRAY.Enabled := True;
{locolor button}
if tbnLOCOLOR.Enabled then
tbnLOCOLOR.Enabled := False
else
tbnLOCOLOR.Enabled := True;
{hicolor button}
if tbnHICOLOR.Enabled then
tbnHICOLOR.Enabled := False
else
tbnHICOLOR.Enabled := True;
{quality button}
if tbnQUALITY.Enabled then
tbnQUALITY.Enabled := False
else
tbnQUALITY.Enabled := True;
{speed button}
if tbnSPEED.Enabled then
tbnSPEED.Enabled := False
else
tbnSPEED.Enabled := True;
{first button}
if tbnFIRST.Enabled then
tbnFIRST.Enabled := False
else
tbnFIRST.Enabled := True;
{previous button}
if tbnPREVIOUS.Enabled then
tbnPREVIOUS.Enabled := False
else
tbnPREVIOUS.Enabled := True;
{next button}
if tbnNEXT.Enabled then
tbnNEXT.Enabled := False
else
tbnNEXT.Enabled := True;
{last button}
if tbnLAST.Enabled then
tbnLAST.Enabled := False
else
tbnLAST.Enabled := True;
{delete button}
if tbnDELETE.Enabled then
tbnDELETE.Enabled := False
else
tbnDELETE.Enabled := True;
end; {enable or disable buttons}

{recurse all specified jpg files on a drive or folder into the dropdown list}
function TfrmView.flngRecurseDrive(strDrive : string) : longint;
var
intCheck : Integer;
srcResult : TSearchRec;
begin
{add slash to drive path}
strDrive := fstrAddSlash(strDrive);
{set first file search up & get result}
intCheck := sysutils.findfirst(strDrive + '*.*',$3f,srcResult);
{keep checking for files until no more are found}
while intCheck = 0 do
begin
if (srcResult.Attr and faDirectory) = faDirectory then
begin {if directory}
{if not a directory}
if (srcResult.name[1] <> '.')then
begin
{extension of file found is a jpeg, add it to the list}
if UpperCase(ExtractFileExt(srcResult.name)) = '.JPG' then
begin
cboFILES.Items.Add(strDrive + srcResult.name);
flngRecurseDrive(strDrive + srcResult.name);
end
else {extension was not jpg - keep recursing}
flngRecurseDrive(strDrive + srcResult.name);
end; {if not .}
end {if directory}
else
begin {extension of file found is a jpeg, add it to the list}
if UpperCase(ExtractFileExt(srcResult.name)) = '.JPG' then
cboFILES.Items.Add(strDrive + srcResult.name);
end;
{find next search result}
intCheck := sysutils.findnext(srcResult);
{show the current search result on the status bar}
sbrView.Panels[4].Text := srcResult.Name;
sbrView.Refresh;
end;
{free memory allocated for search}
sysutils.findclose(srcResult);
{assign function result}
result := cboFILES.Items.Count;
end; {RecurseDrive}

{find a folder using the browse for folder dialog}
function TfrmView.fstrBrowseFolder : string;
var
lpItemID : PItemIDList;
brwsInfo : TBrowseInfo;
charName : array[0..MAX_PATH] of char;
charPath : array[0..MAX_PATH] of char;
begin
FillChar(brwsInfo,sizeOf(TBrowseInfo),#0);
brwsInfo.hwndOwner := frmVIEW.handle;
brwsInfo.lpszTitle := PChar('Select a Drive or Folder to search for images');
brwsInfo.pszDisplayName := PChar('D:');
brwsInfo.pszDisplayName := @charName;
brwsInfo.ulFlags := BIF_RETURNONLYFSDIRS;
lpItemID := SHBrowseForFolder(brwsInfo);
if lpItemID <> nil then
begin
SHGetPathFromIDList(lpItemID,charPath);
Result := charPath;
GlobalFreePtr(lpItemID);
end {lpItemID}
else
begin {user chooses cancel}
result := '';
end; {if lpItemID}
end; {browse for data folder}

{get the number of colors supported by the video card}
function TfrmVIEW.fintNumColors : integer;
var
desktopDC : hDC;
begin
desktopDC := GetDC(0);
result := GetDeviceCaps(desktopDC, BITSPIXEL) * GetDeviceCaps(desktopDC, PLANES);
releaseDC(0,desktopDC);
end; {function numColors}

{get the working area of the screen, excluding the taskbar if
it is in the up position}
function TfrmVIEW.frctGetWorkArea : TRect;
begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0);
end; {get the working area of the screen, excluding the taskbar}

{add a backslash to a path if necessary}
function TfrmVIEW.fstrAddSlash(inString : string) : string;
begin

if inString[length(inString)] = '\' then
Result := inString
else
Result := inString + '\';

end; {add a backslash to a path if necessary}

{check on if a directory exists}
function TfrmVIEW.fboolDirectoryExists(const Name: string): Boolean;
var
Code: Integer;
begin
Code := GetFileAttributes(PChar(Name));
Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end; {DirectoryExists}

{put the current jpeg information on the status bar}
procedure TfrmView.pShowInfo;
var
intPanelWidth : integer; {width of a panel}
begin
{width}
intPanelWidth := sbrView.Canvas.TextWidth('M' + IntToStr(jpgCurrent.Width) + 'M');
sbrView.Panels[0].Width := intPanelWidth;
sbrView.Panels[0].Text := IntToStr(jpgCurrent.Width);
{height}
intPanelWidth := sbrView.Canvas.TextWidth('M' + IntToStr(jpgCurrent.Height) + 'M');
sbrView.Panels[1].Width := intPanelWidth;
sbrView.Panels[1].Text := IntToStr(jpgCurrent.Height);
{file name}
sbrView.Panels[4].Text := cboFILES.Text;
end;

{draw the picture of the current jpeg on the form canvas}
procedure TfrmView.pShowPicture;
var
intLeft : integer; {x-coordinate of left corner of image}
intTop : integer; {y-coordinate of top corner of image}
begin

{show jpeg information on status bar}
pShowInfo;

{set the image scale factor}
jpgCurrent.Scale := jsFullSize; {set to full size initially}
if tbnEIGHTH.Down then jpgCurrent.Scale := jsEighth;
if tbnQUARTER.Down then jpgCurrent.Scale := jsQuarter;
if tbnHALF.Down then jpgCurrent.Scale := jsHalf;
if tbnFULL.Down then jpgCurrent.Scale := jsFullSize;

{if autoscale is on, size image to fit screen}
if tbnAUTO.Down then
begin
if jpgCurrent.Width > frmVIEW.ClientWidth then jpgCurrent.Scale := jsHalf;
if jpgCurrent.Width > frmVIEW.ClientWidth then jpgCurrent.Scale := jsQuarter;
if jpgCurrent.Width > frmVIEW.ClientWidth then jpgCurrent.Scale := jsEighth;
if jpgCurrent.Height > frmVIEW.ClientHeight then jpgCurrent.Scale := jsHalf;
if jpgCurrent.Height > frmVIEW.ClientHeight then jpgCurrent.Scale := jsQuarter;
if jpgCurrent.Height > frmVIEW.ClientHeight then jpgCurrent.Scale := jsEighth;
end; {if autoscale is on, size image to fit screen}

{center the image if possible}
if jpgCurrent.Width < frmVIEW.ClientWidth then
intLeft := round((frmView.ClientWidth - jpgCurrent.Width) / 2)
else
intLeft := 0;
if jpgCurrent.Height < frmVIEW.ClientHeight then
intTop := round((frmView.ClientHeight - jpgCurrent.Height) / 2)
else
intTop := tbrView.Top + tbrView.Height;

{set display format}
if tbnHiColor.Down then
begin
jpgCurrent.PixelFormat := jf24Bit;
jpgCurrent.Grayscale := False;
end;
{low color / 256 color}
if tbnLoColor.Down then
begin
jpgCurrent.PixelFormat := jf8Bit;
jpgCurrent.Grayscale := False;
end;
{grayscale}
if tbnGray.Down then
begin
jpgCurrent.PixelFormat := jf8Bit;
jpgCurrent.Grayscale := True;
end;

{draw the jpeg on the form canvas}
frmView.Refresh;
frmView.Canvas.Draw(intLeft,intTop,jpgCurrent);

end; {draw the picture of the current jpeg on the form canvas}

{load a jpeg image}
function TfrmVIEW.fboolLoadJpeg : boolean;
var
strJpegFileName : string; {qualified filename of jpeg file}
strLogFileName : string; {log file for possible errors}
fhLogFile : TextFile; {text file to log errors to}
begin

{get file name}
strJpegFileName := cboFILES.Items[cboFILES.ItemIndex];
{exit if the file does not exist}
if not FileExists(strJpegFileName) then
begin
result := false;
exit;
end; {if not fileexists}

{set performance factor for reading/decompressing the jpeg}
if tbnSpeed.Down then
jpgCurrent.Performance := jpBestSpeed
else
jpgCurrent.Performance := jpBestQuality;

{try to load a file into the jpeg, log an error if it doesn't work}
try

jpgCurrent.LoadFromFile(strJpegFileName);

except

on exception do
begin

{log exceptions to a text file}
strLogFileName := fstrAddSlash(ExtractFilePath(ParamStr(0))) + 'errorlog.txt';
AssignFile(fhLogFile,strLogFileName);
{create the log file if it doesn't exist, if it does, then add to it}
if FileExists(strLogFileName) then
Append(fhLogFile)
else
Rewrite(fhLogFile);
{write the file name of the jpeg file which caused the exception}
Writeln(fhLogFile, strJpegFileName);
{close the log file}
CloseFile(fhLogFile);
{set result = false}
result := False;
{exit the function here on errors}
exit;

end; {on exception}
end; {try}

{set result = true if function reaches this point}
result := True;

end; {load a jpeg image}

{exit app}
procedure TfrmVIEW.tbnEXITClick(Sender: TObject);
begin
frmVIEW.Close;
Application.Terminate;
end; {exit app}

{initial form creation}
procedure TfrmVIEW.FormCreate(Sender: TObject);
var
iniVIEW : TIniFile; {persist settings for application}
iniFILE : string; {qualified name of ini file}
rctArea : TRect; {working area of desktop}
begin

{disable the buttons that are not needed until pictures are loaded}
ToggleButtons;

{get the working area of the screen}
rctArea := frctGetWorkArea;

{set ini file name}
iniFILE := fstrAddSlash(ExtractFilePath(ParamStr(0))) + 'jpegview.ini';

{initialize ini file}
iniVIEW := TIniFile.Create(iniFILE);

{read position settings from ini file}
frmVIEW.Left := iniVIEW.ReadInteger('POSITION','Left',0);
frmVIEW.Top := iniVIEW.ReadInteger('POSITION','Top',0);
frmVIEW.Width := iniVIEW.ReadInteger('POSITION','Width',rctArea.Right);
frmVIEW.Height := iniVIEW.ReadInteger('POSITION','Height',rctArea.Bottom);

{free ini file handle}
iniVIEW.Free;

{set the autoscale to on by default}
tbnAuto.Down := True;

{check color of current video card and
set to most appropriate viewing mode}
if fintNumColors < 16 then
tbnLOCOLOR.Down := True
else
tbnHICOLOR.Down := True;
end; {initial form creation}

{before form close}
procedure TfrmVIEW.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
var
iniVIEW : TIniFile; {persist settings for application}
iniFILE : string; {qualified name of ini file}
begin
{set ini file name}
iniFILE := fstrAddSlash(ExtractFilePath(ParamStr(0))) + 'jpegview.ini';

{initialize ini file}
iniVIEW := TIniFile.Create(iniFILE);

{read position settings from ini file}
iniVIEW.WriteInteger('POSITION','Left',frmVIEW.Left);
iniVIEW.WriteInteger('POSITION','Top',frmVIEW.Top);
iniVIEW.WriteInteger('POSITION','Width',frmVIEW.Width);
iniVIEW.WriteInteger('POSITION','Height',frmVIEW.Height);

{free ini file handle}
iniVIEW.Free;

{if memory was allocated for the jpeg then free it}
if frmVIEW.Tag <> 0 then jpgCurrent.Free;

end; {before form close}

{select file(s) for viewing}
procedure TfrmVIEW.tbnOpenClick(Sender: TObject);
var
strLastDir : string; {last directory a file was chosen from}
iniVIEW : TIniFile; {persist settings for application}
iniFILE : string; {qualified name of ini file}
begin
{set ini file name}
iniFILE := fstrAddSlash(ExtractFilePath(ParamStr(0))) + 'jpegview.ini';

{initialize ini file}
iniVIEW := TIniFile.Create(iniFILE);

{get the last initial directory used}
strLastDir := iniVIEW.ReadString('PATHS','LastOpenDir','');
if fboolDirectoryExists(strLastDir) then dlgOPENPIC.InitialDir := strLastDir;

{if files were chosen}
if dlgOPENPIC.Execute then
begin

{clear the dropdown list if necessary}
if frmVIEW.Tag <> 0 then
cboFILES.Clear
else
begin
jpgCurrent := TJpegImage.Create;
frmVIEW.Tag := 1;
end; {if frmVIEW.Tag <> 0}

{add selected files to dropdown list}
while dlgOPENPIC.Files.Count > 0 do
begin
cboFILES.Items.Add(dlgOPENPIC.Files[0]);
dlgOPENPIC.Files.Delete(0);
end; {while dlgOPENPIC.Files.Count > 0}

{save the folder that the file was chosen from
for future use}
strLastDir := ExtractFilePath(cboFILES.Items[0]);
iniVIEW.WriteString('PATHS','LastOpenDir',strLastDir);

{show the first picture on the list}
cboFILES.ItemIndex := 0;
if fboolLoadJpeg then pShowPicture;

{enable the buttons}
ToggleButtons;

end; {if files were chosen}

{free memory allocated for ini file handling}
iniVIEW.Free;

end; {select file(s) for viewing}

{form resize}
procedure TfrmVIEW.FormResize(Sender: TObject);
begin
{size combo box to width of form}
cboFILES.Left := 0;
cboFILES.Width := frmVIEW.ClientWidth;
cboFILES.Top := tbrView.Top + tbrView.Height;
if frmVIEW.Tag > 0 then pShowPicture;
end; {form resize}

{toggle view/hide file list}
procedure TfrmVIEW.tbnLISTClick(Sender: TObject);
begin

if tbnList.Down then
cboFILES.Visible := True
else
cboFILES.Visible := False;

end; {toggle view/hide file list}

{save the current picture as a file}
procedure TfrmVIEW.tbnSAVEClick(Sender: TObject);
var
strNewFileName : string;
begin

{if user clicks the save button}
if dlgSAVEPIC.Execute then
begin
strNewFileName := dlgSAVEPIC.FileName;
jpgCurrent.SaveToFile(strNewFileName);
end;

end; {save the current picture as a file}

{set picture to 1/8 size}
procedure TfrmVIEW.tbnEIGHTHClick(Sender: TObject);
begin
if jpgCurrent <> nil then pShowPicture;
end; {set picture to 1/8 size}

{set picture to 1/4 size}
procedure TfrmVIEW.tbnQUARTERClick(Sender: TObject);
begin
if jpgCurrent <> nil then pShowPicture;
end; {set picture to 1/4 size}

{set picture to 1/2 size}
procedure TfrmVIEW.tbnHALFClick(Sender: TObject);
begin
if jpgCurrent <> nil then pShowPicture;
end; {set picture to 1/2 size}

{set picture to full size}
procedure TfrmVIEW.tbnFULLClick(Sender: TObject);
begin
if jpgCurrent <> nil then pShowPicture;
end; {set picture to full size}

{toggle autoscaling of pictures}
procedure TfrmVIEW.tbnAUTOClick(Sender: TObject);
begin
if jpgCurrent <> nil then pShowPicture;
end; {toggle autoscaling of pictures}

{select a drive or folder to search for jpegs}
procedure TfrmVIEW.tbnBROWSEClick(Sender: TObject);
var
strFolder : string; {folder to recurse for image files}
intCount : integer; {resulting count of recursing drive}
begin

{get the selected drive/folder from the user}
strFolder := fstrBrowseFolder;

{clear any current list}
if frmVIEW.Tag <> 0 then cboFILES.Clear;

{change the mousepointer to an hourglass}
Screen.Cursor := crHourGlass;

{recurse all jpegs on the drive into the dropdown list}
if strFolder <> '' then
intCount := flngRecurseDrive(strFolder)
else
intCount := 0;

{change the mousepointer to an hourglass}
Screen.Cursor := crDefault;

{enable buttons and create the jpeg image}
if intCount > 0 then
begin
{enable the buttons}
ToggleButtons;
{create the jpeg image to use for loading jpeg files}
jpgCurrent := TJpegImage.Create;
{set the tag to indicate jpeg memory was allocated}
frmVIEW.Tag := 1;
{show the first picture on the list}
cboFILES.ItemIndex := 0;
if fboolLoadJpeg then pShowPicture;
end; {if frmVIEW.Tag <> 0}

end; {select a drive or folder to search for jpegs}

{move to next jpeg file on list}
procedure TfrmVIEW.tbnNEXTClick(Sender: TObject);
var
intNextJpeg : integer;
begin

{increment list index}
intNextJpeg := cboFILES.ItemIndex + 1;
{move back to first jpeg if past the end}
if intNextJpeg > (cboFILES.Items.Count - 1) then intNextJpeg := 0;
{select the new jpeg from the dropdown list}
cboFILES.ItemIndex := intNextJpeg;
{show the jpeg}
if fboolLoadJpeg then pShowPicture;

end; {move to next jpeg file on list}

{move to last jpeg file on list}
procedure TfrmVIEW.tbnLASTClick(Sender: TObject);
begin

{select the last jpeg from the dropdown list}
cboFILES.ItemIndex := cboFILES.Items.Count - 1;
{show the jpeg}
if fboolLoadJpeg then pShowPicture;

end; {move to last jpeg file on list}

{move to first jpeg file on list}
procedure TfrmVIEW.tbnFIRSTClick(Sender: TObject);
begin

{select the last jpeg from the dropdown list}
cboFILES.ItemIndex := 0;
{show the jpeg}
if fboolLoadJpeg then pShowPicture;

end; {move to first jpeg file on list}

{move to previous jpeg file on list}
procedure TfrmVIEW.tbnPREVIOUSClick(Sender: TObject);
var
intPrevJpeg : integer;
begin

{increment list index}
intPrevJpeg := cboFILES.ItemIndex - 1;
{move back to last jpeg if beginning of list has been reached}
if intPrevJpeg < 0 then intPrevJpeg := cboFILES.Items.Count - 1;
{select the new jpeg from the dropdown list}
cboFILES.ItemIndex := intPrevJpeg;
{show the jpeg}
if fboolLoadJpeg then pShowPicture;

end; {move to previous jpeg file on list}

{user selects a file from the list}
procedure TfrmVIEW.cboFILESClick(Sender: TObject);
begin
if fboolLoadJpeg then pShowPicture;
end; {user selects a file from the list}

{switch image to grayscale}
procedure TfrmVIEW.tbnGRAYClick(Sender: TObject);
begin
jpgCurrent.PixelFormat := jf8Bit;
jpgCurrent.Grayscale := True;
pShowPicture;
end; {switch image to grayscale}

{switch image to low color}
procedure TfrmVIEW.tbnLOCOLORClick(Sender: TObject);
begin
jpgCurrent.PixelFormat := jf8Bit;
jpgCurrent.Grayscale := False;
pShowPicture;
end; {switch image to low color}

{switch image to high color}
procedure TfrmVIEW.tbnHICOLORClick(Sender: TObject);
begin
jpgCurrent.PixelFormat := jf24Bit;
jpgCurrent.Grayscale := False;
pShowPicture;
end; {switch image to high color}

{set jpeg compression}
procedure TfrmVIEW.tbnCOMPRESSClick(Sender: TObject);
var
intQuality : integer; {compression quality index}
strResponse : string; {response from input box}
strPrompt : string; {prompt to user}
begin
{set prompt}
strPrompt := 'Higher value = better quality';
{get user setting}
strResponse := inputbox('Compression Quality',strPrompt,'100');
{make integer from setting}
if strResponse <> '' then
begin
{change the quality response to an integer}
intQuality := StrToIntDef(strResponse,100);
{set the compression quality}
jpgCurrent.CompressionQuality := intQuality;
{call the compression method}
jpgCurrent.Compress;
{set to grayscale}
jpgCurrent.Grayscale := True;
{re-show the picture}
pShowPicture;
{turn off grayscale}
jpgCurrent.Grayscale := False;
{re-show the picture compressed}
pShowPicture;
end; {make integer from setting}
end; {set jpeg compression}

{delete current jpeg file}
procedure TfrmVIEW.tbnDELETEClick(Sender: TObject);
var
strMsg : string;
begin
{show user confirmation message}
strMsg := 'Are you sure you want to delete the current file?';
{if user chooses yes, delete file & item from list}
if MessageDlg(strMsg,mtWarning,[mbYes,mbNo],0) = mrYes then
begin
{delete the jpeg file}
DeleteFile(cboFILES.Text);
{remove the file reference from the list}
cboFILES.Items.Delete(cboFILES.ItemIndex);
{toggle the buttons to disabled if there are no list items}
if cboFILES.Items.Count < 1 then ToggleButtons;
end; {if messagedlg = yes}
end; {delete current jpeg file}

end.

Untuk menjalankannya, load gambar terlebih dahulu. Kemudian klik pada tool set compression level dan atur nominal kwalitasnya. semakin kecil nominalnya, gambar akan di kompresi menjadi semakin kecil.
















hasil citra setelah di kompresi. gambar nampak pecah karena detail warna diubah menjadi lebih sederhana untuk menghasilkan ukuran gambar menjadi lebih kecil.