Sebatas Catatan

Regular Expression (RegEx) dengan Delphi

2014-06-12T10:14:00.000+07:00

Udah lama gak posting... biar gak lupa ane simpen diblog aja.. :D

Berikut ini contoh aplikasi sederhana penggunaan Regular Expression dengan Delphi untuk mengecek validasi alamat email yang ditulis. Pada contoh aplikasi juga ane kasih fungsi untuk mengecek validasi nomor telepon yang ditulis. Oke langsung saja...

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Label1: TLabel;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses RegExpr;

{$R *.dfm}

function IsAnEmail(Addr:String):Boolean;
begin
  with TRegExpr.Create do
  begin
    Expression := '^[_a-z0-9-]+(\.[_a-z0-9-]+)*@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]+)$';
    Result := Exec(Addr);
    Free;
  end;
end;

{
function IsAnPhoneNumber(PhoneNumber:String):Boolean;
begin
  with TRegExpr.Create do
  begin
    Expression := '([+][0-9]|[0][0-9])';
    Result := Exec(PhoneNumber);
    Free;
  end;
end;
}

procedure TForm1.Button1Click(Sender: TObject);
begin
  
  if IsAnEmail(Edit1.Text) then
  ShowMessage('Email OK')
  else
  ShowMessage('Invalid email address');

  {
  if IsAnPhoneNumber(Edit1.Text) then
  ShowMessage('Phone Number OK')
  else
  ShowMessage('Invalid phone number');
  }
end;

end.

Screenshot

Download FULL SOURCE DISINI

Untuk referensi pembelajaran / cara penggunaan regular expression bisa kunjungi website berikut http://regexpstudio.com/

Instal Komponen Zeos pada Lazarus Windows

2014-03-06T10:08:00.000+07:00

Mencoba iseng maen lazarus pada OS Windows teringat salah satu komponen koneksi/akses database yaitu ZEOS dan langsung ane praktekan cara instalnya di lazarus sekaligus ane buat postingan biar gak lupa caranya.. Hehehe... :D

Oke langsung saja...

1. Pastikan punya lazarus yang sudah terinstal dan komponen zeos nya dulu...

lazarus bisa didownload di http://sourceforge.net/projects/lazarus/

zeos component bisa didownload di http://sourceforge.net/projects/zeoslib/

2. Extrak file download komponen ZEOS tersebut.

3. Pada folder ..\ZEOSDBO-7.1.3a-stable\packages

copas satu folder lazarus ke C:\lazarus\components

( punya ane folder lazarus tak rename jadi ZEOSDBO-7.1.3a-stable )

4. Pada folder ..\ZEOSDBO-7.1.3a-stable copas satu folder src ke C:\lazarus

5. Buka lazarus kemudian buka file zcomponent.lpk
caranya klik Menu > Package > Open Package File (.lpk)...

muncul dialog seperti gambar di bawah

Klik Complie setelah selesai kemudian klik Use > Install.

Otomatis lazarus akan restart aplikasi jika berhasil..

ZEOS komponen sudah terinstal di lazarus windows dan siap dipake...

Semoga tutorial instal komponen zeos pada lazarus windows bermanfaat.... :D

Message Dialog Bahasa Indonesia Delphi

2014-02-26T13:28:00.000+07:00

Membuat Message Dialog Bahasa Indonesia Delphi

Berawal dari membuat program dengan bahasa Indonesia, waktu mau buat pesan dialog munculnya bahasa Inggris karena asli bawaannya Delphi. Kan lucu aja gitu semua tampilan pake bahasa Indonesia, dan tiba-tiba muncul pesan dialog konfirmasi pake bahasa Inggris... Hehehe.. :D

Caranya cukup mudah sih, kita tinggal buat unit seperti di bawah.

Source code berikut ane kutip dari blognya mas Bayu Prasetio dan ane buat unit sendiri.

Karena sering ane pake waktu buat aplikasi yang bahasa Indonesia jadi biar gak lupa ane tulis diblog.

Unit uMessageDlgIndonesia

unit uMessageDlgIndonesia;

interface

uses
  Consts, Windows;

const
  _NewSMsgDlgWarning = 'Peringatan';
  _NewSMsgDlgError = 'Kesalahan';
  _NewSMsgDlgInformation = 'Informasi';
  _NewSMsgDlgConfirm = 'Konfirmasi';
  _NewSMsgDlgYes = '&Ya';
  _NewSMsgDlgNo = '&Tidak';
  _NewSMsgDlgOK = 'OK';
  _NewSMsgDlgCancel = 'Batal';
  _NewSMsgDlgHelp = '&Panduan';
  _NewSMsgDlgHelpNone = 'Panduan tidak tersedia';
  _NewSMsgDlgHelpHelp = 'Panduan';
  _NewSMsgDlgAbort = '&Batal';
  _NewSMsgDlgRetry = '&Ulang';
  _NewSMsgDlgIgnore = 'A&cuh';
  _NewSMsgDlgAll = '&Semua';
  _NewSMsgDlgNoToAll = 'T&idak untuk Semua';
  _NewSMsgDlgYesToAll = 'Ya untuk S&emua';

implementation

procedure ReplaceResourceString(RStringRec: PResStringRec; AString: PChar);
var
  OldProtect: Cardinal;
begin
  if RStringRec = nil then Exit;
  if VirtualProtect(RStringRec, SizeOf(RStringRec^), PAGE_EXECUTE_READWRITE, OldProtect) then
  begin
    RStringRec^.Identifier := Integer(AString);
    VirtualProtect(RStringRec, SizeOf(RStringRec^), OldProtect, @OldProtect);
  end;
end;

initialization
  ReplaceResourceString(@SMsgDlgWarning, _NewSMsgDlgWarning);
  ReplaceResourceString(@SMsgDlgError, _NewSMsgDlgError);
  ReplaceResourceString(@SMsgDlgInformation, _NewSMsgDlgInformation);
  ReplaceResourceString(@SMsgDlgConfirm, _NewSMsgDlgConfirm);
  ReplaceResourceString(@SMsgDlgYes, _NewSMsgDlgYes);
  ReplaceResourceString(@SMsgDlgNo, _NewSMsgDlgNo);
  ReplaceResourceString(@SMsgDlgOK, _NewSMsgDlgOK);
  ReplaceResourceString(@SMsgDlgCancel, _NewSMsgDlgCancel);
  ReplaceResourceString(@SMsgDlgHelp, _NewSMsgDlgHelp);
  ReplaceResourceString(@SMsgDlgHelpNone, _NewSMsgDlgHelpNone);
  ReplaceResourceString(@SMsgDlgHelpHelp, _NewSMsgDlgHelpHelp);
  ReplaceResourceString(@SMsgDlgAbort, _NewSMsgDlgAbort);
  ReplaceResourceString(@SMsgDlgRetry, _NewSMsgDlgRetry);
  ReplaceResourceString(@SMsgDlgIgnore, _NewSMsgDlgIgnore);
  ReplaceResourceString(@SMsgDlgAll, _NewSMsgDlgAll);
  ReplaceResourceString(@SMsgDlgNoToAll, _NewSMsgDlgNoToAll);
  ReplaceResourceString(@SMsgDlgYesToAll, _NewSMsgDlgYesToAll);

end.

