unit1.pas

Delphi通讯源码。可给做通讯的朋友参考。

        except
          continue;
        end;
      end;
    except
    end;
    POP3Obj.Disconnect;
  except
    POP3Obj.Disconnect;
  end;
  msg.Free;
end;
procedure TCarrier.GetHTTP(HTTPObj:TIdHTTP);
var stmp:string;
begin
  try
    stmp:=HTTPObj.Get(HTTPObj.SocksInfo.Host);
    while trim(stmp)<>'' do
    begin
      DataArrive(stmp,HTTPObj.Tag);
      stmp:=HTTPObj.Get(HTTPObj.SocksInfo.Host);
    end;
  except
  end;
end;
procedure TCarrier.GetFile(fileObj:TFileFace);
var SearchFile:TSearchRec;
    fls:TStrings;
    stmp:string;
begin
  fls:=Tstringlist.Create;
  if findfirst(fileObj.FilePath,faAnyFile-faDirectory,SearchFile)=0 then
  repeat
    if (SearchFile.Name='..') or (SearchFile.Name='.') then continue;
    stmp:=ExtractFilePath(fileObj.FilePath)+SearchFile.Name;
    fls.Clear;
    fls.LoadFromFile(stmp);
    SetFileAttributes(pchar(STMP),FILE_ATTRIBUTE_ARCHIVE);
    deletefile(stmp);
    DataArrive(fls.Text,fileobj.Tag);
  until FindNext(SearchFile) <> 0;
  FindClose(SearchFile);
  fls.Free;
end;
procedure TCarrier.GetMSMQ(MSMQObj:TMSMQFace);
var Info,Queue,Mess:OleVariant;
begin
  try
    Info:=CreateOleObject('MSMQ.MSMQQueueInfo');
    Queue:=CreateOleObject('MSMQ.MSMQQueue');
    Mess:=CreateOleObject('MSMQ.MSMQMessage');
    Info.PathName:=MSMQObj.MSMQPath;
    if Info.PathNameDNS='' then Info.Create;
    Queue:=Info.Open(1,1);
    repeat
      Mess:= Queue.Receive(, , , 1000);
      if TVarData(Mess).VLongWord >0 then DataArrive(Mess.Body,MSMQObj.Tag) else break;
      Mess:=Null;
    until 1=2;
  except
  end;
  Queue.Close;
  Info:= Unassigned;
  Queue:= Unassigned;
  Mess:= Unassigned;
end;
procedure TCarrier.GetCOM(COMObj:TCOMFace);
var stmp:string;
    COMInterface:OleVariant;
begin
    try
      COMInterface:=CreateOleObject(COMObj.ComPath);
      stmp:=COMInterface.GetData;
      while stmp<>#0 do
      begin
         DataArrive(stmp,COMObj.Tag);
         stmp:=COMInterface.GetData;
      end;
      COMInterface:= Unassigned;
    except
      COMInterface:= Unassigned;
    end;
end;

procedure TCarrier.GetDB(DBObj:TDBFace);
var ADOOBJ,Recd:OleVariant;
    NullTest:Variant;
    itmp:integer;
begin
  try
    ADOOBJ:=CreateOleObject('ADODB.Connection');
    recd:=CreateOleObject('adodb.recordset');
    ADOOBJ.Open(DBObj.DBPath);
    recd.open(DBObj.SQL,adoobj,1,3);
    itmp:= recd.recordCount;
    for itmp:=1  to itmp do
    begin
      recd.AbsolutePosition:=itmp;
      NullTest:=recd.Fields['Data'].value;
      if NullTest <>Null  then DataArrive(NullTest,DBObj.Tag);
    end;
    if itmp>0 then recd.movefirst;
    while not recd.eof do
    begin
      recd.Delete;
      recd.movenext;
    end;
    recd.close;
    adoobj.close;
    recd:= Unassigned;
    ADOOBJ:= Unassigned;
  except
    recd:= Unassigned;
    ADOOBJ:= Unassigned;
  end;
end;





procedure TCarrier.TCPServersClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  DataArrive(socket.ReceiveText,integer(TServerWinSocket(sender).data^));
end;
Function TCarrier.PutTCP(TCPOBJ:TClientSocket;sdata:string):Boolean;
var itime:integer;
begin
  PutTCP:=false;
  try
    TCPOBJ.Close;
    TCPOBJ.Open;
    itime:=gettickcount;
    repeat
      application.ProcessMessages;
    until (TCPOBJ.Active=true) or (gettickcount-itime>5000);
    if TCPOBJ.Active then
    begin
      TCPOBJ.Socket.SendText(sdata);
      PutTCP:=true;
    end;
  except
  end;
  TCPOBJ.Close;
