MeNGompress Gambarr...

Bukan cumaan orang ajah yang butuh d kompress saat demam..
Gambar juga butuh d kompress lho..
Haha..
Inti nya adalah mengurangi kualitas gambar dengan cara kompress..
Check it out...

caranya seperti ini ...
{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.