Jejak Rinda Cahyana: Bahasa Pemrograman

Tampilkan postingan dengan label Bahasa Pemrograman. Tampilkan semua postingan

Senin, 06 Oktober 2014

Format Uang

type tFormatUang=Record
        Text:String;
        SelStart:Integer;
        end;

function FormatUang(input:string):tFormatUang;
var
sRupiah: string;
min,i,c:word; dec:boolean;
begin
        sRupiah:='';
        c:=1;
        dec:=false;

        if length(input)>0 then
        begin
        if input[1]='-' then min:=2 else min:=1;

        for i:=length(input) downto min do
        if input[i]='.' then dec:=true;

        for i:=length(input) downto min do
        begin
                if input[i] in ['0'..'9','.','-'] then
                begin
                        if input[i]='.' then
                        begin
                                dec:=false;
                                c:=0;
                        end;
                        if c=4 then
                        begin
                                if dec=false then sRupiah:=input[i]+','+sRupiah;
                                c:=1;
                        end else sRupiah:=input[i]+sRupiah;
                        if dec=false then inc(c);
                end;
        end;

        if input[1]='-' then sRupiah:='-'+sRupiah;

        end;
        FormatUang.Text := sRupiah;
        FormatUang.SelStart := length(sRupiah);
end;

Contoh :

procedure TForm1.Edit1Change(Sender: TObject);
begin
        Edit1.Text:=FormatUang(Edit1.Text).Text;
        Edit1.SelStart:=FormatUang(Edit1.Text).SelStart;
end;

Memberi warna DBGrid

Contoh memberi warna pada komponen DBGrid dengan nama komponen DBGrid1 :

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
//Memberi warna $00E9D358 jika data population dalam tabel1 > 25000000
if Table1.FieldByName(‘Population‘).AsInteger > 25000000 then
TDBGrid(Sender).Canvas.Brush.Color := $00E9D358;
TDBGrid(Sender).DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;

Menghilangkan karakter dalam kata

By Unknown 22.38 Bahasa Pemrograman , Pengajaran No comments

BEGIN
before:='12,000,000';
StringReplace(before, ',', '',[rfReplaceAll, rfIgnoreCase]);
//koma dihilangkan
ShowMessage(before);
END;

Format uang pada komponen Edit

By Unknown 22.32 Bahasa Pemrograman , Pengajaran No comments


var

sRupiah: string;

iRupiah: Currency;

begin

//ribuan --> currency ( menyesuaikan setting windows )

sRupiah := Edit1.Text;

sRupiah := StringReplace(sRupiah,',','',[rfReplaceAll,rfIgnoreCase]); 
// hilangkan char koma , pemisah //ribuan selain IDR

sRupiah := StringReplace(sRupiah,'.','',[rfReplaceAll,rfIgnoreCase]);

//remove char titik .    pemisah //ribuan IDR

iRupiah := StrToCurrDef(sRupiah,0); // convert srupiah ke currency



//currency --> format ribuan

edit1.Text := FormatCurr('#,###',iRupiah);

edit1.SelStart := length(edit1.text);

Mengatur angka di belakang koma

By Unknown 23.52 Bahasa Pemrograman , Pengajaran No comments

Perintahnya :Format('%8.2f'[])

2 menunjukan jumlah angka di belakang komanya, yakni 2.

diganti dengan angka floatnyaFungsi di atas menghasilkan keluaran bertipe string.

Menyimpan jpg ke database

By Unknown 20.02 Bahasa Pemrograman , Pengajaran 1 comment

Seluruh kode yang ditulis di sini memerlukan unit DB dan jpeg sehingga harus dituliskan

uses DB, jpeg;

Cara untuk menyimpan file gambar ke dalam field "photo" bertipe text milik tabel dalam basis data SQL Server adalah sebagai berikut :

Tambahkan komponen bernama OpenDialog1, ADOQuery1, Button1, dan Image1
Pada event onClick komponen tombol Button1, tuliskan kode berikut :

procedure TFormPustaka.Button1Click(Sender: TObject);

var

FileStream: TFileStream;

BlobStream: TStream;

begin

OpenDialog1.Execute;

ADOQuery1.Edit;

try

BlobStream := ADOQuery1.CreateBlobStream(ADOQuery1.FieldByName('photo'),bmWrite);

FileStream := TFileStream.Create(OpenDialog1.FileName,fmOpenRead or fmShareDenyNone);

BlobStream.CopyFrom(FileStream,FileStream.Size);

FileStream.Free;

BlobStream.Free;

ADOQuery.Post; // menimpan gambar ke field "photo"

