dpcon.pas

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

    cmb^.SetFocus ;
    grdChannel.Hint:=Value;
  end;
end;

procedure Tfrmcfg.grdChannelSetEditText(Sender: TObject; ACol, ARow: Integer;
  const Value: String);
begin
  grdChannel.Cells[6,ARow]:='update'; //record update marker
end;

procedure Tfrmcfg.btcAddClick(Sender: TObject);
begin
  if length(trim(grdChannel.Rows[grdChannel.RowCount-1].Text)) <2 then exit;
  grdChannel.RowCount:=grdChannel.RowCount+1;
  grdChannel.Rows[grdChannel.RowCount-1].Clear;
  grdChannel.Row:=grdChannel.RowCount-1;
  grdChannel.Col:=1;
end;

procedure Tfrmcfg.btcDelClick(Sender: TObject);
begin
  grdChannel.Cells[6,grdChannel.Row]:='update';
  if copy(grdChannel.Cells[5,grdChannel.Row],1,1)<>'*' then grdChannel.Cells[5,grdChannel.Row]:='*'+grdChannel.Cells[5,grdChannel.Row];
end;

procedure Tfrmcfg.btcRefreshClick(Sender: TObject);
var itmp,ival1,ival2,ival3:integer;
    ADOOBJ:OleVariant;
    sSql,stmp,sValid:string;
