Arsip: Program Aplikasi Chat (project)

 
user image
more 17 years ago

stoopid

saya masih dalam tahap belajar pemrograman dengan delphi jadi aplikasi yg saya buat ini masi banyak kekurangannya. buat yg ingin menambahkan fitur2 / memperbaiki error2 yg ada tolong post di thread ini / kirim source codenya ke [u:68854bbdc0]mriandi at gimel dot com[/u:68854bbdc0]. emm program ini saya buat dengan tujuan kita bisa share2 ilmu dan saya juga ingin memperdalam pengetahuan pemrograman saya jadi mohon kalo ada saran / tambahan yah ^^. berikut bbrp keterangan dari program tersebut. aplikasi chat: - menggunakan komponen indy 10 - menggunakan komponen dcpcrypt2 untuk enkripsi - menggunakan ssl - menggunakan ms access untuk database user (harus set odbcnya, file dsnnya sudah disediakan. kalo mau buat sendiri dsnnya, file namenya usershare.dsn kemudian tempatkan di folder yg sama dengan exe server) - fasilitas login & password - belum ada error handlernya :oops: - tidak dapat mendeteksi client yg terputus tidak normal (bukan dengan disconnect / tutup aplikasi ). sehingga pada server masih nampak online meskipun telah terputus. source code lengkap server sidenya bisa di dl disini. http://rapidshare.com/files/3942909/server.rar 0.7 mb exenya server bisa di dl disini. http://rapidshare.com/files/3945640/exe_server.rar 0.7 mb source code lengkap client sidenya bisa di dl disini. http://rapidshare.com/files/3943735/client.rar 0.3 mb exenya client bisa di dl disini. http://rapidshare.com/files/3945975/exe_nya_client.rar 0.6 mb komponen dcpcrypt2 bisa di cari disini http://delphi.icm.edu.pl/stat/dw10lw.htm komponen indy 10 bisa di cari disini http://www.indyproject.org/Sockets/Download/index.en.aspx
user image
more 17 years ago

stoopid