QDataPustakaAfterScroll(QDataPustaka); // memanggil event AfterScroll (di bawah)

except

ADOQuery1.Cancel;

end;

Cara untuk menampilkan data gambar yang merupakan isi field "photo" dengan menggunakan komponen ADOQuery1 dan Image1 adalah sebagai berikut :

Pastikan properti string dari komponen ADOQuery1 mengandung SQL yang terhubung ke tabel yang memiliki field bertipe text.
Pada event AfterScroll dari komponen ADOQuery1, tuliskan perintah berikut ini :

procedure ADOQuery1AfterScroll(DataSet: TDataSet);

var

JpegImage: TJPEGImage;

BlobStream: TStream;

begin

if (not ADOQuery1.FieldByName('photo').IsNull) then

begin

BlobStream:= ADOQuery1.CreateBlobStream(ADOQuery1.FieldByName('photo'),bmRead);

JpegImage := TJPEGImage.Create;

try

JpegImage.LoadFromStream(BlobStream);

Image1.Picture.Assign(JpegImage);

Image1.Visible := True; // ini tidak perlu jika Image1.Visible := False; tdk ditulis di bawah

finally

JpegImage.Free;

BlobStream.Free;

end;

end

else

Image1.Visible := False; // atau bisa juga Image1.Picture.Assign(nil);

end;

Tambahkan DBGrid, kemudian hubungkan dengan ADOQuery menggunakan DataSource. Setiap anda mengklik sel DBGrid, maka apabila field "photo" pada record tersebut mengandung gambar, akan muncul gambarnya di komponen image1.

Enkripsi dan Deskripsi Password

By Unknown 22.46 Bahasa Pemrograman , Pengajaran No comments

unit uEncrypt;

interface

function Decrypt(const S: AnsiString; Key: Word): AnsiString;

function Encrypt(const S: AnsiString; Key: Word): AnsiString;

implementation

const

C1 = 52845;

C2 = 22719;

function Decode(const S: AnsiString): AnsiString;

const

Map: array[Char] of Byte = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, 0, 0, 0, 63, 52, 53,

54, 55, 56, 57, 58, 59, 60, 61, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2,

3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,

20, 21, 22, 23, 24, 25, 0, 0, 0, 0, 0, 0, 26, 27, 28, 29, 30,

31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,

46, 47, 48, 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

0);

var

I: LongInt;

begin

case Length(S) of

begin

I := Map[S[1]] + (Map[S[2]] shl 6);

SetLength(Result, 1);

Move(I, Result[1], Length(Result))

end;

begin

I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12);

SetLength(Result, 2);

Move(I, Result[1], Length(Result))

end;

begin

I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12) +

(Map[S[4]] shl 18);

SetLength(Result, 3);

Move(I, Result[1], Length(Result))

end

end;

function PreProcess(const S: AnsiString): AnsiString;

var

SS: AnsiString;

begin

SS := S;

Result := '';

while SS <> '' do

begin

Result := Result + Decode(Copy(SS, 1, 4));

Delete(SS, 1, 4)

end

end;

function InternalDecrypt(const S: AnsiString; Key: Word): AnsiString;

var

I: Word;

Seed: Word;

begin

Result := S;

Seed := Key;

for I := 1 to Length(Result) do

begin

Result[I] := Char(Byte(Result[I]) xor (Seed shr 8));

Seed := (Byte(S[I]) + Seed) * Word(C1) + Word(C2)

end

end;

function Decrypt(const S: AnsiString; Key: Word): AnsiString;

begin

Result := InternalDecrypt(PreProcess(S), Key)

end;

function Encode(const S: AnsiString): AnsiString;

const

Map: array[0..63] of Char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +

'abcdefghijklmnopqrstuvwxyz0123456789+/';

var

I: LongInt;

begin

I := 0;

Move(S[1], I, Length(S));

case Length(S) of

Result := Map[I mod 64] + Map[(I shr 6) mod 64];

Result := Map[I mod 64] + Map[(I shr 6) mod 64] +

Map[(I shr 12) mod 64];

Result := Map[I mod 64] + Map[(I shr 6) mod 64] +

Map[(I shr 12) mod 64] + Map[(I shr 18) mod 64]

end

end;

function PostProcess(const S: AnsiString): AnsiString;

var

SS: AnsiString;

begin

SS := S;

Result := '';

while SS <> '' do

begin

Result := Result + Encode(Copy(SS, 1, 3));

Delete(SS, 1, 3)

end

end;

function InternalEncrypt(const S: AnsiString; Key: Word): AnsiString;

var

I: Word;

Seed: Word;

begin

Result := S;

Seed := Key;

for I := 1 to Length(Result) do

begin

