unit1.pas

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

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes,Registry, SvcMgr,
  ScktComp,ComObj,Variants,Forms, IdHTTP,IdSMTP,IdFTP,IdMessage,IdPOP3;

type
  TRegVal=Record
    ConfigDB:string;
    RegAddress:string;
    QueueType:string;
    QueueInterval:string;
    QueueRetryCount:string;
    LogType:string;
    QueueDB:string;
    LogCount:string;
    LogOnlyError:string;    
//    QueueMSMQ:string;
    LogDB:string;
//    LogFile:string;
end;

type
   TDBFace=class(TComponent)
   private
       DBPath:string;
       SQL:string;
   end;

type
   TFileFace=class(TComponent)
   private
       FilePath:string;
       Prefix:string;
       suffix:string;
   end;

type
   TMSMQFace=class(TComponent)
   private
       MSMQPath:string;
   end;

type
   TCOMFace=class(TComponent)
   private
       ComPath:string;
   end;





type
  TCarrier = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure TCPServersClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure TCPServerClientError(Sender: TObject;
      Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
      var ErrorCode: Integer);



    Procedure Timer(var Msg: TMsg; var Handled: Boolean);  //trigger Receive/Queue process
    procedure DataArrive(sData:String;PortID:Integer);    //after Data receive process
    Function DataSend(sData:String;PortID:Integer;IsReply:Boolean=false):boolean; //data send process

    //Receive Process
    procedure GetFTP(FTPOBJ:TIdFTP);
    procedure GetPOP3(POP3Obj:TIdPOP3);
    procedure GetHTTP(HTTPObj:TIdHTTP);
    procedure GetFile(fileObj:TFileFace);
    procedure GetMSMQ(MSMQObj:TMSMQFace);
    procedure GetDB(DBObj:TDBFace);
    procedure GetCOM(COMObj:TCOMFace);

    //Send Process
    Function PutTCP(TCPOBJ:TClientSocket;sdata:string):Boolean;
    Function PutSMTP(SMTPOBJ:TIdSMTP;sdata:string):Boolean;
    Function PutFTP(FTPOBJ:TIdFTP;sdata:string):Boolean;
    Function PutHTTP(HTTPOBJ:TIdHTTP;sdata:string):Boolean;
    Function PutFile(FileOBJ:TFileFace;sdata:string):Boolean;
    Function PutMSMQ(MSMQOBJ:TMSMQFace;sdata:string):Boolean;
    Function PutDB(DBOBJ:TDBFace;sdata:string):Boolean;
    Function PutCOM(COMOBJ:TCOMFace;sdata:string):Boolean;


  private
    { Private declarations }
    regval:Tregval;
    TCPClient:array of TClientSocket;
    TCPServer:array of TServerSocket;
    HTTPClient:array of TIdHTTP;
    HTTPServer:array of TIdHTTP;
    FTPSource: array of TIdFTP;
    FTPTarget: array of TIdFTP;
    POP3Source:array of TIdPOP3;
    SMTPTarget:array of TIdSMTP;
    dbSource:array of TDBFace;
    dbTarget:array of TDBFace;
    fileSource:array of TFileFace;
    fileTarget:array of TFileFace;
    msmqSource:array of TMSMQFace;
    msmqTarget:array of TMSMQFace;
    comSource:array of TCOMFace;
    comTarget:array of TCOMFace;






  public
    { Public declarations }
  end;

var
  Carrier: TCarrier;

implementation

{$R *.dfm}





procedure TCarrier.FormCreate(Sender: TObject);
var reg:TRegistry;
    stmp,CurrentDir,sbit:string;
    ADOOBJ,recd,rece:OleVariant;
    NullTest:Variant;
    itmp,isource,itarget,ibit:integer;
    bValid:boolean;
