Koleksi Aplikasi dengan Delphi 7

Program Penjualan di Toko Bangunan

Ok kawan-kawan sekalian, setelah sekian lama tidak posting. akhirnya ada kesempatan juga untuk

membuat program Aplikasi Penjualan di toko Bangunan karna kebetulan ada yang request. heeee
oke gan karna project masih berjalan nanti saya upload dan berbagi tutornya sekalian...
kebetulan sudah sampai pada tahap pembuatan form untuk pembelian yang saya format menggunakan StringGrid

tampilan dasar untuk form pembelian SBB;

berikut code untuk membuat tampilan judul atau nama kolom stringgrid pada saat from beli di create

procedure Tfbeli.FormCreate(Sender: TObject);

beginsg.Cells[0,0]:='No';

sg.Cells[1,0]:='Kode barang';

sg.Cells[2,0]:='Nama barang';

sg.Cells[3,0]:='Jenis Barang';

sg.Cells[4,0]:='Satuan';

sg.Cells[5,0]:='Jumlah beli';

sg.Cells[6,0]:='Harga beli';

sg.Cells[7,0]:='Harga Jual';

sg.Cells[8,0]:='Sub Total Beli';

end;

kemudian untuk mengatur lebar kolom pada Stringgrid bisa digunakan Coding sbb:

procedure Tfbeli.tblebarClick(Sender: TObject);
var lebarF,lebaSG:real;a,b,c,d,e,f,g,h:integer;
begin
lebarF:=fbeli.Width;
a:=round(8/100*lebarF);
b:=round(20/100*lebarF);
c:=round(13/100*lebarF);
d:=round(10/100*lebarF);
e:=round(8/100*lebarF);
f:=round(11/100*lebarF);
g:=round(11/100*lebarF);
h:=round(13/100*lebarF);
sg.ColWidths[1]:=a;sg.ColWidths[2]:=b;sg.ColWidths[3]:=c;
sg.ColWidths[4]:=d;sg.ColWidths[5]:=e;sg.ColWidths[6]:=f;
sg.ColWidths[7]:=g;sg.ColWidths[8]:=h;
end;

lebar kolom ini diatau pada sebuah tombol/button, kemudian button tersebut dipanggil pada saaat form di create.

berikut adalah hasilnya saat aplikasi di compile

untuk menambah data pembelian pada stringgrid tersebut cukup dengan tekan tombol Enter pada kolom nama barang sehingga akan diantarkan pada form pencarian data
berikut code untuk memanggil form pencarian yang disisipkan pada Stringgrid OnkeyDown