end;
Function TCarrier.PutSMTP(SMTPOBJ:TIdSMTP;sdata:string):Boolean;
var Msg:TIdMessage;
begin
  PutSMTP:=false;
  Msg:=TIdMessage.Create(self);
  with Msg do
  begin
    From.Text := SMTPOBJ.UserId;
    body.Text:=sdata;
    Subject:=SMTPOBJ.SocksInfo.Password;
    Recipients.EMailAddresses :=SMTPOBJ.SocksInfo.Host;
  end;
  SMTPOBJ.Connect;
  try
    SMTPOBJ.Send(Msg);
    PutSMTP:=true;
  except
  end;
  SMTPOBJ.Disconnect;
  msg.Free;
end;
Function TCarrier.PutFTP(FTPOBJ:TIdFTP;sdata:string):Boolean;
var stmp:string;
    FileStream: TStringStream;
    itmp,ibit:integer;
begin
  PutFTP:=false;
  FileStream := TStringStream.Create(sdata);
  try
    if not FTPOBJ.Connected then  FTPOBJ.Connect;
    stmp:=FTPOBJ.SocksInfo.Host;
    ibit:=2;
    repeat
      itmp:=pos(stmp[1],copy(stmp,ibit,255));
      if itmp>0 then
      begin
        try
          FTPOBJ.ChangeDir(stmp);
          break;
        except
          FTPOBJ.MakeDir(copy(stmp,1,ibit+itmp-1));
        end;
        ibit:=ibit+itmp+1;
      end;
    until itmp=0;
    FTPOBJ.ChangeDir(stmp);
    stmp:=FTPOBJ.SocksInfo.Password+' '+inttostr(gettickCount)+'.'+FTPOBJ.SocksInfo.UserID;
    FTPOBJ.Put(FileStream,stmp);
    PutFTP:=true;
    FTPOBJ.Disconnect;
  except
    FTPOBJ.Disconnect;
  end;
  FileStream.Free;
end;
Function TCarrier.PutHTTP(HTTPOBJ:TIdHTTP;sdata:string):Boolean;
var  sPostData:TStrings;
     Response: TStringStream;
begin
  PutHTTP:=false;
  sPostData:=Tstringlist.Create;
  sPostData.Text:=HTTPOBJ.SocksInfo.Password+sdata;
  Response := TStringStream.Create('');
  try
    HTTPOBJ.Post(HTTPOBJ.SocksInfo.Host, sPostData, Response);
    PutHTTP:=true;
  except
  end;
  Response.Free;
  sPostData.Free;
end;
Function TCarrier.PutFile(FileOBJ:TFileFace;sdata:string):Boolean;
var stmp:string;
    f:textfile;
begin
  PutFile:=false;
  try
    repeat
      stmp:=FileOBJ.FilePath+FileOBJ.Prefix+inttostr(GetTickCount)+'.'+FileOBJ.suffix;
    until not FileExists(stmp);
    AssignFile(f,stmp);
    Rewrite(F);
    Writeln(f, sdata);
    closefile(f);
    PutFile:=true;
  except
      closefile(f);
  end;
end;
Function TCarrier.PutMSMQ(MSMQOBJ:TMSMQFace;sdata:string):Boolean;
var  Info,Queue,Mess:OleVariant;
begin
  PutMSMQ:=false;
  try
    Info:=CreateOleObject('MSMQ.MSMQQueueInfo');
    Queue:=CreateOleObject('MSMQ.MSMQQueue');
    Mess:=CreateOleObject('MSMQ.MSMQMessage');
    Info.PathName:=MSMQOBJ.MSMQPath;
    if Info.PathNameDNS='' then Info.Create;
    Queue:=Info.Open(2,0);
    Mess.Body:=sdata+#0;
    mess.Label:='From Transceiver';
    mess.send(Queue);
    Queue.Close;
    Info:= Unassigned;
    Queue:= Unassigned;
    Mess:= Unassigned;
    PutMSMQ:=true;
  except
    Info:= Unassigned;
    Queue:= Unassigned;
    Mess:= Unassigned;
  end;