Cara pakainya tinggal di tambahkan ke project ( Project > Add to Project... )

kemudian use unit ( File > Use Unit...)

Setelah unit ditambahkan, maka penggunaan MessageDlg otomatis berubah menjadi Bahasa Indonesia.

Jika menghendaki bahasa lain tinggal dirubah saja konstanta pada unit uMessageDlgIndonesia sesuai keinginan, dengan demikian kita bisa mengkustomise Message Dialog tanpa merubah unit bawaanya Delphi yaitu Dialogs.

Jika males buat nih ada contoh program + source codenya :D

DOWNLOAD DIMARI

Sumber : http://bprasetio.wordpress.com/2007/10/22/meng-indonesia-kan-messagedlg/

Contoh Sederhana Trigger dan Stored Procedure pada Interbase / Firebird

2014-01-30T13:15:00.001+07:00

Postingan kali ini ane share contoh program sederhana yang sudah menggunakan Trigger dan Stored Procedure.. Mudah-mudahan bisa memberi sedikit gambaran bagaimana Trigger dan Strored Procedure itu bekerja karena langsung ane terapkan dalam sebuah apikasi kecil...

Sebenernya contoh program berikut ini adalah program yang sebelumnya uah pernah ane upload dengan judul Koneksi Database Interbase / Firebird dengan Delphi 7 cuma kali ini udah ane tambahkan Trigger dan Strored Procedure.. :D

Program dibuat dengan Delphi7, dengan database Interbase 2007, tools IBExpert.

oke langsung saja ke TKP...

Form Mahasiswa

Form Input Nilai

Pada form nilai, isi dari kolom keterangan akan terupdate otomatis setelah kita mengisikan nilai, proses ini menggunakan Trigger.

Form Rekap Nilai

Kalo proses rekap nilai ini menggunakan Stored Procedure.

Berikut ini Trigger dan Stored Procedure nya... :D

Trigger

Trigger dibuat pada tabel Nilai dimana Trigger ini akan dikerjakan sebelum tabel Nilai terisi atau terupdate, maka buat Triggernya BEFORE INSERT dan BEFORE UPDATE, Triggernya sama..

Stored Procedure

Nah Stored Procedure ini untuk menampilkan semua nilai dari mahasiswa dan sekaligus menghitung nilai Minimum, Maksimum, dan Rata-rata nilai dari seluruh mahasiswa tersebut..

DOWNLOAD SOURCE CODE DAN DATABASE DISINI

Semoga bermanfaat.. :D

Koneksi Database Interbase / Firebird dengan Delphi 7

2013-12-13T13:50:00.000+07:00

Melanjutkan postingan membuat tabel pada interbase / firebird sekarang cara mengkoneksikan ke delphi nya menggunakan komponen standart Interbase. Pada contoh program kali ini ane pake Data Controls supaya minimum coding. Dan bagaimana caranya.. Langsung sajalah... :D ( newbie only )

Database : Interbase 2007
Tools : IBExpert
IDE : Delphi 7

Desain form kira-kira seperti berikut :

Double klik komponen IBDatabase1, akan muncul dialog, seting seperti pada gambar

Pada komponen IBDataset1 seting properties SelectSQL

kemudian pada komponen IBDataset1 klik kanan > Dataset Editor...

klik Get Table Fields > klik NIM pada Key Field seperti yang terlihat pada gambar

kemudian klik Generate SQL, jika benar akan menjadi seperti gambar berikut

Pada komponen ActionList1 double klik, akan muncul dialog, seting saja seperti gambar

Berikut komponen-komponen yang perlu disetting propertiesnya

Komponen	Properties	Value
Label1	Caption	NIM
Label2	Caption	NAMA
DBEdit1
	DataSource	DataSource1
	DataField	NIM
DBEdit2
	DataSource	DataSource1
	DataField	NAMA
IBDatabase1
	DefaultTransaction	IBTransaction1
	Connected	True
IBTransaction1
	Active	True
	DefaultDatabase	IBDatabase1
IBDataset1
	Database	IBDatabase1
	Transaction	IBTransaction1
DataSource1
	AutoEdit	False
	DataSet	IBDataset1
DBGrid1
	Align	alBottom
	DataSource	DataSource1
	ReadOnly	True
Button1
Button1	Action	DataSetInsert1
Button2
Button2	Action	DataSetPost1
Button3
Button3	Action	DataSetEdit1
Button4
Button4	Action	DataSetCancel1
Button5
Button5	Action	DataSetDelete1
ActionList1
ActionList1	-	-

Hasil screenshot

Full Source Code

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, DB, IBCustomDataSet, IBDatabase, StdCtrls, ActnList, Grids,
  DBGrids, DBActns, Mask, DBCtrls;

type
TDataSetInsert = class (DBActns.TDataSetInsert)
  procedure UpdateTarget(Target:TObject); override;
end;
  TForm1 = class(TForm)
    IBDatabase1: TIBDatabase;
    IBTransaction1: TIBTransaction;
    IBDataSet1: TIBDataSet;
    DBGrid1: TDBGrid;
    ActionList1: TActionList;
    DataSource1: TDataSource;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    DataSetInsert1: TDataSetInsert;
    DataSetDelete1: TDataSetDelete;
    DataSetEdit1: TDataSetEdit;
    DataSetPost1: TDataSetPost;
    DataSetCancel1: TDataSetCancel;
    Button5: TButton;
    DBEdit1: TDBEdit;
    DBEdit2: TDBEdit;
    Label1: TLabel;
    Label2: TLabel;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TDataSetInsert }

procedure TDataSetInsert.UpdateTarget(Target: TObject);
begin
  with GetDataSet(Target) do
  Enabled := Active and CanModify and (State=dsBrowse);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  IBDataSet1.Open;
end;

end.

Download Source Code

Membuat Tabel Pada Interbase / Firebird via IBExpert

2013-11-19T12:51:00.001+07:00

Oke langsung saja... Sebelumnya ane pernah membahas bagaimana cara membuat database Interbase/Firebird menggunakan tool ibexpert, jika belum menyimak bisa kunjungi disini. Mengapa harus pake tool IBExpert, karena menurut ane pribadi tool ini sangat bagus sekali rekomended banget bagi developer yang khususnya make database Interbase/Firebird. Untuk tool nya bisa di download disini (gratis).

Setelah membuat database, kali ini ane mau ngeshare bagaimana cara membuat tabel pada Interbase/Firebird, pastinya make tool IBExpert. Jalankan IBExpert, akan muncul tampilan utama. Kemudian klik Register Database.

Ada beberapa yang harus diisi, seperti Server, Server Version, Database File, Database Alias (optional), User Name, Password, dan Always capitalize database objects names (optional berfungsi untuk otomatis semua object memakai huruf kapital) kemudian klik Register. Akan tampil sperti gambar berikut :

Double klik pada Database yang sudah diregister atau klik Connect to Database untuk mengkonekan database. Setelah database terkoneksi, sekarang kita buat tabel-tabelnya. Pilih tabel dan klik new tabel.

Membuat tabel Mahasiswa.
Pada waktu membuat tabel, untuk membuat Primary Key tinggal klik aja pada kolom PK, pilih field mana yang akan dijadikan sebagai Primary Key, akan muncul tanda Kunci seperti yg terlihat pada gambar di bawah. Kemudian klik Compile ( Gambar Petir ) trus klik Commit.

