dpcon.pas

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

unit DPCon;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, ComObj,StdCtrls, ImgList,Registry, ExtCtrls, Grids,
  Spin;


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







type
  Tfrmcfg = class(TForm)
    PageControl1: TPageControl;
    TabChannelCfg: TTabSheet;
    TabPortCfg: TTabSheet;
    TabGeneral: TTabSheet;
    BTapply: TButton;
    BTcancel: TButton;
    BTok: TButton;
    grpLanguage: TGroupBox;
    labLanguage: TLabel;
    cmblanguage: TComboBox;
    grpQueue: TGroupBox;
    LabQueue: TLabel;
    rdoQNone: TRadioButton;
    rdoQDB: TRadioButton;
    edtQDB: TEdit;
    grpLog: TGroupBox;
    LabLog: TLabel;
    rdoLNone: TRadioButton;
    rdoLDB: TRadioButton;
    edtLDB: TEdit;
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    TabQueue: TTabSheet;
    TabLog: TTabSheet;
    grdChannel: TStringGrid;
    cmbSource: TComboBoxEx;
    cmbTarget: TComboBoxEx;
    btcAdd: TButton;
    btcDel: TButton;
    btcRefresh: TButton;
    Image4: TImage;
    Image5: TImage;
    Image6: TImage;
    Image7: TImage;
    labTChannel: TLabel;
    labTPort: TLabel;
    labTQueue: TLabel;
    labTLog: TLabel;
    lstQueue: TListView;
    lstPort: TListView;
    edtPortname: TEdit;
    edtAddress: TEdit;
    cmbProtocol: TComboBoxEx;
    edtUser: TEdit;
    edtPassword: TEdit;
    cmbEncode: TComboBox;
    edtDescription: TEdit;
    edtReserve: TEdit;
    labportname: TLabel;
    labProtocol: TLabel;
    labAddress: TLabel;
    labPort: TLabel;
    labtimeout: TLabel;
    labUser: TLabel;
    labpassword: TLabel;
    labInterval: TLabel;
    labEncode: TLabel;
    labDescription: TLabel;
    labReserve: TLabel;
    ImageList1: TImageList;
    lstLog: TListView;
    btLDelAll: TButton;
    btLDel: TButton;
    btlRefresh: TButton;
    btQDel: TButton;
    btQRefresh: TButton;
    btqDelAll: TButton;
    btPAdd: TButton;
    btPDel: TButton;
    btpRefresh: TButton;
    edtport: TSpinEdit;
    edtTimeout: TSpinEdit;
    edtInterval: TSpinEdit;
    LabQueueInterval: TLabel;
    edtQInterval: TSpinEdit;
    LabQueueCount: TLabel;
    edtQCount: TSpinEdit;
    labver: TLabel;
    LabLogCount: TLabel;
    edtLCount: TSpinEdit;
    chkLog: TCheckBox;
    procedure TabChannelCfgShow(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure BTcancelClick(Sender: TObject);
    procedure BTokClick(Sender: TObject);
    procedure cmbSourceChange(Sender: TObject);
    procedure cmbSourceExit(Sender: TObject);
    procedure grdChannelGetEditText(Sender: TObject; ACol, ARow: Integer;
      var Value: String);
    procedure grdChannelSetEditText(Sender: TObject; ACol, ARow: Integer;
      const Value: String);
    procedure btcAddClick(Sender: TObject);
    procedure btcDelClick(Sender: TObject);
    procedure btcRefreshClick(Sender: TObject);
    procedure BTapplyClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure TabPortCfgShow(Sender: TObject);
    procedure lstPortCompare(Sender: TObject; Item1, Item2: TListItem;
      Data: Integer; var Compare: Integer);
    procedure lstPortColumnClick(Sender: TObject; Column: TListColumn);
    procedure lstPortSelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure TabLogShow(Sender: TObject);
    procedure btLDelAllClick(Sender: TObject);
    procedure btlRefreshClick(Sender: TObject);
    procedure TabQueueShow(Sender: TObject);
    procedure btQDelClick(Sender: TObject);
    procedure btQRefreshClick(Sender: TObject);
    procedure btPDelClick(Sender: TObject);
    procedure edtPortnameChange(Sender: TObject);
    procedure btPAddClick(Sender: TObject);
    procedure cmbProtocolChange(Sender: TObject);
    procedure cmbEncodeChange(Sender: TObject);
    procedure btpRefreshClick(Sender: TObject);
    procedure BindCmb;
    Procedure WinFocus(var msg:Tmessage);Message WM_ACTIVATE;
//    Procedure DataChange(var msg:Tmessage);Message WM_SETTINGCHANGE;
  private
    { Private declarations }
     reg:Tregistry;
     regval:TRegVal;
     message0:string;
  public
    { Public declarations }
  end;

var
  frmcfg: Tfrmcfg;

implementation

{$R *.dfm}

procedure Tfrmcfg.TabChannelCfgShow(Sender: TObject);
var ADOOBJ,recd:OleVariant;
    NullTest:Variant;
    itmp,irun:integer;
   // item:TComboExItem;
begin
  if TabChannelCfg.Tag =1 then exit else TabChannelCfg.Tag:=1;
  with  grdChannel do
  begin
    ColWidths[0]:=30;
    ColWidths[1]:=75;
    ColWidths[2]:=85;
    ColWidths[3]:=85;
    ColWidths[4]:=85;
    ColWidths[5]:=120;
    ADOOBJ:=CreateOleObject('ADODB.Connection');
    recd:=CreateOleObject('adodb.recordset');
    ADOOBJ.Open(regval.ConfigDB);
  {recd.open('select pro.type as type, pot.portname as name,pot.id from port pot,protocol pro where pot.protocol=pro.id',adoobj,1);
  cmbsource.Clear;
  cmbtarget.Clear;
  item:=cmbtarget.ItemsEx.Add;
  item.Caption:='None';
  item.ImageIndex:=-1;
  while not recd.eof do  //bind portname to cmbsource、cmbtarget
  begin
    NullTest:=recd.Fields['type'].value;
    if VarType(NullTest)<>varNull then itmp:=NullTest else itmp:=0;
    if itmp=0 then item:=cmbsource.ItemsEx.Add else item:=cmbtarget.ItemsEx.Add;
    NullTest:=recd.Fields['ID'].value;
    if VarType(NullTest)<>varNull then itmp:=NullTest;
    NullTest:=recd.Fields['name'].value;
    if VarType(NullTest)=varNull then NullTest:='port'+inttostr(itmp);
    item.Caption:=NullTest;
    item.ImageIndex:=itmp;
    recd.movenext;
  end;
  recd.close;}
     bindcmb;



//  recd.open('select p.portname as source,po.portname as target ,pi.portname as reply ,c.id as id,c.channelname as channel,c.Description  from port p,port po,port pi,channel c where c.sourceport=p.ID and c.targetport=po.ID and c.replyport=pi.ID',adoobj,1);
    recd.open('select * from channel',adoobj,1);


    itmp:=recd.recordcount;
    if itmp=0 then RowCount:=2 else RowCount:=itmp+1;
//    if itmp=0 then itmp :=2 else itmp:=itmp+1;
//    RowCount:=itmp;

    Rows[1].Clear;
    itmp:=1;
    while not recd.eof do
    begin

      NullTest:=recd.Fields['ID'].value;
      if VarType(NullTest)<>varNull then Cells[0,itmp]:=NullTest;

      NullTest:=recd.Fields['channelName'].value;
      if VarType(NullTest) <>varNull then Cells[1,itmp]:=NullTest else Cells[0,itmp]:='channel'+inttostr(itmp);

      NullTest:=recd.Fields['sourcePort'].value;
      if VarType(NullTest)<>varNull then
      begin
         for irun:=0 to cmbsource.Items.Count-1  do
         if cmbsource.ItemsEx[irun].ImageIndex=NullTest then
         begin
           Cells[2,itmp]:=cmbsource.Items[irun];
           break;
         end;
      end;
      NullTest:=recd.Fields['targetPort'].value;
      if VarType(NullTest)<>varNull then
      begin
         for irun:=0 to cmbtarget.Items.Count-1 do
         if cmbtarget.ItemsEx[irun].ImageIndex=NullTest then
         begin
           Cells[3,itmp]:=cmbtarget.Items[irun];
           break;
         end;
      end;


      NullTest:=recd.Fields['replyPort'].value;
      if VarType(NullTest)<>varNull then
      begin
         for irun:=0 to cmbtarget.Items.Count-1 do
         if cmbtarget.ItemsEx[irun].ImageIndex=NullTest then
         begin
           Cells[4,itmp]:=cmbtarget.Items[irun];
           break;
         end;
      end;

      NullTest:=recd.Fields['Description'].value;
      if VarType(NullTest)<>varNull then Cells[5,itmp]:=NullTest;

      recd.movenext;
      itmp:=itmp+1;
    end;
    recd.close;
    ADOOBJ.Close;
    recd:=Unassigned;
    ADOOBJ:=Unassigned;
  end;
end;

procedure Tfrmcfg.FormShow(Sender: TObject);
var itmp:integer; stmp,CurrentDir:string;strResult:pchar;
begin

  CurrentDir:=ExtractFilePath(ParamStr(2));
//  CurrentDir:=GetCurrentDir;

  if CurrentDir[length(CurrentDir)]<>'\' then CurrentDir:=CurrentDir+'\DPConfig.ini' else CurrentDir:=CurrentDir+'DPConfig.ini';
  strResult:=strAlloc(256);
  GetPrivateProfileString(pchar(cmblanguage.Text),'Title','Language File Missing',strResult,255,pchar(CurrentDir));
  caption:=strResult;
  for itmp:=0 to self.ComponentCount  -1 do
  begin
     stmp:=self.Components[itmp].name;
     GetPrivateProfileString(pchar(cmblanguage.Text),pchar(stmp),'nil',strResult,255,pchar(CurrentDir));
     if strResult<>'nil' then Tcontrol(self.Components[itmp]).SetTextBuf(strResult);
  end;
  for itmp:=0 to 5 do
  begin
    GetPrivateProfileString(pchar(cmblanguage.Text),pchar('grdChannel.Cell'+inttostr(itmp)),'nil',strResult,255,pchar(CurrentDir));
    if strResult<>'nil' then grdChannel.Cells[itmp,0]:=strResult;
  end;
  for itmp:=0 to 2 do
  begin
    GetPrivateProfileString(pchar(cmblanguage.Text),pchar('lstport.Col'+inttostr(itmp)),'nil',strResult,255,pchar(CurrentDir));
    if strResult<>'nil' then lstport.Columns[itmp].Caption:=strResult;
  end;
  for itmp:=0 to 6 do
  begin
    GetPrivateProfileString(pchar(cmblanguage.Text),pchar('lstLog.Col'+inttostr(itmp)),'nil',strResult,255,pchar(CurrentDir));
    if strResult<>'nil' then lstLog.Columns[itmp].Caption:=strResult;
  end;
    for itmp:=0 to 4 do
  begin
    GetPrivateProfileString(pchar(cmblanguage.Text),pchar('lstQueue.Col'+inttostr(itmp)),'nil',strResult,255,pchar(CurrentDir));
    if strResult<>'nil' then lstQueue.Columns[itmp].Caption:=strResult;
  end;
  GetPrivateProfileString(pchar(cmblanguage.Text),'message0','nil',strResult,255,pchar(CurrentDir));
  if strResult<>'nil' then message0:=strResult;

  StrDispose(strResult);
end;

procedure Tfrmcfg.BTcancelClick(Sender: TObject);
begin
application.Terminate;
end;

procedure Tfrmcfg.BTokClick(Sender: TObject);
begin
  BTapplyClick(sender);
  BTcancelClick(sender);
end;

procedure Tfrmcfg.cmbSourceChange(Sender: TObject);
var stmp:string;itmp:integer;
begin
  stmp:=TComboBoxEx(sender).Items[TComboBoxEx(sender).ItemIndex];
  if grdChannel.Col=2 then
  begin
    if stmp<>'None' then
    begin
      for itmp:=1 to grdChannel.RowCount-1 do
      begin
        if grdChannel.Cells[2,itmp]=stmp then
        begin
          messagebox(handle,pchar(message0),pchar(self.Caption),MB_OK+16);
          stmp:=grdChannel.Hint;
          break;
        end;
      end;
    end;
  end;
  grdChannel.Cells[grdChannel.Col,grdChannel.Row]:=stmp;
  grdChannel.SetFocus;
  TComboBoxEx(Sender).Visible:=false;
end;

procedure Tfrmcfg.cmbSourceExit(Sender: TObject);
begin
  if grdChannel.Cells[grdChannel.Col,grdChannel.Row]='' then grdChannel.Cells[grdChannel.Col,grdChannel.Row]:=grdChannel.Hint;
  if pagecontrol1.TabIndex=1 then grdChannel.SetFocus;
  TComboBoxEx(Sender).Visible:=false;
end;

procedure Tfrmcfg.grdChannelGetEditText(Sender: TObject; ACol, ARow: Integer;
  var Value: String);
var po:TRect;
    cmb:^TComboBoxEx;
begin
  if (ACol>1) and (ACol<5) then
  begin
    case  ACol of
    2:  cmb:=@cmbSource;
    3,4:cmb:=@cmbtarget;
    end;
    Po:=grdChannel.CellRect (acol,arow);
    cmb^.Left:=po.Left+grdChannel.Left ;
    cmb^.Top:=po.Top+grdChannel.Top;
    cmb^.Width:=po.Right-po.Left;
    cmb^.Visible:=true;
    cmb.ItemIndex:=cmb.Items.IndexOf(grdChannel.Cells[acol,arow]);
    SendMessage(cmb^.Handle,CB_SHOWDROPDOWN,1,0);