end;
Function TCarrier.PutDB(DBOBJ:TDBFace;sdata:string):Boolean;
var Conn:OleVariant;
begin
  PutDB:=false;
  try
    Conn:=CreateOleObject('ADODB.Connection');
    Conn.Open(DBOBJ.DBPath);
    Conn.Execute('insert into '+DBOBJ.SQL+' (data) values ('''+sdata+''')');
    Conn.close;
    Conn:= Unassigned;
    PutDB:=true;
  except
    Conn:= Unassigned;
  end;
end;
Function TCarrier.PutCOM(COMOBJ:TCOMFace;sdata:string):Boolean;
var Com:OleVariant;
begin
  PutCOM:=false;
  try
    Com:=CreateOleObject(COMOBJ.ComPath);
    Com.PutData(sdata);        //if Result<>#0 then sendToReply(stmp);
    Com:= Unassigned;
    PutCOM:=true;
  except
    Com:= Unassigned;
  end;
end;
Function TCarrier.DataSend(sData:String;PortID:Integer;IsReply:boolean=false):boolean;
var Obj:TComponent;
begin
  DataSend:=false;
  if IsReply then Obj:=FindComponent('Reply'+inttostr(PortID)) else Obj:=FindComponent('Send'+inttostr(PortID));
  if (obj=nil) or (obj.Tag =-1) then exit;
  case obj.Tag of
  1:DataSend:=PutTCP(TClientSocket(obj),sdata);
  3:DataSend:=PutSMTP(TIdSMTP(obj),sdata);
  5:DataSend:=PutFTP(TIdFTP(obj),sdata);
  7:DataSend:=PutHTTP(TIdHTTP(obj),sdata);
  9:DataSend:=PutFile(TFileFace(obj),sdata);
  11:DataSend:=PutMSMQ(TMSMQFace(obj),sdata);
  13:DataSend:=PutDB(TDBFace(obj),sdata);
  15:DataSend:=PutCOM(TCOMFace(obj),sdata);
  end;
end;

procedure TCarrier.DataArrive(sData:String;PortID:Integer);
var ADOOBJ,recd:OleVariant;
    sTime:string;
    itmp:integer;
 //   bSendSeccess:Boolean;
begin
  if sData='' then exit;
  sTime:= datetimetostr(now);   //mark Receive Time
  if sData[length(sdata)]=#0 then sdata:=copy(sdata,1,length(sdata)-1);

  if DataSend(sdata,PortID) then
  begin
    if (regval.LogType='DB') and (regval.LogOnlyError='false')  then
    begin
    //  ADOOBJ.Execute('update log set SendTime='''+sTime+''',State=1 where ID='+inttostr(itmp));
      ADOOBJ:=CreateOleObject('ADODB.Connection');
      ADOOBJ.Open(regval.LogDB);
      ADOOBJ.Execute('insert into log (ReceiveTime,PortID,Data,state,SendTime) values ('''+sTime+''','+inttostr(PortID)+','''+sData+''',1,'''+datetimetostr(now)+''')');
      ADOOBJ.Close;
      ADOOBJ:= Unassigned;
    end;
  end
  else
  begin
    itmp:=-1;
    ADOOBJ:=CreateOleObject('ADODB.Connection');
    if regval.LogType='DB' then
    begin
      ADOOBJ.Open(regval.LogDB);
      recd:=CreateOleObject('adodb.recordset');
      recd.open('log',adoobj,1,3);
      recd.addnew;
      recd.Fields['ReceiveTime']:=sTime;
      recd.Fields['PortID']:=PortID;
      recd.Fields['data']:=sdata;
      if regval.QueueType='None' then recd.Fields['State']:=3 else recd.Fields['State']:=2;
      recd.update;
      itmp:=recd.Fields['ID'];
      recd.close;
      recd:=Unassigned;
      ADOOBJ.Close;
    end;
    if regval.QueueType='DB' then
    begin
      ADOOBJ.Open(regval.QueueDB);
      ADOOBJ.Execute('insert into data (stamp,PortID,Data,state,logID) values ('''+sTime+''','+inttostr(PortID)+','''+sData+''',2,'+inttostr(itmp)+')');
      ADOOBJ.Close;
    end;
    ADOOBJ:= Unassigned;
  end;
//  sendMessage(findwindow('Tfrmcfg',nil),WM_User+$1011,0,0);
end;

procedure TCarrier.TCPServerClientError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
  ErrorCode:=0;
end;

end.