Membuat tabel Nilai.
Nah pada tabel nilai ini akan ane tunjukan bagaimana membuat Foreign Key dan nomor urut (auto increment field) yang akan terisi secara otomatis nomornya (ex: 1,2,3,4,5,dst...). Cara membuat tabel nilai sama seperti membuat tabel mahasiswa. kira-kira seperti gambar berikut :

Field ID akan dijadikan sebagai auto increment field jadi harus bertipe integer, cara buatnya cukup mudah. Pilih field ID kemudian klik AI sperti gambar berikut, semua akan di generate secara otomatis :

Sekarang membuat Foreign Key.

Pilih Tab Constraints > Foreign Keys > Klik kanan New Foreign Key.

Jika sudah selesai semua akan tampil seperti gambar berikut :

akan terdapat dua tabel (mahasiswa, nilai) trigger dan generator. nah trigger dan generator ini yang berperan untuk membuat nomor otomatis (auto increment filed) tadi. Sekian coretan dari ane, semoga ilmunya bermanfaat... :D

Post Event pada Interbase dan Firebird

2013-10-16T10:54:00.000+07:00

Seringkali dalam membuat aplikasi mengalami hal seperti ini (biasanya pada kasus aplikasi client server). Ada 2 aplikasi yang jalan secara bersamaan misal A dan B, dimana jika A melakukan transaksi maka B bisa langsung terupdate secara realtime tanpa mengeklik tombol Refresh. Nah biasanya pada kasus seperti ini masih ada yang menggunakan tombol Refresh atau Timer untuk merefresh Datasetnya. Berikut ini merupakan jawaban untuk kasus tersebut.

POST_EVENT
Posting sebuah event untuk event manager. Ketika suatu proses terjadi (misal proses insert update delete), pernyataan ini akan memberitahu event manager, yang mana memperingatkan aplikasi untuk menunggu nama eventnya. Post event ini sifatnya CASE SENSITIVE, jadi penulisan huruf besar kecilnya harus sama saat membuat dan saat memanggil event tersebut. Kalo ane bilang ini post_event ibarat trigger disisi aplikasi :D

Dalam kasus ini khususnya bagi para pengguna Delphi dengan database Firebird atau Interbase, karena pada database yang lain ane belum tau udah ada fitur post_event apa belum.

Sudah ane praktekan menggunakan Delphi databasenya Interbase komponen FIBPlus (recomended) pada jaringan lokal dan jaringan via Hamachi. Tool yang digunakan untuk mengolah databasenya adalah IBExpert (recomended).

Langsung saja pada contoh ane buat database DATA.IB dengan satu tabel yaitu tabel MHS, kemudian ane buat TRIGGER dan POST_EVENT dengan nama refresh pada tabel MHS After Insert, After Update, dan After Delete seperti gambar berikut.

Kemudian desain tampilan aplikasi menggunakan komponen FIBPlus, kira-kira seperti berikut.

Pada komponen EventAlert tambahkan nama Event nya, ingat besar kecil nama event harus sama.

Double klik pada komponen EventAlert atau pada Object Inspector Event OnEventAlert, kemudian ketikan kode berikut.

Nah ini screen shot hasil ujicoba pada jaringan via Hamachi, PC Server di Semarang, PC Client di Boyolali. Pada saat transaksi dilakukan di PC Client maka di PC Server tak perlu melakukan refresh secara manual atau pake timer, karena sudah dipicu dengan post event tadi.

Thanks buat Pak Imam Chalimi yang telah mengajarkan teknik post event ini, dan Mas Endra Wijaya yang bersedia membantu dalam uji coba aplikasi..

Capture Console Output Realtime Delphi

2013-09-27T14:37:00.000+07:00

Aplikasi ini berfungsi mengcapture output dari console. Seperti kita menjalankan perintah dari cmd, nah ini dibuat dengan delphi. Pada aplikasi yang sederhana ini sudah menggunakan teknik threading, jadi pada saat proses berjalaan bersamaan tidak saling mengganggu satu sama lain. Terdapat 2 contoh pada aplikasi, yang satu pake threading dan yang satu tidak pake, supaya kita bisa membedakan dan paham cara kerja threading itu seperti apa..

Oke langsung saja gak usah pake lama...nih full source code nya... :D

unit Unit1; interface uses   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,   Dialogs, StdCtrls, ExtCtrls; type   TmyThread = class(TThread)   private     { Private declarations }     fCommand   : String;     fParameter : String;   protected     procedure Execute; override;   public      constructor Create(Suspended: Boolean);//add thread constructor      property Command: String read fCommand write fCommand;      property Parameter: String read fParameter write fParameter;   end; type   TForm1 = class(TForm)     ed1: TEdit;     ed2: TEdit;     mmo1: TMemo;     b1: TButton;     lbl1: TLabel;     lbl2: TLabel;     tmr1: TTimer;     Label1: TLabel;     b2: TButton;     procedure tmr1Timer(Sender: TObject);     procedure b1Click(Sender: TObject);     procedure b2Click(Sender: TObject);   private     { Private declarations }   public     { Public declarations }   end; var   Form1: TForm1; implementation {$R *.dfm} procedure CaptureConsoleOutput(const ACommand, AParameters: String; AMemo: TMemo);  const    CReadBuffer = 2400;  var    saSecurity: TSecurityAttributes;    hRead: THandle;    hWrite: THandle;    suiStartup: TStartupInfo;    piProcess: TProcessInformation;    pBuffer: array[0..CReadBuffer] of Char;    dRead: DWord;    dRunning: DWord;  begin    saSecurity.nLength := SizeOf(TSecurityAttributes);    saSecurity.bInheritHandle := True;    saSecurity.lpSecurityDescriptor := nil;    if CreatePipe(hRead, hWrite, @saSecurity, 0) then    begin      FillChar(suiStartup, SizeOf(TStartupInfo), #0);      suiStartup.cb := SizeOf(TStartupInfo);      suiStartup.hStdInput := hRead;      suiStartup.hStdOutput := hWrite;      suiStartup.hStdError := hWrite;      suiStartup.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;         suiStartup.wShowWindow := SW_HIDE;      if CreateProcess(nil, PChar(ACommand + ' ' + AParameters), @saSecurity,        @saSecurity, True, NORMAL_PRIORITY_CLASS, nil, nil, suiStartup, piProcess)        then      begin        repeat          dRunning  := WaitForSingleObject(piProcess.hProcess, 100);                 Application.ProcessMessages();          repeat            dRead := 0;            ReadFile(hRead, pBuffer[0], CReadBuffer, dRead, nil);                     pBuffer[dRead] := #0;            OemToAnsi(pBuffer, pBuffer);            AMemo.Lines.Add(String(pBuffer));          until (dRead < CReadBuffer);        until (dRunning <> WAIT_TIMEOUT);        CloseHandle(piProcess.hProcess);        CloseHandle(piProcess.hThread);      end;      CloseHandle(hRead);      CloseHandle(hWrite);    end; end; procedure TForm1.tmr1Timer(Sender: TObject); begin   if Label1.Visible = True then Label1.Visible := False   else Label1.Visible := True; end; { TmyThread } constructor TmyThread.Create(Suspended: Boolean); begin   inherited;   FreeOnTerminate := True;   fCommand    := '';   fParameter  := ''; end; procedure TmyThread.Execute; begin   inherited;   CaptureConsoleOutput(Self.fCommand,Self.fParameter,Form1.mmo1); end; procedure TForm1.b1Click(Sender: TObject); var   Capture : TmyThread; begin   mmo1.Clear;   Capture := TmyThread.Create(False);   try     Capture.fCommand  := ed1.Text;     Capture.fParameter  := ed2.Text;     Capture.Resume;   finally   end; end; procedure TForm1.b2Click(Sender: TObject); begin   mmo1.Clear;   CaptureConsoleOutput(ed1.Text,ed2.Text,mmo1); end; end.

