unitmessagedbase.pas

delphi写的基于server和client的聊天源码 有参考意义

{消息中转服务器  Build 2003-12-05 Builder Erice}
unit Unitmessagedbase;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, Messages, SysUtils, Classes, ComServ, ComObj, VCLCom, DataBkr,
  DBClient, dataserver_TLB, StdVcl, Provider, DB, ADODB,FORMS,variants;

type
  Tmessagedbase = class(TRemoteDataModule, Imessagedbase)
    AQmain: TADOQuery;
    Aqmain1: TADOQuery;
    Aqmain2: TADOQuery;
    Aqmain3: TADOQuery;
    DProbase: TDataSetProvider;
    DProbase1: TDataSetProvider;
    AQbase: TADOQuery;
    Aqbase1: TADOQuery;
    DPromain: TDataSetProvider;
    aqlmgl: TADOQuery;
    dsplmgl: TDataSetProvider;
    aqmessage: TADOQuery;
    dspmessage: TDataSetProvider;
    dsplmmx: TDataSetProvider;
    aqlmmx: TADOQuery;
  private
    { Private declarations }
  protected
    class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); override;
    procedure closed(const action, ip: WideString); safecall;
    procedure gettj(const lmbh, fbdate: WideString; out fjdata, fjname, fjtype,
      fjsize: OleVariant); safecall;
    procedure logined(const user, pwd, bm, ip, compname: WideString;
      out fg: OleVariant); safecall;
    procedure query1(const inputed: WideString; out ownerdata: OleVariant);
      safecall;
    procedure query2(const inputed: WideString); safecall;
    procedure opened(const queryed: WideString); safecall;
    procedure exesqled(const inputed: WideString); safecall;
    procedure getmsg(out values1, values2: OleVariant; const comp: WideString);
      safecall;
    procedure sendmsg(const ipstr, values, sendobj: WideString); safecall;
    procedure addcomip(out ipchar, compters, counts: OleVariant); safecall;
    procedure getips(out viewips, viewname, counts: OleVariant); safecall;
  public
    { Public declarations }
  end;

implementation

uses Unitlocatdata, Unitservermain;

{$R *.DFM}

class procedure Tmessagedbase.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
begin
  if Register then
  begin
    inherited UpdateRegistry(Register, ClassID, ProgID);
    EnableSocketTransport(ClassID);
    EnableWebTransport(ClassID);
  end else
  begin
    DisableSocketTransport(ClassID);
    DisableWebTransport(ClassID);
    inherited UpdateRegistry(Register, ClassID, ProgID);
  end;
end;

procedure Tmessagedbase.closed(const action, ip: WideString);
begin
  if action ='2' then
  begin
    frm_servermain.divuser;
    frm_servermain.divip(ip);
  end;
end;

procedure Tmessagedbase.gettj(const lmbh, fbdate: WideString; out fjdata,
  fjname, fjtype, fjsize: OleVariant); //传附件
begin

end;

procedure Tmessagedbase.logined(const user, pwd, bm, ip,
  compname: WideString; out fg: OleVariant);
begin
  if dm.ADOConn.Connected then
  begin
    if not aqlmgl.Active then  //打开数据表;
    begin
      aqlmgl.Open;
    end;
    if not aqlmmx.Active then  //打开数据表;
    begin
      aqlmgl.Open;
    end;
    if not aqmessage.Active then  //打开数据表;
    begin
      aqmessage.Open;
    end;
    fg:=1;
    frm_servermain.addip(ip,compname);
    frm_servermain.adduser;
  end else
  begin
    fg:=2;
  end;

end;

procedure Tmessagedbase.query1(const inputed: WideString;
  out ownerdata: OleVariant);
begin
  frm_servermain.tquerysql(aqbase,trim(inputed));
  if not aqbase.IsEmpty then
  begin
    ownerdata:=dprobase.Data;
  end else
  begin
    ownerdata:=null;
  end;
  frm_servermain.addstream;
end;

procedure Tmessagedbase.query2(const inputed: WideString);
begin
  frm_servermain.tquerysql(aqbase1,trim(inputed));
  frm_servermain.addstream;
end;

procedure Tmessagedbase.opened(const queryed: WideString);
begin
end;

procedure Tmessagedbase.exesqled(const inputed: WideString);
begin
  frm_servermain.remo_exesql(aqmain,trim(inputed));
  frm_servermain.addstream;
end;

procedure Tmessagedbase.getmsg(out values1, values2: OleVariant;
  const comp: WideString); //获得消息
  var
    index :integer;
    str,wstr,wstr2:widestring;
begin
  if frm_servermain.iplist.Find(trim(comp),index) then
  begin
    str:=frm_servermain.pmsg.Strings[index];
    wstr2:=trim(copy(str,1,pos('*',str)-1));
    wstr:=trim(copy(str,pos('*',str)+1,length(str)-length(wstr2)-1));
    values1:=wstr;
    values2:=wstr2;
    frm_servermain.pmsg.Delete(index);
    frm_servermain.iplist.Delete(index);
  end else
  begin
    values1:=null;
    values2:=null;
  end;
end;

procedure Tmessagedbase.sendmsg(const ipstr, values, sendobj: WideString); //发送 (接收放，内容，发送方)
begin
  frm_servermain.pmsg.Add(sendobj+'*'+values); //保存消息
  frm_servermain.iplist.Add(ipstr);//保存接收IP
end;

procedure Tmessagedbase.addcomip(out ipchar, compters,counts: OleVariant);
var
  iplist,nameslist,s:string;
  m1,m2:widestring;
  counted,i:integer;
begin
  iplist:='';
  nameslist:='';
  counted:=0;
  s:='';
  s:=trim(frm_servermain.lviewuser.Items[0].Caption) ;
  if  s<>'' then
  begin
    iplist:=iplist+'p'+trim(s); //加IP
    counted:=frm_servermain.LViewuser.Items.Count;
    for i:=1 to counts do
    begin
      iplist:=iplist+'p'+trim(frm_servermain.lviewuser.Items[i].Caption);
      //viewnames:=viewnames+'p'+trim(lviewuser.Items[i].SubItems);
    end;
  end;
  m1:=iplist;
  m2:=nameslist;
  ipchar:=m1;
  compters:=m2;
  counts:=inttostr(Counted);
end;

procedure Tmessagedbase.getips(out viewips, viewname, counts: OleVariant);//获得IP地址；
var
  ips,compnames:string;
  counted:integer;
  wips,wcomname:widestring;
begin
  frm_servermain.get_clientip(ips,compnames,counted);
  wips:=ips;
  wcomname:=compnames;
  viewips:=wips;
  viewname:=wcomname;
  counts:=counted;
end;
initialization
  TComponentFactory.Create(ComServer, Tmessagedbase,
    Class_messagedbase, ciMultiInstance, tmApartment);
end.