[code:1:b9e0eac7c6]//made by stoopid //this application still have a lot of error and need a lot of improvement //so if you make any improvement to this application pls email me the source code to mriandi@gmail.com //this program was purposely made for studying so pls share ur knowledge unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, IdBaseComponent, IdComponent, IdCustomTCPServer, IdTCPServer,IdServerIOHandler,idcontext, StdCtrls, IdTCPConnection, DB, ADODB, Grids, DBGrids, IdTCPClient, IdSSL, IdSSLOpenSSL; type TForm1 = class(TForm) IdTCPServer1: TIdTCPServer; Timer1: TTimer; Memo1: TMemo; DataSource1: TDataSource; DBGrid1: TDBGrid; ADOTable1: TADOTable; IdTCPClient1: TIdTCPClient; Memo2: TMemo; Label1: TLabel; Label2: TLabel; Label3: TLabel; IdServerIOHandlerSSLOpenSSL1: TIdServerIOHandlerSSLOpenSSL; procedure Timer1Timer(sender:Tobject); procedure FormCreate(Sender: TObject); procedure IdTCPServerExecute(AContext: TIdContext); procedure userlist; procedure FormClose(Sender: TObject; var Action: TCloseAction); //procedure IdTCPServer1Disconnect(AContext: TIdContext); procedure IdServerIOHandlerSSLOpenSSL1GetPassword( var Password: String); procedure IdTCPServer1Connect(AContext: TIdContext); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R .dfm} procedure TForm1.Timer1Timer(Sender: TObject); begin { This approach (with the timer) is used to ensure that everything has been fully created and the application is running before we start the server up. } timer1.enabled:= false; IdTCPServer1.Active:= true; end; { TIMER1 TIMER } procedure TForm1.FormCreate(sender: tObject); var appDir: string; begin memo1.Clear; memo2.Clear; timer1.Enabled:=True; //set ssl appDir:= extractFilePath(application.exename); adotable1.connectionstring:='FILE NAME='+appdir+'usershare.dsn'; IdServerIOHandlerSSLOpenSSL1.SSLOptions.KeyFile:= appDir + 'sample.key'; IdServerIOHandlerSSLOpenSSL1.SSLOptions.CertFile:= appDir + 'sample.crt'; IdServerIOHandlerSSLOpenSSL1.SSLOptions.RootCertFile:= appDir + 'sampleRoot.pem'; //set buka table ms access adotable1.TableName:='"tbuser"'; adotable1.Open; end; procedure TForm1.IdTCPServerExecute(AContext: TIdContext); var connected: boolean; reguser,regpass,ipto,msgkirim,msg,msgfrom,msgto,line, loguser,offuser,logpas,logip: string; cekuser,disc,padduser,preglimit,preguser,pdeluser,pmsgfrom,pmsgto,loffuser,poffuser,ploguser: integer; begin connected:= true; while connected do begin try line:= AContext.Connection.IOHandler.ReadLn; logip:=acontext.Connection.Socket.Binding.PeerIP; memo2.Lines.Add(line); disc:=pos('!disconnect',line); ploguser:=pos('&',line); poffuser:=pos('!',line); pmsgfrom:=pos('@',line); pmsgto:=pos('#',line); preguser:=pos(' reguser',line); loguser:=copy(line,1,ploguser-1); offuser:=copy(line,1,poffuser-1); msgfrom:=copy(line,1,pmsgfrom-1); msgto:=copy(line,pmsgfrom+1,pmsgto-1-pmsgfrom); logpas:=copy(line,ploguser+1,length(line)-ploguser); msg:=copy(line,pmsgto+1,length(line)-pmsgto); msgkirim:=msgfrom+'#'+msg; cekuser:=memo1.Lines.IndexOf(msgto); if preguser>0 then begin padduser:=pos('add',line); pdeluser:=pos('del',line); preglimit:=pos(':',line); reguser:=copy(line,12,preglimit-1-11); regpass:=copy(line,preglimit+1,length(line)-preglimit); if padduser>0 then begin adotable1.Edit; //adotable1.AppendRecord([1,reguser,regpass]); adotable1.Next; adotable1.insertrecord([reguser,regpass]); dbgrid1.Refresh; acontext.connection.IOHandler.WriteLn('Register User Sukses'); end else if pdeluser>0 then begin ADOTable1.Locate('Nama', reguser, [loPartialKey, loCaseInsensitive]); if adotable1.FieldValues['Nama']=reguser then if adotable1.FieldValues['Password']=regpass then begin //delete ga perlu adotable1.edit adotable1.DeleteRecords(arCurrent); dbgrid1.Refresh; acontext.connection.IOHandler.WriteLn('Delete User Sukses'); end end; end; if cekuser>=0 then if pmsgfrom>0 then if pmsgfrom<pmsgto then begin ADOTable1.Locate('Nama', msgto, [loPartialKey, loCaseInsensitive]); ipto:=adotable1.FieldValues['IP']; idtcpclient1.Host:=ipto; idtcpclient1.Port:=6113; IdTCPClient1.Connect; idtcpclient1.IOHandler.WriteLn(msgkirim); idtcpclient1.Disconnect; end; if memo1.Lines.IndexOf(loguser)<1 then if ADOTable1.Locate('Nama', loguser, [loPartialKey, loCaseInsensitive]) then if Adotable1.FieldByName('Password').AsString=logpas then begin adotable1.Edit; adotable1.FieldByName('IP').NewValue:=logip; dbgrid1.Refresh; adotable1.Post; //loguser:=loguser+':'+logip; memo1.Lines.add(loguser); acontext.Connection.Socket.WriteLn('login sukses'); userlist; end else begin AContext.Connection.IOHandler.WriteLn('Username atau Password tidak benar'); end; if disc>0 then begin loffuser:=memo1.Lines.IndexOf(offuser); memo1.Lines.Delete(loffuser); end except connected:= false; end; end;//while end;//begin procedure tform1.userlist; var useronline,ipuser,usera:string; i,j:integer; begin i:=0; repeat usera:=memo1.Lines.Strings[i]; ADOTable1.Locate('Nama', usera, [loPartialKey, loCaseInsensitive]); ipuser:=adotable1.FieldValues['IP']; idtcpclient1.Host:=ipuser; idtcpclient1.Port:=6113; IdTCPClient1.Connect; idtcpclient1.IOHandler.WriteLn('~clear'); j:=0; repeat useronline:=memo1.lines.strings[j]; idtcpclient1.IOHandler.WriteLn('^'+useronline); inc(j); until j>memo1.Lines.Count; inc(i); idtcpclient1.Disconnect; until i>memo1.Lines.Count; end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin adotable1.Close; end; procedure TForm1.IdServerIOHandlerSSLOpenSSL1GetPassword( var Password: String); begin password:= 'aaaa'; end; { ID SERVER IO HANDLER SSL OPEN SSL GET PASSWORD } procedure TForm1.IdTCPServer1Connect(AContext: TIdContext); begin { THESE TWO LINES ARE CRITICAL TO MAKING THE IdTCPSERVER WORK WITH SSL! } if (AContext.Connection.IOHandler is TIdSSLIOHandlerSocketBase) then TIdSSLIOHandlerSocketBase(AContext.Connection.IOHandler).PassThrough:= false; end; end.[/code:1:b9e0eac7c6]
user image
more 17 years ago

