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. 


Sumber : http://puputra21.blogspot.com/2011/06/kompresi-citra-dengan-delphi.html