begin
  CurrentDir:=GetCurrentDir;
  if CurrentDir[length(CurrentDir)]<>'\' then CurrentDir:=CurrentDir+'\';
  regval.RegAddress:='SOFTWARE\DRPACIFIC\DP Connection\Transceiver';
  regval.QueueType:='DB';
  regval.QueueInterval:='10';
  regval.QueueRetryCount:='10';
  regval.LogType:='DB';
  regval.LogCount:='1000';
  regval.LogOnlyError:='true';

  //  regval.LogFile:=CurrentDir+'carrier.Log';
  CurrentDir:=CurrentDir+'carrier.mdb';
  regval.ConfigDB:='driver={Microsoft Access Driver (*.mdb)};dbq='+CurrentDir;
  regval.QueueDB:='driver={Microsoft Access Driver (*.mdb)};dbq='+CurrentDir;
  regval.LogDB:='driver={Microsoft Access Driver (*.mdb)};dbq='+CurrentDir;
//  regval.QueueMSMQ:='.\private$\TransceiverCache';
//  regval.DataID:=0;
  reg:=TRegistry.Create;
  reg.RootKey:=HKEY_LOCAL_MACHINE;
  reg.OpenKey(regval.RegAddress,true);

  if not reg.ValueExists('QueueType') then reg.WriteString('QueueType',regval.QueueType);
  stmp:=reg.ReadString('QueueType');
  if trim(stmp)<>'' then regval.QueueType:=stmp  ;

  if not reg.ValueExists('QueueInterval') then  reg.WriteString('QueueInterval',regval.QueueInterval);
  stmp:=reg.ReadString('QueueInterval');
  if trim(stmp)<>''  then regval.QueueInterval:=stmp;

  if not reg.ValueExists('QueueRetryCount') then  reg.WriteString('QueueRetryCount',regval.QueueRetryCount);
  stmp:=reg.ReadString('QueueRetryCount');
  if trim(stmp)<>''  then regval.QueueRetryCount:=stmp;


  if not reg.ValueExists('LogType') then  reg.WriteString('LogType',regval.LogType);
  stmp:=reg.ReadString('LogType');
  if trim(stmp)<>''  then regval.LogType:=stmp;

  if not reg.ValueExists('LogCount') then reg.WriteString('LogCount',regval.LogCount) ;
  stmp:=reg.ReadString('LogCount');
  if trim(stmp)<>''  then regval.LogCount:=stmp;

  if not reg.ValueExists('LogOnlyError') then  reg.WriteString('LogOnlyError',regval.LogOnlyError) ;
  stmp:=lowercase(reg.ReadString('LogOnlyError'));
  if trim(stmp)<>'' then regval.LogOnlyError :=stmp;

  if not reg.ValueExists('QueueDB') then  reg.WriteString('QueueDB',regval.QueueDB) ;
  stmp:=reg.ReadString('QueueDB');
  if trim(stmp)<>''  then regval.QueueDB:=stmp;