stoopid

main client side: [code:1:9eeb9697d5]//made by stoopid //this application still have a lot of error and need a lot of improvement //so if you make any improvement to this application pls email me the source code to mriandi@gmail.com //this program was purposely made for studying so pls share ur knowledge unit cclient; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ADODB, DB, DBTables, Grids, DBGrids, DBClient, Provider, IdBaseComponent, IdComponent, idcontext, IdCustomTCPServer, IdTCPServer, ExtCtrls, IdTCPConnection, IdTCPClient, IdIOHandler, IdIOHandlerSocket, IdIOHandlerStack, IdSSL, IdSSLOpenSSL, pm, DCPcrypt2, DCPblockciphers, DCPidea; type TForm1 = class(TForm) euser: TEdit; Label1: TLabel; Label2: TLabel; ListBox1: TListBox; Label3: TLabel; Label4: TLabel; ehost: TEdit; Button1: TButton; epas: TEdit; IdTCPServer1: TIdTCPServer; Timer1: TTimer; IdTCPClient1: TIdTCPClient; Memo2: TMemo; Button2: TButton; ListBox2: TListBox; Label5: TLabel; Button3: TButton; IdSSLIOHandlerSocketOpenSSL1: TIdSSLIOHandlerSocketOpenSSL; DCP_idea1: TDCP_idea; procedure ListBox1DblClick(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure IdTCPServer1Execute(AContext: TIdContext); procedure Timer1Timer(Sender: TObject); procedure tutup; procedure Memo2Change(Sender: TObject); procedure Button2Click(Sender: TObject); procedure Button3Click(Sender: TObject); private {send to window pm } procedure SendString(); procedure SendData(copyDataStruct: TCopyDataStruct); { receive from window pm } procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA; procedure HandleCopyDataString(copyDataStruct : PCopyDataStruct); public uluar,msgdariluar : string; receiverHandle : THandle; end; var Form1: TForm1; implementation {$R .dfm} procedure TForm1.ListBox1DblClick(Sender: TObject); var a:integer; kpd:string; begin a:=listbox1.ItemIndex; kpd:=listbox1.Items.Strings[a]; if FindWindow(PChar('TForm2'),PChar(kpd)) = 0 then begin application.CreateForm(TForm2,Form2); form2.Caption:=kpd; form2.Label1.Caption:=inttostr(form2.Handle); form2.from.Caption:=euser.text; Form2.show; end; end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin if IdTCPClient1.Connected then begin tutup; end; end; procedure TForm1.FormCreate(Sender: TObject); begin listbox1.Enabled:=false; timer1.Enabled:=True; end; procedure TForm1.Timer1Timer(Sender: TObject); begin { This approach (with the timer) is used to ensure that everything has been fully created and the application is running before we start the server up. } timer1.enabled:= false; IdTCPServer1.Active:= true; end; { TIMER1 TIMER } procedure TForm1.Button1Click(Sender: TObject); var a,b,line:string; key:integer; begin if button1.Caption='&Connect' then begin a:=euser.Text; b:=epas.Text; key:=StrToIntDef('anton',0); dcp_idea1.Init(key,Sizeof(key) 8,nil); b:=dcp_idea1.EncryptString(b); dcp_idea1.Burn; IdTCPClient1.Host:=ehost.Text; IdTCPClient1.Connect; if IdTCPClient1.Connected then begin IdTCPClient1.IOHandler.WriteLn(a+'&'+b); line:=IdTCPClient1.IOHandler.ReadLn; listbox2.Items.Add(line); if line='login sukses' then begin euser.Enabled:=false; epas.Enabled:=false; ehost.Enabled:=false; listbox1.Enabled:=true; button1.Caption:='&Disconnect'; end else begin tutup; end end end else if button1.Caption='&Disconnect' then begin button1.Caption:='&Connect'; tutup; end; end; procedure TForm1.tutup; var a:string; begin a:=euser.Text+'!disconnect'; IdTCPClient1.IOHandler.WriteLn(a); IdTCPClient1.Disconnect; euser.Enabled:=true; epas.Enabled:=true; ehost.Enabled:=true; listbox1.Enabled:=false; listbox1.clear; listbox2.Items.Add('Terputus dari server'); end; procedure TForm1.IdTCPServer1Execute(AContext: TIdContext); var connected:boolean; line,ulist:string; pospagar,cpos,upos:integer; begin connected:=true; while connected do begin try line:=acontext.Connection.IOHandler.readln; cpos:=pos('~clear',line); upos:=pos('^',line); pospagar:=pos('#',line); if pospagar>0 then begin uluar:=copy(line,1,pospagar-1); msgdariluar:=copy(line,pospagar+1,length(line)-pospagar); receiverHandle := FindWindow(PChar('TForm2'),PChar(uluar)); if receiverHandle=0 then begin memo2.Lines.Add('a'); end; sendstring; end; if cpos>0 then if cpos<2 then begin listbox1.Clear; end; if upos>0 then if upos<2 then begin ulist:=copy(line,upos+1,length(line)-upos); if ulist<>euser.Text then begin listbox1.items.Add(ulist); end; end; except connected:=false; end; end; end; procedure TForm1.SendString(); var copyDataStruct : TCopyDataStruct; stringtosend : string; begin stringToSend := msgdariluar; copyDataStruct.dwData := 3; //use it to identify the message contents copyDataStruct.cbData := 1 + Length(stringToSend); copyDataStruct.lpData := PChar(stringToSend); SendData(copyDataStruct); end; procedure TForm1.SendData(copyDataStruct: TCopyDataStruct); begin SendMessage(receiverHandle, WM_COPYDATA, Integer(Handle), Integer(@copyDataStruct)); end; procedure TForm1.HandleCopyDataString(copyDataStruct: PCopyDataStruct); var s : string; begin s := PChar(copyDataStruct.lpData); idtcpclient1.IOHandler.Writeln(s); end; procedure TForm1.WMCopyData(var Msg: TWMCopyData); var copyDataType : integer; begin copyDataType := Msg.CopyDataStruct.dwData; if copydatatype=1 then begin HandleCopyDataString(Msg.CopyDataStruct); end; end; procedure TForm1.Memo2Change(Sender: TObject); begin application.CreateForm(TForm2,Form2); Form2.Caption:=uluar; Form2.Label1.Caption:=inttostr(form2.Handle); Form2.from.Caption:=euser.text; Form2.show; receiverHandle:=form2.Handle; end; procedure TForm1.Button2Click(Sender: TObject); var a,b,line:string; key:integer; begin a:=euser.Text; b:=epas.Text; key:=StrToIntDef('anton',0); dcp_idea1.Init(key,Sizeof(key)8,nil); b:=dcp_idea1.EncryptString(b); dcp_idea1.Burn; IdTCPClient1.Host:=ehost.Text; IdTCPClient1.Connect; if IdTCPClient1.Connected then begin IdTCPClient1.IOHandler.WriteLn(' reguser'+'add'+a+':'+b); line:=IdTCPClient1.IOHandler.ReadLn; listbox2.Items.Add(line); if line='Register User Sukses' then begin showmessage('account anda telah terdaftar'); end else begin showmessage('gunakan username yang lain'); end; idtcpclient1.Disconnect; end end; procedure TForm1.Button3Click(Sender: TObject); var a,b,line:string; key:integer; begin a:=euser.Text; b:=epas.Text; key:=StrToIntDef('anton',0); dcp_idea1.Init(key,Sizeof(key)8,nil); b:=dcp_idea1.EncryptString(b); dcp_idea1.Burn; IdTCPClient1.Host:=ehost.Text; IdTCPClient1.Connect; if IdTCPClient1.Connected then begin IdTCPClient1.IOHandler.WriteLn(' reguser'+'del'+a+':'+b); line:=IdTCPClient1.IOHandler.ReadLn; listbox2.Items.Add(line); if line='Delete User Sukses' then begin showmessage('account anda telah dihapus'); end else begin showmessage('username atau password yang anda masukkan salah'); end; idtcpclient1.Disconnect; end end; end.[/code:1:9eeb9697d5] private window chat source:
unit pm;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdBaseComponent, IdComponent, ExtCtrls, DCPcrypt2,
  DCPblockciphers, DCPidea;