Result[I] := Char(Byte(Result[I]) xor (Seed shr 8));

Seed := (Byte(Result[I]) + Seed) * Word(C1) + Word(C2)

end

end;

function Encrypt(const S: AnsiString; Key: Word): AnsiString;

begin

Result := PostProcess(InternalEncrypt(S, Key))

end;

end.

Sumber : http://www.swissdelphicenter.ch/torry/showcode.php?id=1243

Mengkonversi IP address ke Hostname

By Unknown 14.10 Bahasa Pemrograman , Pengajaran No comments

Menggunakan winsock



function IPAddrToName(IPAddr: string): string;

var SockAddrIn:TSockAddrIn;HostEnt:PHostEnt;WSAData:TWSAData;

begin

WSAStartup($101,WSAData);

SockAddrIn.sin_addr.s_addr:=inet_addr(PChar(IPAddr));

HostEnt:= GetHostByAddr(@SockAddrIn.sin_addr.S_addr,4,AF_INET);

if HostEnt<>nil then Rresult:=StrPas(Hostent^.h_name)

else Result:='';

end;

Menangani masalah instalasi Lazarus di Ubuntu 10

By Unknown 13.43 Bahasa Pemrograman , Pengajaran 7 comments

Untuk menginstall Lazarus di Ubuntu 10, cara paling mudah adalah mencari installer nya di Ubuntu Software Center. Anda bisa menemukannya dengan memberikan kata kunci Lazarus. Setelah installer ditemukan, tinggal klik tombol install nya.

Jika setelah proses instal tersebut anda mencoba menjalankannya, sebelum masuk ke dalam IDE Lazarus akan ada informasi yang menyatakan bahwa direktory source free pascal tidak ditemukan. Jika diabaikan, kemudian project dijalankan dengan menekan tombol F9, akan ada pesan kesalahan yang merujuk kepada informasi awal. Untuk menangani masalah tersebut, cari installer Free Pascal Compiler - Source Code di Ubuntu Software Center dengan memasukan keyword FPC. Setelah ditemukan, klik tombol instal nya.

Jika setelah proses instal tersebut anda mencoba menjalankannya, tidak akan muncul lagi informasi yang menyatakan direktori source free pascal tidak ditemukan. Jika anda menekan tombol F9 tanpa menambahkan komponen apapun, maka anda akan mendapatkan aplikasi berhasil dijalankan. Namun saat anda hendak mengakses event procedure milik komponen, akan ada pesan kesalahan yang menyatakan ppu nya tidak ditemukan. Untuk menangani masalah tersebut, cari MSEide+MSEgui - source files di Ubuntu Software Center dengan memasukan keyword FPC. Setelah ditemukan, klik tombol instal nya.

Setelah itu ... Lazarus pun sudah bisa digunakan untuk keperluan proyek anda.

Kesimpulannya, untuk memasang Lazarus di Ubuntu, tiga installer yang harus dijalankan:

Lazarus
Free pascal compiler - source code
MSEide+MSEgui - source files

Mengubah wallpaper dan mematikan screensaver dengan memanipulasi registry

By Unknown 22.58 Bahasa Pemrograman , Pengajaran No comments

uses registry;
procedure TForm1.FormCreate(Sender: TObject) ;
var
reg:TRegistry;
begin
reg:=TRegistry.Create;
with reg do begin
try
if OpenKey('\Control Panel\desktop', False) then begin
//change wallpaper and tile it
reg.WriteString ('Wallpaper','c:\windows\CIRCLES.bmp') ;
reg.WriteString ('TileWallpaper','1') ;
//disable screen saver//('0'=disable, '1'=enable)
reg.WriteString('ScreenSaveActive','0') ;
//update changes immediately
SystemParametersInfo (SPI_SETDESKWALLPAPER,0, nil,SPIF_SENDWININICHANGE) ;
SystemParametersInfo (SPI_SETSCREENSAVEACTIVE,0, nil,SPIF_SENDWININICHANGE) ;
end
finally
reg.Free;
end;
end;
end;

Menampilkan Informasi BIOS

By Unknown 22.56 Bahasa Pemrograman , Pengajaran No comments

