Tek formda Indy ile server-client chat programı

Yazdığınız makaleleri ve üyelerimizin işine yarayacağını düşündüğünüz kodlarınızı gönderebilirsiniz. Bu foruma soru sormayın!
Cevapla
Kullanıcı avatarı
MicroChip
Kıdemli Üye
Mesajlar: 1119
Kayıt: 02 Ağu 2003 01:02
Konum: İstanbul
İletişim:
İletişim MicroChip

Tek formda Indy ile server-client chat programı

Mesaj gönderen MicroChip »

Aşağıda verdiğim dosyaları kaydederek delphi ile açın ve derleyin.
Baktım Indy ile ornek forumda çok az. Güzel bir şey ekliyeyim dedim.

Saygılar


************************************************

Aşağıdaki dosyayı "MicroCHAT.dpr" olarak kaydedin

Kod: Tümünü seç

program MicroCHAT;
//Coder: Ahmet CEYLAN (MicroChip)
uses
  Forms,
  form01 in 'form01.pas' {Form1};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
************************************************

Aşağıdaki dosyayı "form01.dfm" olarak kaydedin

Kod: Tümünü seç

object Form1: TForm1
  Left = 222
  Top = 108
  BorderStyle = bsSingle
  Caption = 'MicroCHAT v.1.0'
  ClientHeight = 323
  ClientWidth = 465
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  Menu = MainMenu1
  OldCreateOrder = False
  OnClose = FormClose
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 136
    Top = 8
    Width = 60
    Height = 13
    Caption = 'Kullanıcı Adı:'
  end
  object Label2: TLabel
    Left = 256
    Top = 8
    Width = 66
    Height = 13
    Caption = 'Server Adresi:'
  end
  object Label3: TLabel
    Left = 400
    Top = 7
    Width = 39
    Height = 13
    Caption = 'Port No:'
  end
  object Label4: TLabel
    Left = 136
    Top = 69
    Width = 42
    Height = 13
    Caption = 'Mesajlar:'
  end
  object Label5: TLabel
    Left = 136
    Top = 260
    Width = 39
    Height = 13
    Caption = 'Mesajın:'
  end
  object labeldns: TLabel
    Left = 512
    Top = 336
    Width = 39
    Height = 13
    Caption = 'labeldns'
  end
  object labelsocketver: TLabel
    Left = 512
    Top = 360
    Width = 69
    Height = 13
    Caption = 'labelsocketver'
  end
  object Edit2: TEdit
    Left = 256
    Top = 21
    Width = 137
    Height = 21
    TabOrder = 0
    Text = 'localhost'
  end
  object Edit3: TEdit
    Left = 400
    Top = 21
    Width = 57
    Height = 21
    TabOrder = 1
    Text = '23'
  end
  object listclients: TListBox
    Left = 8
    Top = 8
    Width = 121
    Height = 287
    ItemHeight = 13
    PopupMenu = PopupMenu1
    TabOrder = 2
  end
  object Memo1: TMemo
    Left = 136
    Top = 83
    Width = 321
    Height = 174
    ScrollBars = ssVertical
    TabOrder = 3
  end
  object Edit4: TEdit
    Left = 136
    Top = 274
    Width = 321
    Height = 21
    TabOrder = 4
    OnKeyPress = Edit4KeyPress
  end
  object butonbaglan: TBitBtn
    Left = 400
    Top = 48
    Width = 57
    Height = 21
    Caption = 'Bağlan'
    TabOrder = 5
    OnClick = butonbaglanClick
  end
  object Memo2: TMemo
    Left = 504
    Top = 240
    Width = 185
    Height = 89
    Lines.Strings = (
      '/help=Here are the EMotes: /grin, '
      '/lol, /kiss, /rose'
      '/grin=%s grins.'
      '/lol=%s Laughs out loud.'
      '/kiss=%s blows everyone a big kiss.'
      '/rose=A @--'#39'--- for you from %s.')
    TabOrder = 6
  end
  object durum: TfcStatusBar
    Left = 0
    Top = 303
    Width = 465
    Height = 20
    Panels = <
      item
        Font.Charset = DEFAULT_CHARSET
        Font.Color = clWindowText
        Font.Height = -11
        Font.Name = 'MS Sans Serif'
        Font.Style = []
        Name = 'Panel0'
        Tag = 0
        TextOptions.Alignment = taLeftJustify
        TextOptions.VAlignment = vaVCenter
        Width = '270'
      end
      item
        Font.Charset = DEFAULT_CHARSET
        Font.Color = clWindowText
        Font.Height = -11
        Font.Name = 'MS Sans Serif'
        Font.Style = []
        Name = 'Panel1'
        Tag = 0
        TextOptions.Alignment = taCenter
        TextOptions.VAlignment = vaVCenter
        Width = '100'
      end
      item
        Font.Charset = DEFAULT_CHARSET
        Font.Color = clWindowText
        Font.Height = -11
        Font.Name = 'MS Sans Serif'
        Font.Style = []
        Name = 'Panel2'
        Style = psDateTime
        Tag = 0
        Text = '05.05.2005 03:02'
        TextOptions.Alignment = taCenter
        TextOptions.VAlignment = vaVCenter
        Width = '50'
      end>
    SimplePanel = False
    SizeGrip = False
    StatusBarText.CapsLock = 'Caps'
    StatusBarText.Overwrite = 'Overwrite'
    StatusBarText.NumLock = 'Num'
    StatusBarText.ScrollLock = 'Scroll'
  end
  object Memo3: TMemo
    Left = 504
    Top = 40
    Width = 185
    Height = 193
    Lines.Strings = (
      'Memo3')
    TabOrder = 8
  end
  object Edit1: TEdit
    Left = 135
    Top = 21
    Width = 114
    Height = 21
    MaxLength = 15
    TabOrder = 9
  end
  object rad01: TRadioButton
    Left = 259
    Top = 50
    Width = 65
    Height = 17
    Caption = 'Sunucu'
    TabOrder = 10
  end
  object rad02: TRadioButton
    Left = 328
    Top = 50
    Width = 65
    Height = 17
    Caption = 'İstemci'
    Checked = True
    TabOrder = 11
    TabStop = True
  end
  object client: TIdTCPClient
    MaxLineAction = maException
    RecvBufferSize = 8192
    OnConnected = clientConnected
    Port = 0
    Left = 40
    Top = 160
  end
  object server: TIdTCPServer
    Bindings = <
      item
        Port = 23
      end>
    CommandHandlers = <>
    DefaultPort = 0
    Greeting.NumericCode = 0
    MaxConnectionReply.NumericCode = 0
    OnConnect = serverConnect
    OnExecute = serverExecute
    OnDisconnect = serverDisconnect
    ReplyExceptionCode = 0
    ReplyTexts = <>
    ReplyUnknownCommand.NumericCode = 0
    ThreadMgr = IdThreadMgrDefault1
    Left = 40
    Top = 128
  end
  object IdThreadMgrDefault1: TIdThreadMgrDefault
    Left = 72
    Top = 128
  end
  object Timer1: TTimer
    Interval = 500
    OnTimer = Timer1Timer
    Left = 72
    Top = 160
  end
  object MainMenu1: TMainMenu
    Left = 40
    Top = 88
    object Men1: TMenuItem
      Caption = 'Menü'
      object ProgramHakknda1: TMenuItem
        Caption = 'Program Hakkında'
      end
      object k1: TMenuItem
        Caption = 'Çıkış'
      end
    end
  end
  object PopupMenu1: TPopupMenu
    Left = 72
    Top = 88
    object Yenile1: TMenuItem
      Caption = 'Listeyi Yenile'
      OnClick = Yenile1Click
    end
    object ChattenDarAt1: TMenuItem
      Caption = 'Chat'#39'ten Dışarı At'
      Visible = False
      OnClick = ChattenDarAt1Click
    end
  end
end
************************************************

Aşağıdaki dosyayı "form01.pas" olarak kaydedin

Kod: Tümünü seç

unit form01;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdTCPServer, IdThreadMgr, IdThreadMgrDefault, ExtCtrls, Buttons,
  fcStatusBar, ComCtrls, ToolWin, ImgList, Menus, WinSkinData;

type
  TSimpleClient = class(TObject)
    DNS,
    Name        : String;
    ListLink    : Integer;
    Thread      : Pointer;
  end;

  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Edit2: TEdit;
    Label3: TLabel;
    Edit3: TEdit;
    listclients: TListBox;
    Memo1: TMemo;
    Edit4: TEdit;
    Label4: TLabel;
    Label5: TLabel;
    client: TIdTCPClient;
    server: TIdTCPServer;
    IdThreadMgrDefault1: TIdThreadMgrDefault;
    Timer1: TTimer;
    butonbaglan: TBitBtn;
    Memo2: TMemo;
    labeldns: TLabel;
    labelsocketver: TLabel;
    durum: TfcStatusBar;
    Memo3: TMemo;
    MainMenu1: TMainMenu;
    Men1: TMenuItem;
    Edit1: TEdit;
    rad01: TRadioButton;
    rad02: TRadioButton;
    k1: TMenuItem;
    PopupMenu1: TPopupMenu;
    Yenile1: TMenuItem;
    ChattenDarAt1: TMenuItem;
    ProgramHakknda1: TMenuItem;
    procedure Edit4KeyPress(Sender: TObject; var Key: Char);
    procedure Timer1Timer(Sender: TObject);
    procedure clientConnected(Sender: TObject);
    procedure butonbaglanClick(Sender: TObject);
    procedure serverConnect(AThread: TIdPeerThread);
    procedure serverDisconnect(AThread: TIdPeerThread);
    procedure serverExecute(AThread: TIdPeerThread);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure Yenile1Click(Sender: TObject);
    procedure ChattenDarAt1Click(Sender: TObject);
  private
    { Private declarations }
  public
    Clients  : TList;
    procedure BroadcastMessage( WhoFrom, TheMessage : String );
    procedure UpdateClientList;
    procedure UpdateBindings;
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses IdSocketHandle;

{$R *.DFM}

procedure TForm1.UpdateBindings;
var
  Binding : TIdSocketHandle;
begin
  Server.DefaultPort := strtoint(edit3.text);
  Server.Bindings.Clear;
  Binding := Server.Bindings.Add;
  Binding.Port := strtoint(edit3.text);
end;

procedure TForm1.Edit4KeyPress(Sender: TObject; var Key: Char);
begin
  if key = #13 then
    begin
      client.WriteLn(edit4.Text);
      edit4.Text := '';
    end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  Com,
  Msg : String;
begin
  if not client.Connected then exit;

  labelDNS.Caption := Server.LocalName;

  Msg := client.ReadLn('', 5);

  if UpperCase(Trim(Copy(Msg, Pos(':', Msg) +1, Length(Msg)))) = 'DEGIS' then
  begin
     Yenile1.Click;
     Msg := client.ReadLn('', 5);
  end;

  if Msg <> '' then
    if (Msg[1] <> '@') then
      begin
      { Not a system command }
        memo1.Lines.Add(Msg);
      end
    else
      begin
      { System command }
        Com := UpperCase(Trim(Copy(Msg, 2, Pos(':', Msg) -2)));
        Msg := UpperCase(Trim(Copy(Msg, Pos(':', Msg) +1, Length(Msg))));
        if (Com = 'CLIENTS') then
        begin
          listClients.Items.CommaText := Msg;
          durum.Panels[0].text:='Yönetici: '+listclients.Items.Strings[0];
        end;
      end;
end;

procedure TForm1.clientConnected(Sender: TObject);
begin
    Client.WriteLn(edit1.text);
    Client.WriteLn('DEGIS');
    //Yenile1.Click;
end;

procedure TForm1.butonbaglanClick(Sender: TObject);
begin
    if trim(edit1.text)='' then
    begin
        showmessage('Kullanıcı adını yazmamışsınız...');
        exit;
    end;
    client.Host := edit2.text;
    client.Port := strtoint(edit3.text);

    if rad02.Checked then
    begin
        try
            client.Connect;
        except
            showmessage('Bağlanmak istediğiniz sunucu bulunamadı...');
            exit;
        end;
    end;

    if rad01.checked then
    begin
        server.active:=true;
        client.connect;
        ChattenDarAt1.visible:=true;
    end;

end;

procedure TForm1.serverConnect(AThread: TIdPeerThread);
var
  Clientalt : TSimpleClient;
begin
  AThread.Connection.WriteLn('MicroCHAT''e bağlanıyorsunuz...');
  AThread.Connection.WriteLn('Lütfen bekleyiniz...');
  //AThread.Connection.WriteLn('İsminiz:');
  Clientalt := TSimpleClient.Create;
  Clientalt.DNS  := AThread.Connection.LocalName;
  Clientalt.Name := 'Logging In';
  Clientalt.ListLink := listClients.Items.Count;
  Clientalt.Thread := AThread;
  listClients.Items.Add(Clientalt.Name);
  AThread.Data := Clientalt;
  Clients.Add(Clientalt);


end;

procedure TForm1.serverDisconnect(AThread: TIdPeerThread);
var
  Clientalt : TSimpleClient;
begin
  Clientalt := Pointer(AThread.Data);
  Clients.Delete(Clientalt.ListLink);
  listClients.Items.Delete(listClients.Items.IndexOf(Clientalt.Name));
  BroadcastMessage('System', Clientalt.Name + ' sohbetten ayrıldı.');
  Clientalt.Free;
  AThread.Data := nil;
  Client.WriteLn('DEGIS');

end;

procedure TForm1.BroadcastMessage( WhoFrom, TheMessage : String );
var
  Count: Integer;
  List : TList;
  EMote,
  Msg  : String;
begin
  Msg := Trim(TheMessage);

  EMote := Trim(memo2.Lines.Values[Msg]);

  if WhoFrom <> 'System' then
    Msg := WhoFrom + ': ' + Msg;

  if EMote <> '' then
    Msg := Format(Trim(EMote), [WhoFrom]);

  List := Server.Threads.LockList;
  try
    for Count := 0 to List.Count -1 do
    try
      TIdPeerThread(List.Items[Count]).Connection.WriteLn(Msg);
    except
      TIdPeerThread(List.Items[Count]).Stop;
    end;
  finally
    Server.Threads.UnlockList;
  end;
end;

procedure TForm1.UpdateClientList;
var
  Count : Integer;
begin
  for Count := 0 to listClients.Items.Count -1 do
    if Count < Clients.Count then
      listClients.Items.Strings[Count] := TSimpleClient(Clients.Items[Count]).Name;
end;

procedure TForm1.serverExecute(AThread: TIdPeerThread);
var
  Client : TSimpleClient;
  Com,     // System command
  Msg    : String;
begin
  Msg    := AThread.Connection.ReadLn;  //showmessage(msg);
  Client := Pointer(AThread.Data);
  if Client.Name = 'Logging In' then
  begin
      Client.Name := Msg;
      UpdateClientList;
      BroadcastMessage('System', Msg + ' şu an sohbette.');
      //AThread.Connection.WriteLn(memo1.Lines.Text);  //server sürümünde olacak sadece
  end
  else
  if Msg[1] <> '@' then
  begin
      BroadcastMessage(Client.Name, Msg);

  end
  else
  begin
    { System command }
      Com := UpperCase(Trim(Copy(Msg, 2, Pos(':', Msg) -2)));
      Msg := UpperCase(Trim(Copy(Msg, Pos(':', Msg) +1, Length(Msg))));
      if Com = 'CLIENTS' then
        AThread.Connection.WriteLn( '@' + 'clients:' +
                                    listClients.Items.CommaText);
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if (Clients.Count > 1) and (Server.Active) then
    begin
      Action := caNone;
      ShowMessage('Server''a bağlı kişiler olduğu sürece MicroCHAT''i kapatamazsınız...');
    end
  else
    Clients.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    Clients := TList.Create;
    UpdateBindings;
    labelDNS.Caption := Server.LocalName;
    labelSocketVer.Caption := Server.Version;
end;

procedure TForm1.Yenile1Click(Sender: TObject);
begin
    Client.WriteLn('@' + 'CLIENTS:REQUEST');
end;

procedure TForm1.ChattenDarAt1Click(Sender: TObject);
var
  Msg : String;
  Client : TSimpleClient;
begin
  Msg := InputBox('Dışarı Atma Mesajınız', 'Kullanıcıyı attığınız zaman göreceği mesajınız:', '');
  Msg := Trim(Msg);
  Msg := edit1.text + '> ' + Msg;
  if (Msg <> '') and
     (listclients.ItemIndex <> -1) then
    begin
      Client := Clients.Items[listClients.ItemIndex];
      TIdPeerThread(Client.Thread).Connection.WriteLn(Msg);
      TIdPeerThread(Client.Thread).Connection.Disconnect;
      Clients.Delete(listClients.ItemIndex);
      listClients.Items.Delete(listClients.ItemIndex);
    end;
end;

end.
************************************************
Kafkas Kartalı Kabarday
Sitesi!= http://www.ahmetceylan.com
Resim
Başa dön
must_sargin
Üye
Mesajlar: 216
Kayıt: 14 Şub 2004 03:13
Konum: Gebze
İletişim:
İletişim must_sargin

Mesaj gönderen must_sargin »

s.a.
dediğiniz gibi dosyaları oluşturdum.sorun olur diye güvenlik duvarını kapattım programı çalıştırdığımda normal,mesela sunucuyu seçip bağlana tıklayınca program yanıt vermiyor uyarısı veriyor.acaba neden olabilir?
Başa dön
Kullanıcı avatarı
conari
Üye
Mesajlar: 2102
Kayıt: 27 Nis 2006 03:10
Konum: İstanbul & Gebze Karışık

Mesaj gönderen conari »

res dosyasını aradı bendede hoca..
ayrca field1.durum yok diyor.
fcStatusBar.dcu, WinSkinData.dcu dosyalarını arıyor
Bir kelimenin anlamını öğretsen bile yeter..
ResimResim
Başa dön
must_sargin
Üye
Mesajlar: 216
Kayıt: 14 Şub 2004 03:13
Konum: Gebze
İletişim:
İletişim must_sargin

Mesaj gönderen must_sargin »

o bileşenleri uses kısmından silince o uyarıyı vermiyor ama henüz çalıştıramadım.ustalardan da konuyla ilgilenen çıkmadı henüz.
Başa dön
Cevapla

“Makale ve İpucu” sayfasına dön