procedure Tfbeli.sgKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var i,pRawal:integer; var a:string;
begin
if(ssctrl in Shift)and(chr(Key)in['S','s']) OR (ssctrl in Shift)and(chr(Key)in[#13])then
begin btsimpanClick(Sender);
exit;
end;
if(ssctrl in Shift)and(chr(Key)in['B','b']) OR (ssctrl in Shift)and(chr(Key)in[#13])then
begin
btbatalClick(Sender);
exit;
end;
if key=vk_tab then
begin
if (sg.Col=sg.ColCount-1)and(sg.Row=sg.RowCount-1) then btHapus.SetFocus;
end;
if key=vk_down then
begin
if (sg.Row=sg.RowCount-1) then bttbbarisClick(Sender);
end;
if key=vk_delete then
begin
btHapusClick(Sender);
end;
if key=vk_return then
begin
if sg.Col=1 then
begin
if sg.Cells[1,sg.Row]='' then exit;
a:=sg.Cells[1,sg.Row];
pRawal:=sg.Row; //cek jika ada data sama
   for i:=0 to sg.RowCount-1 do
begin
if i<>pRawal then
begin
if a=sg.Cells[1,i] then
begin
sg.Cells[5,i]:=FloatToStr(StrToFloat(sg.Cells[5,i])+1);
   sg.Cells[1,prawal]:='';
sg.Cells[8,i]:=FormatUang(FloatToStr( StrToFloat(clearF(sg.Cells[5,i]))* StrToFloat(clearF(sg.Cells[6,i]))));
exit;
Break;
end;
end;
end; // end cek
if cari('select * from barang where kd_brg='+ QuotedStr(sg.Cells[sg.Col,sg.row]))>0 then
begin
sg.Cells[1,sg.Row]:=futama.addscari['kd_brg'];
sg.Cells[2,sg.Row]:=futama.addscari['nm_brg'];
sg.Cells[3,sg.Row]:=futama.addscari['jenis'];
sg.Cells[4,sg.Row]:=futama.addscari['sat'];
sg.Cells[5,sg.Row]:='1';
sg.Cells[6,sg.Row]:=FormatUang(futama.addscari['hrg_beli']);
sg.Cells[7,sg.Row]:=FormatUang(futama.addscari['hrg_jual']);
sg.Cells[8,sg.Row]:=FormatUang(futama.addscari['hrg_beli']);
if sg.Row=sg.RowCount-1 then
sg.RowCount:=sg.RowCount+1;
   sg.Row:=sg.Row+1;
   end
else // jika kolom 0 tidak diketemukan kode yang sesuai maka
begin
if MessageDlg('Kode Barang tidak ditemukan'+#13+ 'Tambahkan Data Baru ?',mtInformation,[mbYes]+[mbno],0)=mryes then
begin
if fbarangin=nil then fbarangIn:=TfbarangIn.Create(Application);
fbarangin.Edit2.Text:='';
   fbarangin.Edit3.Text:='0';
   fbarangin.Edit4.Text:='0';
fbarangin.Edit5.Text:='';
fbarangin.Edit6.Text:='0';
fbarangin.ComboBox1.Text:='';
fbarangin.ComboBox2.Text:='';
   fbarangIn.Edit1.Text:=sg.Cells[sg.Col,sg.row];
fbarangIn.ShowModal;
end;
   end;
end
else
if (sg.Col=2)or (sg.col=3) then
   begin
   if fcaribarang=nil then fcaribarang:=tfcaribarang.Create(Application);
fcaribarang.pcontrol.Caption:='fbeli';
fcaribarang.Edit1.Text:=sg.Cells[sg.Col,sg.row];
fcaribarang.ShowModal;
end
   else exit;
end;
end;

waw, sangat panjang ya? heeeee

ups iya karna coding diatas memiliki beberapa fungsi yang digunakan untuk mengatur beberapa tombol seperti

Tombol CTRL + S atau CTRL+ENTER untuk menyimpan / memproses Pembelian
Tombol CTRL + B untuk membatalkan transaksi
tombol Navigasi panah ke bawah untuk menambah baris baru pada Stringgrid
tombol delete untuk menghapus baris data pada Stringgrid
tombol Enter untuk memanggil form pencarian dll

berikut hasilnya saat pada kolom ke 2dan kolom ketiga ditekan Enter

kemudian tinggal pilih pada form pencarian> enter
data loangsung masuk ke String grid yang kemudian bisa di proses sebagai data pembelian.

dan bagi yang tertarik untuk Editing lebih jauh dengan bahasa delphi, silahkan download source codenya dengan klink link dibawah ini
mohon maaf sedang ada maintenance: bisa requst via comentar

perlengkapan yang dibutuhkan untuk menjalankan
1. Database Mysql
2. Xampp untuk Mysql Servernya
3. Delphi 7 jika hendak melihat Coding nya

tapi bagi agan yang hanya hendak menggunakan saja tanpa melihat codingnya cukup Mysql dan Xampp

Program Penjualan dengan database Mysql ini saya olah dengan Navy Cat (ada backup an yang siap untuk di Restore). bagi yang belum punya, silahkan download

Program Jual Beli di Toko bangunan V.10

untuk source code dalam bahasa delphi silahkan requst ke alamat email:
delphi.programku@gmail.com

password : nuestzone

Program Konversi Suhu Untuk Android Menggunakan Delphi XE5

Kali ini ane sharing aplikasi android untuk konversi suhu beserta sourcodenya secara lengkap
program ini saya buat untuk tugas mata kuliah prmrogramman Mobile

Ok gan langsung Sedot saja dengan klik link dibawah ini

berhubung sedang dalam perbaikan
untuk sementara silahkan requst ke alamat email:
delphi.programku@gmail.com

Program membuat Sertifikat

Ok gan kali ini ane buat program untuk membuat laporan dalam bentuk sertifikat yang langsung bisa di cetak
nama dan lain sebagainya berdasar dari inputan
program ini masih dalam tahap pengembangan lebih lanjut

bagi yang agan agan menginginkan lebih bisa request saja heeee......

Interface Program

Pertama di minta untuk input data terlebih dahulu
kedua, tinggal pilih Laporan> Cetak Sertifikat hasilnya langsul muncul
Tararam........................................

Tinggal langgkah terahir
klik cetak atau tekan tompol yang berikon print
heeeee

selamat mencoba

ok gan untuk memcoba hasil aplikasinya bisa download dengan klik link dibawah ini

berhubung sedang dalam perbaikan
untuk sementara silahkan requst ke alamat email:
delphi.programku@gmail.com

Cara Mengatasi Masalah Register Licence Delphi 7

Apakah Anda pernah mengalami kegagalan pada saat membuka aplikasi Borland Delphi dengan pesan " Borland license information was found, but it is not valid for Delphi " ?

Berikut cara mengatasi " Borland license information was found, but it is not valid for Delphi " pada Borland Delphi :

Cara Pertama :
1. Masuk pada direktory C:/ProgramFiles/Borland/Delphi7/bin
2. Bersihkan registrasi dengan menjalankan file D7RegClean.exe
3. Kemudian regristasi ulang dengan cara menjalankan D7Reg.exe
4. Jika muncul registrasi sukses berati delphi siap untuk di jalankan kembali

Cara yang kedua

(Masuk ke dalam folder .borland yang terletak pada direktori user's pada Documents And Settings)
(Jalankan D7Reg.exe yang terletak pada direktori C:/ProgramFiles/Borland/Delphi7/bin)
(Ikuti step demi step dalam proses registrasi)
(Selesai, sekarang delphi Anda sudah dapat dijalankan dengan normal)

Program Auto renamer + Source Code Delphi

og gan program ini saya peruntukan bagi yang ingin merubah nama file dalam sebuah folder dengan nama series/urut seperti digunakan pada file musik, video, dll
dengan tujuan agar ketika di kirim ke media player seperti musik box, sudah urut sesuai dengan keinginan.

berawal dari permintaan teman yang memutar file musik menggunakan flasdisk di DVD Player.
secara otomatis, file akan terbaca series sesuai dengan abjad huruf. sedangkan temaan saya meminta untuk lagu tertentu diurutkan berdasarkan folder tertentu.

kali ini program ane share beserta source codenya menggunakan bahasa delphi dan saya beri nama auto renamer dan masih dalah tahap pengembangan

Cara penggunaan
bisa Kasih komentar di bawahnya

untuk mencoba aplikasinya atau melihat source codenya dalam bahasa delhi, bisa klik link dibawah ini

Download Disini Auto Renamer v1.0

selamat berkarya gan

Program Akademik SMK

Program ini mencangkup beberapa bagian seperti
Bagian Bimbingan Konseling (BK)
Kurikulum
Sistem Penilaian
Pendataan Siswa

Cara Instalasi/ Pemasangan

pastikan terlebih dahulu anda memiliki komputer yang sudah terinstal Mysql Server. disini penulis menggunakan Xampp sebagai mysql servernya. jika belum tahu pelajari lebih jauh disini.
install aplikasi database manager yaitu navicat
Buat database baru dengan madani
execute / restore database yang ada pada folder database mengunakan navicat
sekarang program siap untuk dijalankan.

selamat mencoba heeee

untuk downolad program bisa klik link dibawah ini

Download Aplikasi Akademik SMK

Update 26 /11/2016
mohon maaf agan agan semua tidak bisa membalas email satu persatu
berikt ini tampilkan link untuk download source Code Programnya secara lengkap
Untuk Source Code Bisa Di download dengan klik link dibawah ini

ProGram kompresi Citra

Kali ini Saya akan share Listing Program untuk Kompresi gambar menggunakan delphi 07
program ini di tujukan untuk memenuhi tugas mata kuliah Analisa Algortima Lanjut
program ini di tujukan untuk memenuhi tugas mata kuliah Analisa Algortima Lanjut
Menggunakan Metode Loosles
Croma Sub Sampling

sementara ane share dulu untuk hasil exenya gan
source codenya bisa request

Tampilan Programnya

Kemudian Pilih Buka dan ambil sembarang gambar

seperti gambar dibawah

Setelah memilih gambar, tekan tombol compresen croma .

tentukan nilainya antara 0 - 100

coba kita isi dengan 50

kemudian pilih ok

dan inilah hasilnya gambar yang telah di kompres dengan algoritma croma sub sampling

untuk lebih lengkapnya silahkan Download hasil compile nya dengan klik link dibawah ini

Klik disini

untuk source Codenya dalam bahasa delhpi slahkan download disini

Program Inventarisasi Bank

Gambar 1. Form Refiew Seluruh Data jaminan

Program ini saya buat untuk salah satu bank swasta yang menggunakan database Microsoft Office ACCESS 2003 berekstensi mdb
terdapat banyak fitur didalamnya salah satunya adalah:
Pendataan data jaminan dari masing-masing nasabah. setiap data jaminan yang masuk dapat dikelola menggunakan program ini, baik saat memasukan data jaminan, maupun mengambilnya.
sehingga diharapkan dengan program ini, arsip data jaminan terhadap pinjaman nasabah dapat tertata dengan rapi.
berikut ini adalah beberapa data jaminan yang dapat dikelola
Data Jaminan BPKB
Data jaminan Sertifikat
Data jaminan Rekening
Data Jaminan Los Pasar
Data Jaminan Convernote
Data jaminan Trayek
Data jaminan Ijazah
Data Jaminan Akta kelahiran

kelebihan dari program ini adalah pengunaan laporan yang sangat user friendly mudah dipahami dan bagus untuk kelas profesional.
saya menggunakan komponen fast report untuk membuat laporanya

Bentuk Laporan Seluruh data Jaminan

Gambar 3. Contoh Hasil Print Out setelah Pengambilan Data Jaminan

untuk Download hasil compile Programnya bisa klik link dibawah ini

klik disini
untuk Download Source Codenya kirim permintaan via e-mail ke delphi.programku@gmail.com
atau klik link dibawah ini
Donload Source program jaminan Bank

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

Program Showroom Sepeda motor

Program ini dibuat menggunakan Delphi 07 dan menggunakan database MySQL.

Showroom sepeda motor merupakan Sebuah Toko Penjual Sepeda Motor Baik Baru maupun 2nd.
program ini dibuat sesuai dengan permintaan customer yaitu salah satu Showroom sepeda motor di wonosobo. program dengan delphi ini dapat menangani proses seperti

Data Sepeda Motor
Data jenis Sepeda motor
Data Lising
Data Kredit
Data Pembelian Dari Lising
Pembelian Hutang
Penjualan Sepeda Motor baik cash, maupun Credit
Laporan data Suplier
Laporan data Pelanggan
Laporan Data Sepeda Motor
Laporan Data pembelian
Laporan Data Penjualan
Laporan Rugi Laba
dll

cara instalsinya
1. Restore database menggunakan Program NavyCat atau PHPMyADMIN
2. Copy file "Midas.dll" kedalam c:\Windows\Sistem32
3. program siap dijalankan

oke gan, untuk mencoba program aplikasinya bisa download link berikut ini

Download Showoroom Azka Motor V1.0

Update Agustus 2016
Program Showroom Sepeda motor telah saya kembangkan ke Versi 2.0
berikut Link Downloadnya
https://delphi-zones.blogspot.co.id/2015/08/program-showroom-sepeda-motor-v20.html

nah untuk info lengkapanya mengenai perkembangan program dan juga source codenya

silahkan kunjungi website resminya di