type
  TCopyDataStruct = packed record
    dwData: DWORD; //up to 32 bits of data to be passed to the receiving application
    cbData: DWORD; //the size, in bytes, of the data pointed to by the lpData member
    lpData: Pointer; //Points to data to be passed to the receiving application. This member can be nil.
  end;
  TForm2 = class(TForm)
    Memo1: TMemo;
    Memo2: TMemo;
    Button1: TButton;
    Button2: TButton;
    from: TLabel;
    Label1: TLabel;
    Edit1: TEdit;
    DCP_idea1: TDCP_idea;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button2Click(Sender: TObject);
  private
    {send to window Client }
    procedure SendString();
    procedure SendData(copyDataStruct: TCopyDataStruct);
    { receive from window Client }
    procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA;
    procedure HandleCopyDataString(copyDataStruct : PCopyDataStruct);
  public
    { Public declarations }
  end;
var
  Form2: TForm2;
implementation
{$R .dfm}
procedure TForm2.FormCreate(Sender: TObject);
begin
memo1.Clear;
memo2.clear;
end;
procedure TForm2.Button1Click(Sender: TObject);
begin
memo1.Lines.Add(from.Caption+' says:');
memo1.Lines.Add(memo2.Text);
SendString;
memo2.Clear;
end;
procedure TForm2.SendString();
var
  pmdari,pmke,stringToSend,teksenkrip : string;
  keypm:integer;
  copyDataStruct : TCopyDataStruct;