Download program full source DISINI

Form Full Screen Menutupi Taskbar Delphi

2013-09-04T14:05:00.003+07:00

Tambahkan 1 Form dan 1 Tombol, langsung copas saja kodenya.. :D

unit Unit1; interface uses   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,   Dialogs, StdCtrls; {$J+} //writeable constants on const   rec: TRect = (Left:0; Top:0; Right:0; Bottom:0);   ws : TWindowState = wsNormal; {$J-} //writeable constants off type   TForm1 = class(TForm)     btn1: TButton;     procedure btn1Click(Sender: TObject);     procedure FormCreate(Sender: TObject);   private     { Private declarations }   public     { Public declarations }   end; var   Form1: TForm1; implementation {$R *.dfm} procedure TForm1.btn1Click(Sender: TObject); begin   Application.Terminate; end; procedure TForm1.FormCreate(Sender: TObject); var   r : TRect; begin   if BorderStyle <> bsNone then   begin     ws := WindowState;     rec:= BoundsRect;     BorderStyle := bsNone;     r := Screen.MonitorFromWindow(Handle).BoundsRect;     SetBounds(r.Left, r.Top, r.Right-r.Left, r.Bottom-r.Top) ;   end   else   begin     BorderStyle := bsSizeable;     if ws = wsMaximized then       WindowState := wsMaximized     else       SetBounds(rec.Left, rec.Top, rec.Right-rec.Left, rec.Bottom-rec.Top) ;   end;  end; end.

Mengatur Volume TMediaplayer Delphi

2013-08-20T09:35:00.000+07:00

Mengatur volume pada komponen TMediaPlayer bawaan delphi

unit Unit1; interface uses   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,   Dialogs, StdCtrls, ComCtrls, MPlayer, MMSystem; //--- tambah constanta disini untuk mengatur volume const // ---- buat loading volume ----    MCI_SETAUDIO = $0873;    MCI_DGV_SETAUDIO_VOLUME = $4002;    MCI_DGV_SETAUDIO_ITEM = $00800000;    MCI_DGV_SETAUDIO_VALUE = $01000000;    MCI_DGV_STATUS_VOLUME = $4019;  type   TForm1 = class(TForm)     Button1: TButton;     TrackBar1: TTrackBar;     Label1: TLabel;     MediaPlayer1: TMediaPlayer;     OpenDialog1: TOpenDialog;     StatusBar1: TStatusBar;     procedure FormCreate(Sender: TObject);     procedure TrackBar1Change(Sender: TObject);     procedure Button1Click(Sender: TObject);   private     { Private declarations }   public     { Public declarations }   end; var   Form1: TForm1; implementation {$R *.dfm} // tambahkan " type " untuk atur volume type    MCI_DGV_SETAUDIO_PARMS = record // volume      dwCallback: DWORD;      dwItem: DWORD;      dwValue: DWORD;      dwOver: DWORD;      lpstrAlgorithm: PChar;      lpstrQuality: PChar;    end; // tambahkan " type " untuk atur volume type    MCI_STATUS_PARMS = record // volume      dwCallback: DWORD;      dwReturn: DWORD;      dwItem: DWORD;      dwTrack: DWORD;    end; // prosedur set volume procedure MPSetVolume(MP:TMediaPlayer;Volume:Integer) ; var    p: MCI_DGV_SETAUDIO_PARMS; begin    p.dwCallback := 0;    p.dwItem := MCI_DGV_SETAUDIO_VOLUME;    p.dwValue := Volume;    p.dwOver := 0;    p.lpstrAlgorithm := nil;    p.lpstrQuality := nil;    mciSendCommand(MP.DeviceID, MCI_SETAUDIO, MCI_DGV_SETAUDIO_VALUE    or MCI_DGV_SETAUDIO_ITEM, Cardinal(@p)) ; end; // dapatkan Volume, range 0 - 1000 function MPGetVolume(MP: TMediaPlayer): Integer; var    p: MCI_STATUS_PARMS; begin    p.dwCallback := 0;    p.dwItem := MCI_DGV_STATUS_VOLUME;    mciSendCommand(MP.DeviceID, MCI_STATUS, MCI_STATUS_ITEM, Cardinal(@p)) ;    Result := p.dwReturn; end; procedure TForm1.FormCreate(Sender: TObject); begin   Label1.Caption :='0%';   TrackBar1.Position:=400;   MPGetVolume(MediaPlayer1); end; procedure TForm1.TrackBar1Change(Sender: TObject); var i:real; begin      i:=int(TrackBar1.Position/TrackBar1.Max*100);      Label1.Caption:=floattostr(i)+'%';      MPSetVolume(MediaPlayer1,TrackBar1.Position); end; procedure TForm1.Button1Click(Sender: TObject); begin   if OpenDialog1.Execute then   begin   StatusBar1.SimpleText:=OpenDialog1.FileName;   MediaPlayer1.Close;   MediaPlayer1.FileName:=OpenDialog1.FileName;   MediaPlayer1.Open;   end; end; end.

Hasil Screenshot :

Download Source Code DISINI

Menghitung Umur Delphi

2013-08-02T08:26:00.000+07:00

Aplikasi sederhana untuk menghitung berapa umur kita sekarang, dengan memasukkan tanggal lahir.

unit Unit1; interface uses   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,   Dialogs, ComCtrls, StdCtrls, DateUtils; type   TForm1 = class(TForm)     Edit1: TEdit;     DateTimePicker1: TDateTimePicker;     procedure DateTimePicker1Change(Sender: TObject);   private     { Private declarations }   public     { Public declarations }   end; var   Form1: TForm1; implementation {$R *.dfm} function Umur(TglSekarang, TglLahir:TDate): string; var th,bl,hr, y1,m1,d1, y2,m2,d2: Word; begin Result:=''; if TglLahir>TglSekarang then Exit; DecodeDate(TglSekarang,y1,m1,d1); DecodeDate(TglLahir,y2,m2,d2); th:=y1-y2; if m1<m2 then begin bl:=12-m2+m1; Dec(th); end else bl:=m1-m2; if d1<d2 then begin hr:=DaysInAMonth(y2,m2)-d2+d1; Dec(bl); if bl>11 then begin bl:=11; Dec(th); end; end else hr:=d1-d2; if th>0 then Result:=Result+IntToStr(th)+' tahun'; if bl>0 then begin if Result>'' then Result:=Result+', '; Result:=Result+IntToStr(bl)+' bulan'; end; if hr>0 then begin if Result>'' then Result:=Result+', '; Result:=Result+IntToStr(hr)+' hari.'; end; if Result>'' then Result:='Umur ... '+Result; end; procedure TForm1.DateTimePicker1Change(Sender: TObject); begin   Edit1.Text  := Umur(Now,DateTimePicker1.Date); end; end.