//  if reg.ValueExists('QueueMSMQ') then regval.QueueMSMQ:=reg.ReadString('QueueMSMQ') else reg.WriteString('QueueMSMQ',regval.QueueMSMQ);

  if not reg.ValueExists('LogDB') then  reg.WriteString('LogDB',regval.LogDB) ;
  stmp:=reg.ReadString('LogDB');
  if trim(stmp)<>'' then  regval.LogDB :=stmp;
  //  if reg.ValueExists('LogFile') then regval.LogFile:=reg.ReadString('LogFile')  else reg.WriteString('LogFile',regval.LogFile) ;

  if not reg.ValueExists('ConfigDB') then reg.WriteString('ConfigDB',regval.ConfigDB) ;
  stmp:=reg.ReadString('ConfigDB');
  if trim(stmp)<>'' then regval.ConfigDB:=stmp;
  reg.CloseKey;
  reg.Free;

  ADOOBJ:=CreateOleObject('ADODB.Connection');
  recd:=CreateOleObject('adodb.recordset');
  rece:=CreateOleObject('adodb.recordset');
  ADOOBJ.Open(regval.ConfigDB);
  recd.open('select ID,SourcePort,TargetPort,ReplyPort from channel where state=true',adoobj,1);
  while not recd.eof do
  begin
    NullTest:=recd.Fields['SourcePort'].value;
    if NullTest =Null then isource:=-1 else isource:=NullTest;

    NullTest:=recd.Fields['TargetPort'].value;
    if NullTest =Null  then itarget:=-1 else itarget:=NullTest;

    if isource>-1 then
    begin
      stmp:='Receive'+inttostr(isource);
      if FindComponent(stmp)=nil then //if no exist then Create Source instance
      begin
        rece.open('select * from port where id='+inttostr(isource),adoobj,1);
        if  rece.recordcount>0 then
        begin
          NullTest:=rece.Fields['Protocol'].value;
          if NullTest <>Null then
          begin
            bValid:=true;
            case NullTest of
              2:   //Create TCP/Receive
              begin
                itmp:=high(TCPServer)+1;
                SetLength(TCPServer,itmp+1);
                TCPServer[itmp]:=TServerSocket.Create(self);
                TCPServer[itmp].OnClientRead:=TCPServersClientRead;
                TCPServer[itmp].OnClientError:=TCPServerClientError;
   //             NullTest:=recd.Fields['ID'].value;

                TCPServer[itmp].Tag:=itarget; //Marker TargetPort ID
                TCPServer[itmp].Name:=stmp;

                NullTest:=rece.Fields['Port'].value;
                if (NullTest =null) or (NullTest=0)  then bValid:=false else TCPServer[itmp].Port:=NullTest;
                try
                  if bValid then TCPServer[itmp].Active:=true;
                  TCPServer[itmp].Socket.Data:=@TCPServer[itmp].Tag;  //TargetPort ID Pointer
                except
                end;
              end;
              4:  //Create POP3
              begin
                itmp:=high(POP3Source)+1;
                SetLength(POP3Source,itmp+1);
                POP3Source[itmp]:=TIdPOP3.Create(self);
                POP3Source[itmp].Name:=stmp;
                POP3Source[itmp].Tag:=itarget;
                NullTest:=rece.Fields['Address'].value;
                if (NullTest <>null) and (trim(NullTest) <>'') then POP3Source[itmp].Host :=NullTest else  bValid:=false;
                NullTest:=rece.Fields['Port'].value;
                if  NullTest <>null  then (if NullTest<>0 then POP3Source[itmp].Port :=NullTest) else  bValid:=false;
                NullTest:=rece.Fields['user'].value;
                if NullTest <>null then POP3Source[itmp].UserId :=NullTest else  bValid:=false;
                NullTest:=rece.Fields['password'].value;
                if NullTest <>null then  POP3Source[itmp].Password :=NullTest else bValid:=false;
                NullTest:=rece.Fields['Description'].value;
                if NullTest <>null then POP3Source[itmp].SocksInfo.Password :=trim(NullTest) else bValid:=false;
                NullTest:=rece.Fields['interval'].value;
                if NullTest <>null then if bValid then SetTimer(application.handle,isource,NullTest*60000,nil);
              end;
              6:   //FTP/Receive
              begin
                itmp:=high(FTPSource)+1;
                SetLength(FTPSource,itmp+1);
                FTPSource[itmp]:=TIdFTP.Create(self);
                FTPSource[itmp].Name:=stmp;
                FTPSource[itmp].tag:=itarget;
                NullTest:=rece.Fields['Address'].value;
                if (NullTest <>null) and (trim(NullTest)<>'') then FTPSource[itmp].Host:=NullTest else bValid:=false;
                NullTest:=rece.Fields['Port'].value;
                if NullTest <>null then  (if NullTest<>0  then FTPSource[itmp].Port:=NullTest) else bValid:=false;
                NullTest:=rece.Fields['user'].value;
                if NullTest <>null then if trim(NullTest)='' then FTPSource[itmp].User:='anonymous' else FTPSource[itmp].User :=NullTest else  bValid:=false;
                NullTest:=rece.Fields['password'].value;
                if NullTest <>null then if trim(NullTest)='' then  FTPSource[itmp].Password :='[e-mail]' else FTPSource[itmp].Password :=NullTest else bValid:=false;
                NullTest:=rece.Fields['Description'].value;
                if NullTest <>null then  FTPSource[itmp].SocksInfo.Password :=NullTest else bValid:=false;
                NullTest:=rece.Fields['Reserve'].value;
                if NullTest <>null then
                begin
                  stmp:=NullTest;
                  if trim(stmp)='' then stmp:='/'
                  else
                  begin
                    if pos('/',stmp)<pos('\',stmp) then sbit:='\' else sbit:='/';
                    if stmp[1]<>sbit then NullTest:=sbit+NullTest;
                    if stmp[length(stmp)]<>sbit then NullTest:=NullTest+sbit;
                  end;
                  FTPSource[itmp].SocksInfo.Host:=NullTest;
                end else bValid:=false;
                NullTest:=rece.Fields['interval'].value;
                if NullTest <>null then if bValid then SetTimer(application.handle,isource,NullTest*60000,nil);
              end;
              8:    //HTTP/Receive
              begin
                itmp:=high(HTTPServer)+1;
                SetLength(HTTPServer,itmp+1);
                HTTPServer[itmp]:=TIdHTTP.Create(self);
                HTTPServer[itmp].Name:=stmp;
                HTTPServer[itmp].tag:=itarget;
                NullTest:=rece.Fields['Address'].value;
                if (NullTest <>null) and (trim(NullTest) <>'') then stmp:=NullTest else bValid:=false;
                NullTest:=rece.Fields['Port'].value;
                if (NullTest <>null) and (NullTest<>0) and (NullTest<>80) then sbit:=inttostr(NullTest) else sbit:='';
                if bValid and (sbit<>'') then
                begin
                  ibit:=pos('/',copy(stmp,9,512));
                  Insert(':'+sbit,stmp,ibit+8);
                end;
                HTTPServer[itmp].SocksInfo.Host:=stmp;
                NullTest:=rece.Fields['interval'].value;
                if NullTest <>null then if bValid then SetTimer(application.handle,isource,NullTest*60000,nil);
              end;
              10:   //File/Receive
              begin
                itmp:=high(fileSource)+1;
                SetLength(fileSource,itmp+1);
                fileSource[itmp]:=TFileFace.Create(self);

                fileSource[itmp].Tag:=itarget; //Marker TargetPort ID
                fileSource[itmp].Name:=stmp;

                NullTest:=rece.Fields['Address'].value;
                if (NullTest <>null) and (trim(NullTest) <>'') then  stmp:=NullTest else bValid:=false;
                if DirectoryExists(stmp) then
                  if stmp[length(stmp)]='\' then stmp:=stmp+'*.*'
                    else stmp:=stmp+'\*.*'
                else
                  if not DirectoryExists(ExtractFiledir(stmp)) then if not ForceDirectories(ExtractFiledir(stmp)) then  bValid:=false;
                fileSource[itmp].FilePath:=stmp;
                NullTest:=rece.Fields['interval'].value;
                if NullTest <>null then if bValid then SetTimer(application.handle,isource,NullTest*60000,nil);
              end;
              12:  //MSMQ/Receive
              begin
                itmp:=high(msmqSource)+1;
                SetLength(msmqSource,itmp+1);
                msmqSource[itmp]:=TMSMQFace.Create(self);
                msmqSource[itmp].Tag:=itarget; //Marker TargetPort ID
                msmqSource[itmp].Name:=stmp;
                NullTest:=rece.Fields['Address'].value;
                if (NullTest <>null) and (trim(NullTest) <>'') then msmqSource[itmp].MSMQPath:=NullTest else bValid:=false;
                NullTest:=rece.Fields['interval'].value;
                if NullTest <>null then if bValid then SetTimer(application.handle,isource,NullTest*60000,nil);
              end;
              14:  //DB/Receive
              begin
                itmp:=high(dbSource)+1;
                SetLength(dbSource,itmp+1);
                dbSource[itmp]:=TDBFace.Create(self);
                dbSource[itmp].Tag:=itarget; //Marker TargetPort ID
                dbSource[itmp].Name:=stmp;
                NullTest:=rece.Fields['Address'].value;
                if (NullTest <>null) and (trim(NullTest) <>'') then dbSource[itmp].DBPath:=NullTest else bValid:=false;
                NullTest:=rece.Fields['Reserve'].value;
                if NullTest <>null then dbSource[itmp].SQL:=NullTest else bValid:=false;
                NullTest:=rece.Fields['interval'].value;
                if NullTest <>null then if bValid then SetTimer(application.Handle,isource,NullTest*60000,nil);
              end;
              16:  //COM/Receive
              begin
                itmp:=high(comSource)+1;
                SetLength(comSource,itmp+1);
                comSource[itmp]:=TCOMFace.Create(self);