begin
  pmdari:=from.Caption;
  pmke:=form2.Caption;
  keypm:=StrToIntDef(edit1.Text,0);
  dcp_idea1.Init(keypm,Sizeof(keypm) 8,nil);
  teksenkrip:=dcp_idea1.EncryptString(memo2.Lines.Text);
  dcp_idea1.Burn;
  stringToSend := pmdari+'@'+pmke+'#'+teksenkrip;
  copyDataStruct.dwData := 1; //use it to identify the message contents
  copyDataStruct.cbData := 1 + Length(stringToSend);
  copyDataStruct.lpData := PChar(stringToSend);
  SendData(copyDataStruct);
end;
procedure TForm2.SendData(copyDataStruct: TCopyDataStruct);
var
  receiverHandle  : THandle;
begin
  receiverHandle := FindWindow(PChar('TForm1'),PChar('Client'));
  SendMessage(receiverHandle, WM_COPYDATA, Integer(Handle), Integer(@copyDataStruct));
end;
procedure TForm2.HandleCopyDataString(copyDataStruct: PCopyDataStruct);
var
  s,teksdekrip : string;
  keypm:integer;
begin
  s := PChar(copyDataStruct.lpData);
  keypm:=StrToIntDef(edit1.Text,0);
  
  dcp_idea1.Init(keypm,Sizeof(keypm)*8,nil);
  teksdekrip:=dcp_idea1.DecryptString(s);
  dcp_idea1.Burn;
  memo1.Lines.Add(form2.Caption+' says:');
  memo1.Lines.Add(teksdekrip);
end;
procedure TForm2.WMCopyData(var Msg: TWMCopyData);
var
  copyDataType : integer;
begin
  copyDataType := Msg.CopyDataStruct.dwData;
  if copydatatype=3 then begin
  HandleCopyDataString(Msg.CopyDataStruct);
  end;
end;
procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
destroywindow(strtoint(label1.Caption));
end;
procedure TForm2.Button2Click(Sender: TObject);
begin
if edit1.Enabled=true then begin
edit1.Enabled:=false;
button2.Caption:='&Reset Key';
end
else if edit1.Enabled=false then begin
edit1.Enabled:=true;
edit1.Clear;
button2.Caption:='&Set Key';
end;
end;
end.
user image
more 17 years ago

EkoIndri

waduh..... rapidsharenya di block.....
user image
more 17 years ago

kaka-delphi

@EkoIndri Diriku enggak ... we ... :P
user image
more 17 years ago

portege

Stoopid, Open-Source...., menarik juga. kalo emang mau berkolaborasi tolong pelajari CVS biar lebih terkontrol versi-versi revisi-nya. coba di sourceforge.net .
user image
more 17 years ago

Sutilkon

Stoopid, Kalau pakai delphi 6.! indy nya pakai yang ver berapa ? thx
user image
more 17 years ago

R960XT

@Sutilkon kalo pake D6, indy nya harus pake versi yang sama dengan yang dipake bro stoopid tapi cari yang untuk D6, jangan pake versi yang untuk delphi laen
user image
more 13 years ago

batozai

buat om TS tolong donk upload lagi file2nya.... saya coba buka, rapidshare mengatakan file not found gitu.... saya lagi butuh contoh aplikasi chat untuk aplikasi TA saya... atau klo ada master master yang lain yang udah download program aplikasi ini tolong donk share lagi.... terima kasih banyak atas kebaikan master2 semua :)
user image
more 13 years ago

elva_ivana

wah..susah juga ya carinya secara itu postingan tahun 2006 :D sedikit referensi nih muga2 bisa bantu http://delphi.about.com/library/weekly/aa101105a.htm
more ...
  • Pages:
  • 1
  • 2
Share to
Local Business Directory, Search Engine Submission & SEO Tools FreeWebSubmission.com SonicRun.com