Hasil Screenshot :

Download Program + Source DISINI

Form tidak bisa di geser Delphi

2013-07-29T12:51:00.000+07:00

Form default ada title bar nya, tapi tidak bisa di geser / di drag

Membuat TEdit Rata Tengah dan Kanan Delphi

2013-07-25T15:34:00.000+07:00

Screen shot :

Button dalam Edit Delphi

2013-07-18T13:21:00.001+07:00

Tambahkan 1 BitButton dan 1 Edit seperti gambar berikut

Source code lengkap :

Hasil screenshot :

Menghitung bilangan berpangkat bulat delphi

2013-07-17T09:08:00.000+07:00

Program sederhana untuk menghitung bilangan berpangkat bulat dengan delphi.. semoga bermanfaat.. :D

unit Unit1; interface uses   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,   Dialogs, StdCtrls; type   TForm1 = class(TForm)     Edit1: TEdit;     Edit2: TEdit;     Edit3: TEdit;     BHitung: TButton;     Label1: TLabel;     Label2: TLabel;     Label3: TLabel;     procedure BHitungClick(Sender: TObject);     procedure FormCreate(Sender: TObject);   private     { Private declarations }   public     { Public declarations }   end; var   Form1: TForm1; implementation {$R *.dfm} function PangkatBilangan(a:Double; b : Integer) : Double; var i : integer; temp : Double; begin temp := 1; for i := 1 to b do begin temp := temp * a; end; PangkatBilangan := temp; end; procedure TForm1.BHitungClick(Sender: TObject); var angka   : Double;     pangkat : Integer; begin angka   := StrToFloat(Edit1.Text); pangkat := StrToInt(Edit2.Text); Edit3.Text := FloatToStr(PangkatBilangan(angka,pangkat)); end; procedure TForm1.FormCreate(Sender: TObject); var x : Integer; begin   for x:=0 to ComponentCount-1 do   begin     if (Components[x] is TEdit) then     begin       (Components[x] as TEdit).Clear;     end;   end; end; end.

Hasil screenshot program :

Download Program + Source DISINI

Load Database ke ListView Delphi

2013-07-15T13:49:00.010+07:00

Berikut ini adalah contoh program sederhana, bagaimana cara meload database dan ditampilkan ke listview..
oke langsung saja.. :D

buatlah desain form kira2 seperti gambar berikut :

Berikut source code nya lengkap :


unit Unit1;interfaceuses  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  Dialogs, ComCtrls, Grids, DBGrids, XPMan, StdCtrls, ExtCtrls;typeTCustomSortStyle = (cssAlphaNum, cssNumeric, cssDateTime);  TForm1 = class(TForm)    DBGrid1: TDBGrid;    ListView1: TListView;    Button1: TButton;    XPManifest1: TXPManifest;    Button2: TButton;    StatusBar1: TStatusBar;    Timer1: TTimer;    procedure Button2Click(Sender: TObject);    procedure Button1Click(Sender: TObject);    procedure ListView1ColumnClick(Sender: TObject; Column: TListColumn);    procedure Timer1Timer(Sender: TObject);  private    { Private declarations }  public    { Public declarations }  end;var  Form1: TForm1;  { variable to hold the sort style }  LvSortStyle: TCustomSortStyle;  { array to hold the sort order }  LvSortOrder: array[0..4] of Boolean;implementationuses Unit2;{$R *.dfm}function CustomSortProc(Item1, Item2: TListItem; SortColumn: Integer): Integer; stdcall;var  s1, s2: string;  i1, i2: Integer;  r1, r2: Boolean;  d1, d2: TDateTime;  { Helper functions }  function IsValidNumber(AString : string; var AInteger : Integer): Boolean;  var    Code: Integer;  begin    Val(AString, AInteger, Code);    Result := (Code = 0);  end;  function IsValidDate(AString : string; var ADateTime : TDateTime): Boolean;  begin    Result := True;    try      ADateTime := StrToDateTime(AString);    except      ADateTime := 0;      Result := False;    end;  end;  function CompareDates(dt1, dt2: TDateTime): Integer;  begin    if (dt1 > dt2) then Result := 1    else      if (dt1 = dt2) then Result := 0    else      Result := -1;  end;  function CompareNumeric(AInt1, AInt2: Integer): Integer;  begin    if AInt1 > AInt2 then Result := 1    else      if AInt1 = AInt2 then Result := 0    else      Result := -1;  end;begin  Result := 0;  if (Item1 = nil) or (Item2 = nil) then Exit;  case SortColumn of    -1 :    { Compare Captions }    begin      s1 := Item1.Caption;      s2 := Item2.Caption;    end;    else    { Compare Subitems }    begin      s1 := '';      s2 := '';      { Check Range }      if (SortColumn < Item1.SubItems.Count) then        s1 := Item1.SubItems[SortColumn];      if (SortColumn < Item2.SubItems.Count) then        s2 := Item2.SubItems[SortColumn]    end;  end;  { Sort styles }  case LvSortStyle of    cssAlphaNum : Result := lstrcmp(PChar(s1), PChar(s2));    cssNumeric  : begin                    r1 := IsValidNumber(s1, i1);                    r2 := IsValidNumber(s2, i2);                    Result := ord(r1 or r2);                    if Result <> 0 then                      Result := CompareNumeric(i1, i2);                  end;    cssDateTime : begin                    r1 := IsValidDate(s1, d1);                    r2 := IsValidDate(s2, d2);                    Result := ord(r1 or r2);                    if Result <> 0 then                      Result := CompareDates(d1, d2);                  end;  end;  { Sort direction }  if LvSortOrder[SortColumn + 1] then    Result := - Result;end;procedure TForm1.Button1Click(Sender: TObject);vari  : Integer;LC : TListColumn;LI : TListItem;beginButton2Click(Sender);// load kolomfor i:= 0 to DM.tb.FieldCount-1 dobeginLC := self.ListView1.Columns.Add;LC.Caption := UpperCase(DM.tb.Fields [i]. FieldName);LC.Width   := 100;end;// load recordDM.tb.First;while not DM.tb.Eof dobeginLI := self.ListView1.Items.Add;LI.Caption := DM.tb.Fields [0]. AsString;for i:= 1 to DM.tb.FieldCount-1 dobeginLI.SubItems.Add (DM.tb.Fields [i]. AsString);end;DM.tb.Next;end;end;procedure TForm1.Button2Click(Sender: TObject);var i:integer;beginfor i := ListView1.Items.Count - 1 downto 0 doListView1.Items.Delete(i);for i := ListView1.Columns.Count - 1 downto 0 doListView1.Columns[i].Destroy;end;procedure TForm1.ListView1ColumnClick(Sender: TObject; Column: TListColumn);begin  case Column.Index of    0 : LvSortStyle := cssNumeric;    1 : LvSortStyle := cssAlphaNum;    2 : LvSortStyle := cssAlphaNum;  end;  { Call the CustomSort method }  ListView1.CustomSort(@CustomSortProc, Column.Index -1);  listview1.Column[1];  { Set the sort order for the column}  LvSortOrder[Column.Index] := not LvSortOrder[Column.Index];end;procedure TForm1.Timer1Timer(Sender: TObject);var s : string;begins:='Untuk mensortir klik pada kolom';if statusbar1.Panels[0].Text = s then  statusbar1.Panels[0].Text:=''else  statusbar1.Panels[0].Text:=s;end;end.