function GetBiosInfoAsText: string;
var
p, q: pchar;
begin
q := nil;
p := PChar(Ptr($FE000));
repeat
if q <> nil then begin
if not (p^ in [#10, #13, #32..#126, #169, #184]) then begin
if (p^ = #0) and (p - q >= 8) then begin
Result := Result + TrimRight(String(q)) + #13#10;
end;
q := nil;
end;
end else
if p^ in [#33..#126, #169, #184] then
q := p;
inc(p);
until p > PChar(Ptr($FFFFF));
Result := TrimRight(Result);
end;

Checksum BIOS

By Unknown 22.55 Bahasa Pemrograman , Pengajaran No comments

function GetBiosCheckSum: string;
var
s: int64;
i: longword;
p: PChar;
begin
i := 0;
s := 0;
p := PChar($F0000);
repeat
inc(s, Int64(Ord(p^)) shl i);
if i < 64 then inc(i) else i := 0;
inc(p);
until p > PChar($FFFFF);
Result := IntToHex(s,16);
end;

Nomor Serial BIOS

By Unknown 22.54 Bahasa Pemrograman , Pengajaran No comments

uses SHA1, Base64;

function GetHashedBiosInfo: string;
var
SHA1Context: TSHA1Context;
SHA1Digest: TSHA1Digest;
begin
// Get the BIOS data
SetString(Result, PChar(Ptr($F0000)), $10000);
// Hash the string
SHA1Init(SHA1Context);
SHA1Update(SHA1Context, PChar(Result), Length(Result));
SHA1Final(SHA1Context, SHA1Digest);
SetString(Result, PChar(@SHA1Digest), sizeof(SHA1Digest));
// Return the hash string encoded in printable characters
Result := B64Encode(Result);
end;

Nomor Serial BIOS

By Unknown 22.54 Bahasa Pemrograman , Pengajaran No comments

Mematikan Mouse dan Keyboard selama 5 detik

By Unknown 22.52 Bahasa Pemrograman , Pengajaran No comments

procedure TForm1.Button1Click(Sender: TObject) ;

function FuncAvail
(_dllname, _funcname: string; var _p: pointer):
boolean;
var _lib: tHandle;
begin
Result := false;
_p := NIL;
if LoadLibrary(PChar(_dllname)) = 0 then exit;
_lib := GetModuleHandle(PChar(_dllname)) ;
if _lib <> 0 then
begin
_p := GetProcAddress(_lib, PChar(_funcname)) ;
if _p <> NIL then Result := true;
end;
end;

var
xBlockInput : function(Block: BOOL):
BOOL; stdcall;

begin
if FuncAvail
('USER32.DLL', 'BlockInput', @xBlockInput) then
begin
xBlockInput(true) ;
Sleep(5000) ;
xBlockInput(false) ;
end;
end;

Mengambil nama komputer dan penggunanya

By Unknown 22.51 Bahasa Pemrograman , Pengajaran No comments

function GetComputerNetName: string;
var
buffer: array[0..255] of char;
size: dword;
begin
size := 256;
if GetComputerName(buffer, size) then
Result := buffer
else
Result := ''
end;

Function GetUserFromWindows: string;
Var
UserName : string;
UserNameLen : Dword;
Begin
UserNameLen := 255;
SetLength(userName, UserNameLen) ;
If GetUserName(PChar(UserName), UserNameLen) Then
Result := Copy(UserName,1,UserNameLen - 1)
Else
Result := 'Unknown';
End;

Menampilkan proses yang sedang berjalan di Windows

By Unknown 22.47 Bahasa Pemrograman , Pengajaran No comments

function EnumProcess(hHwnd: HWND; lParam : integer): boolean; stdcall;
var
pPid : DWORD;
title, ClassName : string;
begin
//if the returned value in null the
//callback has failed, so set to false and exit.
if (hHwnd=NULL) then
begin
result := false;
end
else
begin
//additional functions to get more
//information about a process.
//get the Process Identification number.
GetWindowThreadProcessId(hHwnd,pPid);
//set a memory area to receive
//the process class name
SetLength(ClassName, 255);
//get the class name and reset the
//memory area to the size of the name
SetLength(ClassName,
GetClassName(hHwnd,
PChar(className),
Length(className)));
SetLength(title, 255);
//get the process title; usually displayed
//on the top bar in visible process
SetLength(title, GetWindowText(hHwnd, PChar(title), Length(title)));
//Display the process information
//by adding it to a list box
ProcessForm.ProcessListBox.Items.Add
('Class Name = ' + className +
'; Title = ' + title +
'; HWND = ' IntToStr(hHwnd) +
'; Pid = ' + IntToStr(pPid));
Result := true;
end;
end;

procedure TProcessForm.GetProcessButtonClick(Sender: TObject);
begin
//Clear any previous calls
if ProcessListBox.Count > 0 then
ProcessListBox.Clear;
//define the tag flag
lp := 0; //globally declared integer
//call the windows function with the address
//of handling function and show an error message if it fails
if EnumWindows(@EnumProcess,lp) = false then
ShowMessage('Error: Could not obtain
process window hook from system.');
end;

Mematikan ALT+TAB, CTRL+ESC, CTRL+ALT+DEL

By Unknown 22.47 Bahasa Pemrograman , Pengajaran No comments

procedure SystemKeys(Disable: Boolean) ;
var OldVal : LongInt;
begin
SystemParametersInfo(SPI_SCREENSAVERRUNNING,
Word(Disable), @OldVal, 0) ;
end;

Mematikan Ctrl+Alt+Del Kedua

By Unknown 22.46 Bahasa Pemrograman , Pengajaran No comments

procedure DisableTaskMgr(bTF: Boolean);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_CURRENT_USER;

reg.OpenKey('Software', True);
reg.OpenKey('Microsoft', True);
reg.OpenKey('Windows', True);
reg.OpenKey('CurrentVersion', True);
reg.OpenKey('Policies', True);
reg.OpenKey('System', True);

if bTF = True then
begin
reg.WriteString('DisableTaskMgr', '1');
end
else if bTF = False then
begin
reg.DeleteValue('DisableTaskMgr');
end;
reg.CloseKey;
end;

// Example Call:
procedure TForm1.Button1Click(Sender: TObject);
begin
DisableTaskMgr(True);
end;

Mematikan Ctrl+Alt+Del Pertama

By Unknown 22.44 Bahasa Pemrograman , Pengajaran No comments

uses
Registry;

procedure EnableCTRLALTDEL(YesNo : boolean);
const
sRegPolicies = '\Software\Microsoft\Windows\CurrentVersion\Policies';
begin
with TRegistry.Create do
try
RootKey:=HKEY_CURRENT_USER;
if OpenKey(sRegPolicies+'\System\',True) then
begin
case YesNo of
False:
begin
WriteInteger('DisableTaskMgr',1);
end;
True:
begin
WriteInteger('DisableTaskMgr',0);
end;
end;
end;
CloseKey;
if OpenKey(sRegPolicies+'\Explorer\',True) then
begin
case YesNo of
False:
begin
WriteInteger('NoChangeStartMenu',1);
WriteInteger('NoClose',1);
WriteInteger('NoLogOff',1);
end;
True:
begin
WriteInteger('NoChangeStartMenu',0);
WriteInteger('NoClose',0);
WriteInteger('NoLogOff',0);
end;
end;
end;
CloseKey;
finally
Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
EnableCTRLALTDEL(true);
end;

Jejak Rinda Cahyana

Sekolah Tinggi Teknologi Garut

Program Studi Teknik Informatika

Rinda Cahyana

Senin, 06 Oktober 2014

Format Uang

Kamis, 15 Maret 2012

Memberi warna DBGrid

Kamis, 08 Maret 2012

Menghilangkan karakter dalam kata

Format uang pada komponen Edit

Kamis, 08 Desember 2011

Mengatur angka di belakang koma

Minggu, 25 September 2011

Menyimpan jpg ke database

Kamis, 22 September 2011

Enkripsi dan Deskripsi Password

Senin, 08 Agustus 2011

Mengkonversi IP address ke Hostname

Selasa, 05 April 2011

Menangani masalah instalasi Lazarus di Ubuntu 10

Rabu, 09 Juli 2008

Mengubah wallpaper dan mematikan screensaver dengan memanipulasi registry

Menampilkan Informasi BIOS

Checksum BIOS

Nomor Serial BIOS

Nomor Serial BIOS

Mematikan Mouse dan Keyboard selama 5 detik

Mengambil nama komputer dan penggunanya

Menampilkan proses yang sedang berjalan di Windows

Mematikan ALT+TAB, CTRL+ESC, CTRL+ALT+DEL

Mematikan Ctrl+Alt+Del Kedua

Mematikan Ctrl+Alt+Del Pertama

Total Tayangan Halaman

Medsos

ORCID

Pengajaran

Penelitian

Pengabdian

Senin, 06 Oktober 2014

Kamis, 15 Maret 2012

Kamis, 08 Maret 2012

document.write(ultimaFecha);

Kamis, 08 Desember 2011

Minggu, 25 September 2011

Kamis, 22 September 2011

Senin, 08 Agustus 2011

Selasa, 05 April 2011

Rabu, 09 Juli 2008

document.write(ultimaFecha);

document.write(ultimaFecha);

document.write(ultimaFecha);

document.write(ultimaFecha);

document.write(ultimaFecha);

document.write(ultimaFecha);

document.write(ultimaFecha);

document.write(ultimaFecha);

document.write(ultimaFecha);

document.write(ultimaFecha);

Total Tayangan Halaman

Medsos

ORCID

Pengajaran

Penelitian

Pengabdian