begin
   if TabChannelCfg.Tag =1 then TabChannelCfg.Tag:=0 else exit;
   ADOOBJ:=CreateOleObject('ADODB.Connection');
   ADOOBJ.Open(regval.ConfigDB);
  with grdChannel do
  begin
    for itmp:=1 to RowCount do
    begin
      if Cells[6,itmp]='update' then
      begin

        ssql:=Cells[1,itmp];
        stmp:=Cells[5,itmp];
        ival1:=cmbsource.Items.IndexOf(Cells[2,itmp]);
        ival2:=cmbtarget.Items.IndexOf(Cells[3,itmp]);
        ival3:=cmbtarget.Items.IndexOf(Cells[4,itmp]);
        if (trimleft(ssql+stmp)='') and (ival1+ival2+ival3=-3) then continue;
        if ssql='' then sSql:='Channel'+inttostr(itmp);
        if stmp='' then stmp:=' ';
        if ival1=-1 then ival1:=0;
        if ival2=-1 then ival2:=0;
        if ival3=-1 then ival3:=0;
        ival1:=cmbsource.ItemsEx[ival1].ImageIndex;
        ival2:=cmbtarget.ItemsEx[ival2].ImageIndex;
        ival3:=cmbtarget.ItemsEx[ival3].ImageIndex;
        if (ival1=-1) or (ival2=-1) then sValid:='false' else sValid:='true';
        //        if ival3<>-1 then ival3:=cmbtarget.ItemsEx[ival3].ImageIndex;
        if Cells[0,itmp]='' then//add
          (if copy(stmp,1,1)<>'*' then sSql:='insert into channel (ChannelName,Description,SourcePort,TargetPort,ReplyPort,state) values  ('''+sSql+''','''+stmp+''','+inttostr(ival1)+','+inttostr(ival2)+','+inttostr(ival3)+','+sValid+')'
            else sSql:='')
        else//Delete or edit
          (if copy(stmp,1,1)='*' then
            sSql:='DELETE from channel where id='+Cells[0,itmp]+''
          else
            sSql:='UPDATE channel set ChannelName='''+sSql+''',Description='''+stmp+
            ''',SourcePort='+inttostr(ival1)+',TargetPort='+inttostr(ival2)+
            ',ReplyPort='+inttostr(ival3)+',state='+sValid+' where id='+Cells[0,itmp]+'');
        if sSql<>'' then ADOOBJ.Execute(sSql);
      end;
    end;
  end;
  ADOOBJ.Close;
  ADOOBJ:=Unassigned;
  if Tbutton(Sender).Name='BTok' then  exit;
  TabChannelCfgShow(TabChannelCfg);
end;

procedure Tfrmcfg.BTapplyClick(Sender: TObject);
begin
  btcRefreshClick(sender);
  btpRefreshClick(sender);
  btQRefreshClick(sender);
  btlRefreshClick(sender);
  reg.OpenKey(regval.RegAddress,true);
  reg.WriteString('QueueDB',edtQDB.Text);
//  reg.WriteString('QueueMSMQ',edtQMSMQ.Text);
  reg.WriteString('LogDB',edtLDB.Text);
  reg.WriteString('LogCount',edtLCount.Text);
  if chklog.Checked then reg.WriteString('LogOnlyError','True') else reg.WriteString('LogOnlyError','False');
//  reg.WriteString('LogFile',edtLFile.Text);
  reg.WriteString('Language',cmblanguage.Text);
  reg.WriteString('QueueInterval',inttostr(edtQinterval.Value));
  reg.WriteString('QueueRetryCount',inttostr(edtQCount.Value));
  if rdoQNone.Checked then reg.WriteString('QueueType','None');
  if rdoQDB.Checked then reg.WriteString('QueueType','DB');
//  if rdoQMSMQ.Checked then reg.WriteString('QueueType','MSMQ');
  if rdoLNone.Checked then reg.WriteString('LogType','None');
  if rdoLDB.Checked then reg.WriteString('LogType','DB');
//  if rdoLFile.Checked then reg.WriteString('LogType','File');
  reg.CloseKey;
end;

procedure Tfrmcfg.FormCreate(Sender: TObject);
var stmp,CurrentDir:string;
begin
  CurrentDir:=ExtractFilePath(ParamStr(2));
// CurrentDir:=GetCurrentDir;
//  labver.Caption:='V.'+datetimetostr(FileDateToDateTime(FileAge(copy(ParamStr(2),1,pos(',',ParamStr(2))-1))));
  labver.Caption:='V.1.00.0518';
  if CurrentDir[length(CurrentDir)]<>'\' then CurrentDir:=CurrentDir+'\carrier.mdb' else CurrentDir:=CurrentDir+'carrier.mdb';
  reg:=TRegistry.Create;
  reg.RootKey:=Hkey_Local_Machine;
  regval.RegAddress:='SOFTWARE\DRPACIFIC\DP Connection\Transceiver';
  regval.QueueType:='DB';
  regval.QueueInterval:='10';
  regval.QueueRetryCount:='10';
//  regval.QueueMSMQ:='.\private$\DPCache';
  regval.LogType:='DB';
  regval.LogCount:='1000';
  regval.LogOnlyError:='true';
//  regval.LogFile:='C:\DPLOG.LOG';
  regval.Language:='English';
  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;
  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;
  TRadioButton(FindComponent('rdoQ'+regval.QueueType)).Checked:=true;

  if not reg.ValueExists('LogType') then  reg.WriteString('LogType',regval.LogType);
  stmp:=reg.ReadString('LogType');
  if trim(stmp)<>''  then regval.LogType:=stmp;
  TRadioButton(FindComponent('rdol'+regval.LogType)).Checked:=true;

  if reg.ValueExists('LogCount') then regval.LogCount:= reg.ReadString('LogCount') else reg.WriteString('LogCount',regval.LogCount ) ;
  edtLCount.Text:=regval.LogCount ;

  if reg.ValueExists('LogOnlyError') then regval.LogOnlyError:= reg.ReadString('LogOnlyError') else reg.WriteString('LogOnlyError',regval.LogOnlyError ) ;
  if lowercase(regval.LogOnlyError)='true' then chklog.Checked:=true;

  if reg.ValueExists('QueueDB') then regval.QueueDB:= reg.ReadString('QueueDB') else reg.WriteString('QueueDB',regval.QueueDB ) ;
  edtQDB.Text:=regval.QueueDB ;

  if reg.ValueExists('QueueInterval') then regval.QueueInterval:= reg.ReadString('QueueInterval') else reg.WriteString('QueueInterval',regval.QueueInterval) ;
  edtQInterval.text:=regval.QueueInterval;

  if reg.ValueExists('QueueRetryCount') then regval.QueueRetryCount:= reg.ReadString('QueueRetryCount') else reg.WriteString('QueueRetryCount',regval.QueueRetryCount) ;
  edtQCount.Text:=regval.QueueRetryCount ;


//  if reg.ValueExists('QueueMSMQ') then regval.QueueMSMQ:=reg.ReadString('QueueMSMQ') else reg.WriteString('QueueMSMQ',regval.QueueMSMQ ) ;
//  edtQMSMQ.Text:=regval.QueueMSMQ;
  if reg.ValueExists('LogDB') then regval.LogDB :=reg.ReadString('LogDB')  else reg.WriteString('LogDB',regval.LogDB ) ;
  edtLDB.Text:=regval.LogDB;
//  if reg.ValueExists('LogFile') then regval.LogFile:=reg.ReadString('LogFile')  else reg.WriteString('LogFile',regval.LogFile) ;
//  edtLFile.Text:=regval.LogFile;
  if reg.ValueExists('ConfigDB') then regval.ConfigDB:=reg.ReadString('ConfigDB')  else reg.WriteString('ConfigDB',regval.ConfigDB) ;
  if reg.ValueExists('Language') then cmblanguage.ItemIndex:=cmblanguage.Items.IndexOf(reg.ReadString('Language'))  else reg.WriteString('Language',regval.Language) ;
  reg.CloseKey;
end;

procedure Tfrmcfg.FormDestroy(Sender: TObject);
begin
  reg.Free;
end;

procedure Tfrmcfg.TabPortCfgShow(Sender: TObject);
var ADOOBJ,recd:OleVariant;
    NullTest:Variant;
    item:TComboExItem;
    litem:TListitem;
begin
  if TabPortCfg.Tag =1 then exit else TabPortCfg.Tag:=1;
  ADOOBJ:=CreateOleObject('ADODB.Connection');
  recd:=CreateOleObject('adodb.recordset');
  ADOOBJ.Open(regval.ConfigDB);
  if cmbProtocol.Items.Count=0 then
  begin
    recd.open('select Protocol,ID,type from Protocol order by type,protocol',adoobj,1);
    while not recd.eof do
    begin
      NullTest:=recd.Fields['Protocol'].value;
      if VarType(NullTest)=varNull then continue;
      item:=cmbProtocol.ItemsEx.Add;
      item.Caption:=NullTest;
      NullTest:=recd.Fields['ID'].value;
      item.ImageIndex:=NullTest;
      recd.movenext;
    end;
    recd.close;
  end;
  recd.open('select ptc.Protocol,ptc.type,pt.id,pt.address,pt.portname,pt.Port,pt.Timeout,pt.User,pt.Password,pt.Interval,pt.Encode,pt.Description,pt.Reserve from Port pt,protocol ptc where pt.protocol=ptc.id',adoobj,1);
  while not recd.eof do
  begin

    NullTest:=recd.Fields['PortName'].value;
    litem:=lstport.Items.Add;
    if VarType(NullTest)<>varNull then litem.Caption:=NullTest;

    NullTest:=recd.Fields['Type'].value;
    if VarType(NullTest)=varNull then litem.ImageIndex:=0  else litem.ImageIndex:=NullTest+1;

    NullTest:=recd.Fields['Protocol'].value;
    if VarType(NullTest)<>varNull then litem.SubItems.Add(NullTest) else litem.SubItems.Add('0') ;

    NullTest:=recd.Fields['ID'].value;
    if VarType(NullTest)<>varNull then litem.SubItems.Add(NullTest) else litem.SubItems.Add('0') ;

    NullTest:=recd.Fields['Address'].value;
    if VarType(NullTest)<>varNull then litem.SubItems.Add(NullTest) else litem.SubItems.Add('');

    NullTest:=recd.Fields['Port'].value;
    if VarType(NullTest)<>varNull then  litem.SubItems.Add(NullTest) else litem.SubItems.Add('0');

    NullTest:=recd.Fields['Timeout'].value;
    if VarType(NullTest)<>varNull then  litem.SubItems.Add(NullTest) else litem.SubItems.Add('0');

    NullTest:=recd.Fields['User'].value;
    if VarType(NullTest)<>varNull then litem.SubItems.Add(NullTest) else litem.SubItems.Add('');

    NullTest:=recd.Fields['Password'].value;
    if VarType(NullTest)<>varNull then litem.SubItems.Add(NullTest) else litem.SubItems.Add('');

    NullTest:=recd.Fields['Interval'].value;
    if VarType(NullTest)<>varNull then  litem.SubItems.Add(NullTest) else litem.SubItems.Add('0');

    NullTest:=recd.Fields['Encode'].value;
    if VarType(NullTest)<>varNull then litem.SubItems.Add(NullTest) else litem.SubItems.Add('-1');

    NullTest:=recd.Fields['Description'].value;
    if VarType(NullTest)<>varNull then litem.SubItems.Add(NullTest) else litem.SubItems.Add('');

    NullTest:=recd.Fields['Reserve'].value;
    if VarType(NullTest)<>varNull then litem.SubItems.Add(NullTest) else litem.SubItems.Add('');
    litem.SubItems.Add('');
    recd.movenext;
  end;
  recd.close;
  ADOOBJ.Close;
  recd := Unassigned;
  ADOOBJ:=Unassigned;
end;

procedure Tfrmcfg.lstPortCompare(Sender: TObject; Item1, Item2: TListItem;
  Data: Integer; var Compare: Integer);
begin
  if TComponent(Sender).Tag = 0 then
    Compare := CompareText(Item1.Caption,Item2.Caption)
  else
   Compare := CompareText(Item1.SubItems[TComponent(Sender).Tag-1],Item2.SubItems[TComponent(Sender).Tag-1]);
end;

procedure Tfrmcfg.lstPortColumnClick(Sender: TObject; Column: TListColumn);
begin
  TComponent(Sender).Tag  := Column.Index;
  (Sender as TCustomListView).AlphaSort;

end;

procedure Tfrmcfg.lstPortSelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
var ADOOBJ,recd:OleVariant;
    itmp:integer;
    NullTest:Variant;
begin
  if not Selected then
  begin
     edtportname.Hint:='';
     cmbprotocol.Hint:='';
     edtaddress.Hint:='';
     edtport.Hint:='';
     edttimeout.Hint:='';
     edtuser.Hint:='';
     edtpassword.Hint:='';
     edtinterval.Hint:='';
     cmbencode.Hint:='';
     edtdescription.Hint:='';
     edtreserve.Hint:='';
     exit;
  end;
  edtportname.Enabled:=true;
  labportname.Enabled :=true;
  cmbprotocol.Enabled:=true;
  labprotocol.Enabled:=true;
  labencode.Enabled:=true;
  labdescription.Enabled:=true;
  cmbencode.Enabled:=true;
  edtdescription.Enabled:=true;
  edtportname.Text:=item.Caption;
  if trim(item.SubItems[0])='' then itmp:=0 else itmp:=cmbprotocol.Items.IndexOf(item.SubItems[0]);
  cmbprotocol.ItemIndex:=itmp;
  //if Tcomponent(sender)<>cmbprotocol then cmbprotocol.Text:=item.SubItems[0] else item.SubItems[0]:=cmbprotocol.Text;
  itmp:=cmbprotocol.ItemsEx[itmp].ImageIndex;
  ADOOBJ:=CreateOleObject('ADODB.Connection');
  recd:=CreateOleObject('adodb.recordset');
  ADOOBJ.Open(regval.ConfigDB);
  recd.open('select * from Protocol where id='+inttostr(itmp),adoobj,1);
  if recd.recordcount >0 then
  begin
    NullTest:=recd.Fields['Address'].value;
    if VarType(NullTest)<>varNull then
      if trim(NullTest)='' then
      begin
        labaddress.Enabled:=false;
        edtaddress.Enabled:=false;
      end
      else
      begin
        edtaddress.Text:=item.SubItems[2];
        labaddress.Caption:=NullTest;
        labaddress.Enabled:=true;
        edtaddress.Enabled:=true;
      end
    else
    begin
      labaddress.Enabled:=false;
      edtaddress.Enabled:=false;
    end;


    NullTest:=recd.Fields['Port'].value;
    if VarType(NullTest)<>varNull then
      if trim(NullTest)='' then
      begin
        labport.Enabled:=false;
        edtport.Enabled:=false;
      end
      else
      begin
        if trim(item.SubItems [3])='' then edtport.Text :='0' else edtport.Text :=item.SubItems [3];
        labport.Enabled:=true;
        edtport.Enabled:=true;
      end
    else
    begin
      labport.Enabled:=false;
      edtport.Enabled:=false;
    end;

    NullTest:=recd.Fields['Timeout'].value;
    if VarType(NullTest)<>varNull then
      if trim(NullTest)='' then
      begin
        labTimeout.Enabled:=false;
        edtTimeout.Enabled:=false;
      end
      else
      begin
        if trim(item.SubItems[4])='' then  edtTimeout.Text:='0' else edtTimeout.Text:=item.SubItems[4];
        labTimeout.Enabled:=true;
        edtTimeout.Enabled:=true;
      end
    else
    begin
      labTimeout.Enabled:=false;
      edtTimeout.Enabled:=false;
    end;

    NullTest:=recd.Fields['User'].value;
    if VarType(NullTest)<>varNull then
      if trim(NullTest)='' then
      begin
        labUser.Enabled:=false;
        edtUser.Enabled:=false;
      end
      else
      begin
        edtUser.Text :=item.SubItems [5];
        labUser.Enabled:=true;
        edtUser.Enabled:=true;
      end
    else
    begin
      labUser.Enabled:=false;
      edtUser.Enabled:=false;
    end;

    NullTest:=recd.Fields['Password'].value;