Hasil screen shot program :

Program dan source code bisa di download DISINI

Simpan dan Load File dari Database Delphi

2013-06-21T15:06:00.000+07:00

Program sederhana ini merupakan contoh cara menyimpan segala macam file berformat sembarang ke dalam database, file bisa diload / diambil lagi dari database kemudian disimpan ke hardisk. Pada contoh program ini ane menggunakan database Firebird 2.0

unit Unit1; interface uses   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,   Dialogs, DB, Grids, DBGrids, IBCustomDataSet, IBDatabase, StdCtrls, ShellAPI; type   TForm1 = class(TForm)     db: TIBDatabase;     tr: TIBTransaction;     DBGrid1: TDBGrid;     ds: TDataSource;     Button1: TButton;     Button2: TButton;     OD: TOpenDialog;     Memo1: TMemo;     Button3: TButton;     tb: TIBDataSet;     tbID: TIntegerField;     tbNAMAFILE: TIBStringField;     tbFILES: TBlobField;     tbUKURAN: TIntegerField;     procedure Button1Click(Sender: TObject);     procedure Button2Click(Sender: TObject);     procedure FormCreate(Sender: TObject);     procedure Button3Click(Sender: TObject);   private     { Private declarations }   public     { Public declarations }   end; var   Form1: TForm1; implementation {$R *.dfm} function GetSize(const AFile:String):Int64; begin //  Result := 0;   with TFileStream.Create(AFile, fmOpenRead) do   begin     try       Result := Size;     finally       Free;     end;   end; end; procedure TForm1.Button1Click(Sender: TObject); begin if OD.Execute then BEGIN   tb.Insert;   tbNAMAFILE.AsString := ExtractFileName(OD.FileName);   tbFILES.LoadFromFile(OD.FileName);   tbUKURAN.AsInteger  := GetSize(OD.FileName);   tb.Post; END; end; procedure TForm1.Button2Click(Sender: TObject); var AStrm : TMemoryStream; d,m,y : Word; s     : string; begin if tb.RecordCount = 0 then begin MessageDlg('Data Kosong',mtInformation,[mbOK],0); Exit; end; if MessageDlg('Load File ?',mtConfirmation,[mbYes,mbNo],0)=mrYes then begin DecodeDate(Date(),y,m,d); s := IntToStr(d)+IntToStr(m)+IntToStr(y)+'-'; //download file, jika belum ada folder DOWNLOAD maka buat Foldernya dulu if not DirectoryExists(ExtractFilePath(ParamStr(0))+'Download') then       ForceDirectories(ExtractFilePath(ParamStr(0))+'Download'); //mengambil file dari database dan disimpan pada MemoryStream AStrm:=TMemoryStream.Create; TBlobField(tb.FieldByName('FILES')).SaveToStream(AStrm); // jika file sudah ada, maka buat file dengan nama ada tanggalnya if FileExists(ExtractFilePath(ParamStr(0))+'Download\'+tbNAMAFILE.AsString+'') then begin      AStrm.SaveToFile(ExtractFilePath(ParamStr(0))+'Download\'+s+tbNAMAFILE.AsString+''); end else      AStrm.SaveToFile(ExtractFilePath(ParamStr(0))+'Download\'+tbNAMAFILE.AsString+'');      AStrm.Free; MessageDlg('Download Berhasil...!!!'+#13+'File Sudah Tersimpan di Folder '+ #13+ExtractFilePath(ParamStr(0))+'Download',mtInformation,[mbOK],0); //buka folder download ShellExecute(handle, 'Open',PChar(ExtractFilePath(ParamStr(0))+'Download'), nil, nil, SW_SHOWNORMAL); end; end; procedure TForm1.Button3Click(Sender: TObject); begin if tb.RecordCount = 0 then begin MessageDlg('Data Kosong',mtInformation,[mbOK],0); Exit; end;   if MessageDlg('Hapus File ?',mtConfirmation,[mbYes,mbNo],0)=mrYes then     tb.Delete; end; procedure TForm1.FormCreate(Sender: TObject); begin if db.Connected = True then db.Connected:=False;   db.DatabaseName :='';   if db.DatabaseName = '' then       db.DatabaseName := ExtractFilePath(ParamStr(0))+'DATA.FDB';       db.Open;       tb.Open;  end; end.

Hasil Screen Shot Program :

Program dan Source Code bisa didownload DISNI

Cek Ukuran File Delphi

2013-06-17T10:43:00.000+07:00

Program sederhana dari delphi untuk mengecek ukuran file.

unit Unit1; interface uses   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,   Dialogs, StdCtrls, Buttons; type   TForm1 = class(TForm)     OD: TOpenDialog;     BitBtn1: TBitBtn;     Label1: TLabel;     Edit1: TEdit;     Label2: TLabel;     procedure BitBtn1Click(Sender: TObject);   private     { Private declarations }   public     { Public declarations }   end; var   Form1: TForm1;   nilai,hasil: Double; implementation {$R *.dfm} function GetSize(const AFile:String):Int64; begin   Result := 0;   with TFileStream.Create(AFile, fmOpenRead) do   begin     try       Result := Size;     finally       Free;     end;   end; end; procedure TForm1.BitBtn1Click(Sender: TObject); begin if OD.Execute then Edit1.Text := IntToStr(GetSize(OD.FileName)); end; end.

Hasil screenshot :

Program dan Source Code dapat didownload DISINI

Menggunakan Fast Report Secara Runtime

2013-05-29T15:41:00.000+07:00

Pada contoh yang ane pakai adalah delphi 2007 dan Fast Report 4.12.

Untuk databasenya ane pakai Ms. Access. Langsung sajalah... :D

Recompile Fast Report sesuaikan dengan versi delphi yang dipakai.
contoh seperti gambar berikut :

Setelah tercompile akan terbentuk folder LibD11 (Delphi2007), nah didalam folder itu berisi paket-paket komponen fast report yang nanti akan dipakai.

Tambahkan library path pada delphi, pada contoh :

"C:\Program Files\CodeGear\RAD Studio\5.0\FastReport 4.12\LibD11"

Compile file-file berikut : tanda (*) merupakan versi dari delphi yang dipakai.

fs*.dpk - FastScript, main package
fsDB*.dpk - FastScript, DB classes and controls
fsBDE*.dpk - FastScript, BDE components
fsADO*.dpk - FastScript, ADO components
fsIBX*.dpk - FastScript, IBX components
fsTee*.dpk - FastScript, TeeChart components
frx*.dpk - FastReport, main package
frxDB*.dpk - FastReport, TDataSet wrapper (TfrxDBDataSet)
frxIBO*.dpk - FastReport, IB_Objects wrapper (TfrxIBODataSet)
frxBDE*.dpk - FastReport, end-user BDE components
frxADO*.dpk - FastReport, end-user ADO components
frxIBX*.dpk - FastReport, end-user IBX components
frxDBX*.dpk - FastReport, end-user DBX components
frxTee*.dpk - FastReport, TeeChart components
frxe*.dpk - FastReport, export filters

Sekarang kita buat program sederhana, buatlah kira-kira seperti gambar berikut :

1 ADOConnection

1 ADOTable

3 Button

Tambahkan Uses : frxClass, frxDBSet, frxDesgn

Tambahkan variabel : dbPath, frx, frxDB

Berikut Source Code untuk tombol Design Report, Preview Report dan Print Report :

Full Source Code

unit Unit1; 
interface 
uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
Forms,Dialogs, frxClass, frxDBSet, frxDesgn, StdCtrls, DB, ADODB;
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Button2: TButton; 
    Button3: TButton; 
    ADOConnection1: TADOConnection; 
    ADOTable1: TADOTable; 
    procedure FormCreate(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
  private 
    { Private declarations } 
  public 
    { Public declarations } 
  end; 
 
var 
  Form1  : TForm1;
  dbPath : string;
  frx    : TfrxReport;
  frxDB  : TfrxDBDataset;

implementation

{$R *.dfm}

// Tombol Design Report 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  frxDB.DataSet  := ADOTable1; 
  frxDB.UserName := 'mahasiswa'; 
  frx.DesignReport; 
end; 
 
// Tombol Preview Report 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  frxDB.DataSet  := ADOTable1; 
  frxDB.UserName := 'mahasiswa'; 
  frx.LoadFromFile(ExtractFilePath(ParamStr(0))+'Reports\cobacoba.fr3'); 
  frx.ShowReport; 
end; 
 
// Tombol Print Report 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  frxDB.DataSet  := ADOTable1; 
  frxDB.UserName := 'mahasiswa'; 
  frx.LoadFromFile(ExtractFilePath(ParamStr(0))+'Reports\cobacoba.fr3'); 
  frx.PrepareReport; 
  frx.Print; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  dbPath:=ExtractFilePath(ParamStr(0))+'\coba.mdb'; 
  ADOConnection1.ConnectionString:='Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+dbPath+';Persist Security Info=False'; 
  ADOConnection1.Connected := True; 
  ADOTable1.TableName := 'mhs'; 
  ADOTable1.Active    := True; 
  frx    := TfrxReport.Create(Self); 
  frxDB  := TfrxDBDataset.Create(Self); 
end; 
end.

Setelah selesai sekarang Fast Report sudah bisa dipakai secara runtime, meskipun agak ribet sih.. wkwkwk... :D Jalankan program dan klik tombol Design Report maka akan muncul Fast Report Designer, nah disitu kita bisa buat atau mendesain tampilan report sesuai yang diinginkan.

Pada saat mendesain report kita tambahkan dulu dataset nya dengan cara klik pada menu Report > Data > tambahkan dataset yang diberi nama mahasiswa tadi. seperti gambar berikut :

Contoh desain Fast Report yang ane buat, dan ane beri nama cobacoba.fr3

Berikut hasil reportnya yang ane screen shot :D

Yang lagi males ngoding nih ada Full Source Code dan Programnya, silahkan download aja DISINI

Membatalkan Form Always On Top Delphi

2013-05-15T16:19:00.000+07:00

Dulu ane pernah posting cara membuat form always on top dengan delphi.
Nah kali ini ane mau berbagi sedikit tips cara membatalkan form always on top tersebut..
Langsung saja.. :D

Progam + Source Code bisa didownload DISINI

Hasil screenshot program

Import Dari Excel ke Database Firebird-Interbase Delphi

2013-04-24T09:43:00.000+07:00

Males nulis ane... wkwkwkk..... :D langsung saja dah ini unit full langsung pake..

Dibuat dengan delphi 2007, make komponen Interbase ( Standar ).

Sudah di uji coba dengan database Firebird 2.0 SQL Dialect 3.

unit uMain; interface uses   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,   Dialogs, StdCtrls, XPMan, Grids, DBGrids, DB, IBCustomDataSet, IBQuery,   IBDatabase, ComObj; type   TFImport = class(TForm)     XPManifest1: TXPManifest;     OD: TOpenDialog;     Button1: TButton;     DBGrid1: TDBGrid;     db: TIBDatabase;     tr: TIBTransaction;     ds: TDataSource;     Label1: TLabel;     Label2: TLabel;     tb: TIBDataSet;     Button2: TButton;     Q1: TIBQuery;     tbNOPOL: TIBStringField;     tbJENIS: TIBStringField;     tbJTEMPO: TDateField;     tbEX_NOPOL: TIBStringField;     procedure ProsesFromExcel(pFileName:String) ;     procedure Button1Click(Sender: TObject);     procedure FormCreate(Sender: TObject);     procedure FormShow(Sender: TObject);     procedure Button2Click(Sender: TObject);   private     { Private declarations }   public     { Public declarations }   end; var   FImport: TFImport; implementation {$R *.dfm} procedure TFImport.Button1Click(Sender: TObject); begin   if OD.Execute then     ProsesFromExcel(OD.FileName); end; procedure TFImport.Button2Click(Sender: TObject); begin if MessageDlg('Hapus semua record ?',mtConfirmation,[mbYes,mbNo],0) = mrYes then begin   Q1.Close;   Q1.SQL.Clear;   Q1.SQL.Add('delete from COBA');   Q1.ExecSQL;   tb.ApplyUpdates;   tb.Transaction.CommitRetaining;   tb.Close;   tb.Open;   Label2.Caption :='0'; end; end; procedure TFImport.FormCreate(Sender: TObject); begin try   if db.Connected = True then db.Connected:=False;   db.DatabaseName:=ExtractFilePath(ParamStr(0))+'Data\COBA.FDB';   db.Open;   Label2.Caption :='0'; except     MessageDlg('Database Tidak Terkoneksi..!!',mtError,[mbOK],0);     Application.Terminate; end; end; procedure TFImport.FormShow(Sender: TObject); begin   tb.Open; end; procedure TFImport.ProsesFromExcel(pFileName:String) ; var baris : Word; ExcelApp: OleVariant ; JML_BERHASIL : Integer; vNOPOL,vJENIS,vEX_NOPOL : string; vJTEMPO : TDateTime; BEGIN try   ExcelApp := CreateOleObject('Excel.Application');   ExcelApp.Workbooks.Open(pFileName);   JML_BERHASIL := 0;   tb.Close;   tb.Open;   baris := 3; REPEAT   vNOPOL         := VarToStr(ExcelApp.Cells[baris,1]) ;   vJENIS         := VarToStr(ExcelApp.Cells[baris,2]) ;   vJTEMPO        := VarToDateTime(ExcelApp.Cells[baris,3]) ;   vEX_NOPOL      := VarToStr(ExcelApp.Cells[baris,4]) ;     tb.Insert;   tbNOPOL.AsString        := vNOPOL;   tbJENIS.AsString        := vJENIS;   tbJTEMPO.AsDateTime     := vJTEMPO;   tbEX_NOPOL.AsString     := vEX_NOPOL;   tb.ApplyUpdates;   tb.Transaction.CommitRetaining;   JML_BERHASIL := JML_BERHASIL + 1;   Label2.Caption := IntToStr(JML_BERHASIL);   baris := baris+1; UNTIL VarToStr(ExcelApp.cells[baris,1]) = '' ;   ExcelApp.DisplayAlerts := False;   ExcelApp.Quit;   tb.Close;   tb.Open;     MessageDlg('Import Berhasil',mtInformation,[mbOK],0); except   MessageDlg('Proses Import Gagal',mtInformation,[mbOK],0);   ExcelApp.Quit; end; END; end.

Kalo males ngoding, nih udah ane sediain project jadi full source... :D

Download aja DISINI

Mengambil Mac Address Delphi

2013-04-20T10:48:00.000+07:00

Program sederhana untuk mengambil Mac Address dengan Delphi

Pertama buatlah Unit dengan nama GetMacAddress, kemudian simpan.

isi unit nya sbb :

unit GetMacAddress; interface uses classes, sysutils; const MAX_INTERFACE_NAME_LEN = $100; ERROR_SUCCESS = 0; MAXLEN_IFDESCR = $100; MAXLEN_PHYSADDR = 8; MIB_IF_OPER_STATUS_NON_OPERATIONAL = 0 ; MIB_IF_OPER_STATUS_UNREACHABLE = 1; MIB_IF_OPER_STATUS_DISCONNECTED = 2; MIB_IF_OPER_STATUS_CONNECTING = 3; MIB_IF_OPER_STATUS_CONNECTED = 4; MIB_IF_OPER_STATUS_OPERATIONAL = 5; MIB_IF_TYPE_OTHER = 1; MIB_IF_TYPE_ETHERNET = 6; MIB_IF_TYPE_TOKENRING = 9; MIB_IF_TYPE_FDDI = 15; MIB_IF_TYPE_PPP = 23; MIB_IF_TYPE_LOOPBACK = 24; MIB_IF_TYPE_SLIP = 28; MIB_IF_ADMIN_STATUS_UP = 1; MIB_IF_ADMIN_STATUS_DOWN = 2; MIB_IF_ADMIN_STATUS_TESTING = 3; type MIB_IFROW = Record wszName : Array[0 .. (MAX_INTERFACE_NAME_LEN*2-1)] of char; dwIndex : LongInt; dwType : LongInt; dwMtu : LongInt; dwSpeed : LongInt; dwPhysAddrLen : LongInt; bPhysAddr : Array[0 .. (MAXLEN_PHYSADDR-1)] of Byte; dwAdminStatus : LongInt; dwOperStatus : LongInt; dwLastChange : LongInt; dwInOctets : LongInt; dwInUcastPkts : LongInt; dwInNUcastPkts : LongInt; dwInDiscards : LongInt; dwInErrors : LongInt; dwInUnknownProtos : LongInt; dwOutOctets : LongInt; dwOutUcastPkts : LongInt; dwOutNUcastPkts : LongInt; dwOutDiscards : LongInt; dwOutErrors : LongInt; dwOutQLen : LongInt; dwDescrLen : LongInt; bDescr : Array[0 .. (MAXLEN_IFDESCR - 1)] of Char; end; function Get_EthernetAddresses: TStringList; Function GetIfTable( pIfTable : Pointer; VAR pdwSize : LongInt; bOrder : LongInt ): LongInt; stdcall; implementation Function GetIfTable; stdcall; external 'MacAddress.dll'; function Get_EthernetAddresses: TStringList; const _MAX_ROWS_ = 20; type _IfTable = Record nRows : LongInt; ifRow : Array[1.._MAX_ROWS_] of MIB_IFROW; end; VAR pIfTable : ^_IfTable; TableSize : LongInt; tmp : String; i,j : Integer; ErrCode : LongInt; begin pIfTable := nil; //--------------------------------------------------------------- Result:=TStringList.Create; if Assigned(Result) then try //------------------------------------------------------- // First: just get the buffer size. // TableSize returns the size needed. TableSize:=0; // Set to zero so the GetIfTabel function // won't try to fill the buffer yet, // but only return the actual size it needs. GetIfTable(pIfTable, TableSize, 1); if (TableSize < SizeOf(MIB_IFROW)+Sizeof(LongInt)) then begin Exit; // less than 1 table entry?! end; // if-end. // Second: // allocate memory for the buffer and retrieve the // entire table. GetMem(pIfTable, TableSize); ErrCode := GetIfTable(pIfTable, TableSize, 1); if ErrCode<>ERROR_SUCCESS then begin Exit; // OK, that did not work. // Not enough memory i guess. end; // if-end. // Read the ETHERNET addresses. for i := 1 to pIfTable^.nRows do try if pIfTable^.ifRow[i].dwType=MIB_IF_TYPE_ETHERNET then begin tmp:=''; for j:=0 to pIfTable^.ifRow[i].dwPhysAddrLen-1 do begin tmp := tmp + format('%.2x', [ pIfTable^.ifRow[i].bPhysAddr[j] ] ); end; // for-end. //------------------------------------- if Length(tmp)>0 then Result.Add(tmp); end; // if-end. except Exit; end; // if-try-except-end. finally if Assigned(pIfTable) then FreeMem(pIfTable,TableSize); end; // if-try-finally-end. end; end.

Sertakan file library MacAddress.dll dalam satu folder project.

Tambahkan satu Memo dan Button pada Form.

Tambahkan unit GetMacAddress yg di buat tadi.

File > Use Unit... tambahkan unit nya..

Cara Menggunakannya. Double klik button dan tulis code sbb :

Hasil Screenshot Program :

Contoh program diatas ada dua Mac Address karena pada PC ane ada 2 Mac Address, yang satu asli punya PC, yang satunya lagi punya Hamchi.

Download Program dan Source Code nya DISINI

Backup dan Restore Firebird/Interbase via CMD

2013-04-06T11:51:00.000+07:00

Dalam contoh postingan ini ane pake Firebird 2.0

Pada intinya sama, kita letakan path nya dimana file GBAK.exe itu berada.

Untuk lebih jelasnya silahkan lihat pada gambar.

Backup

gbak -v -user sysdba -pass masterkey [file_database] [file_backup]

Contoh:

gbak.exe -v -user sysdba -pass masterkey D:\_MemOnLine\Data\MEMO.GDB C:\MEMO.GBK

Contoh jika database ada di komputer lain :
gbak.exe -v -c -r -k -user sysdba -pass masterkey 10.10.1.209:D:\_MemOnLine\Data\MEMO.GDB C:\MEMO.GBK

Restore

gbak -v -c -r -k -user sysdba -pass masterkey [file_backup] [file_database]

Contoh:

gbak.exe -v -c -r -k -user sysdba -pass masterkey C:\MEMO.GBK C:\MEMO.GDB

Catatan sedikit untuk proses Restore :

kalo pingin ada pengaman (ditolak jika sudah ada file databasenya) buang comand -r
-r = replace. akan ditolak jika database masih dipake/ tidak tahu user&pass nya.

Membuka Folder Delphi

2013-04-01T10:21:00.000+07:00

Seletah membahas tentang cara membuat folder dan subfolder, menghapus folder beserta file di dalamnya, sekarang cara membuka folder delphi.

Caranya cukup mudah, langsung saja ke TKP :D

Tambahkan Uses ShellAPI

Memanggil File Word Delphi

2013-03-19T10:29:00.001+07:00

Tambahkan Uses ShellAPI

Memanggil dari PC sendiri :
Memanggil dari PC lain, dengan catatan udah dishare drive nya :

NB : Format .doc bisa juga diganti dengan .docx disesuaikan aja...