u_web_user.pas

以前写的一个利用P2P 技术的一个通讯的例子。里面用到了 DBISAM 、INDY 控件。

unit U_WEB_USER;

interface

uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, ExtCtrls, Grids, Buttons, AdvGrid, TFlatComboBoxUnit,
   TFlatEditUnit, TFlatButtonUnit, BaseGrid;

type
   TF_WEB_USER = class(TForm)
      PN_FC: TPanel;
      Panel2: TPanel;
      LB_CODE: TLabel;
      LB_NAME: TLabel;
      LB_NAMEE: TLabel;
      LB_AREA: TLabel;
      SG_JL: TAdvStringGrid;
      ED_CODE: TFlatEdit;
      ED_NAME: TFlatEdit;
      ED_NAMEE: TFlatEdit;
      CB_AREA: TFlatComboBox;
      BN_BC: TFlatButton;
      BN_PRN: TFlatButton;
      BN_DEL: TFlatButton;
      bn_dw: TFlatButton;
      BN_BACK: TFlatButton;
      function saveroom(sender: TObject): boolean;
      procedure FormClose(Sender: TObject; var Action: TCloseAction);
      procedure FormCreate(Sender: TObject);
      procedure BN_BACKClick(Sender: TObject);
      procedure SG_JLDblClick(Sender: TObject);
      procedure FormKeyDown(Sender: TObject; var Key: Word;
         Shift: TShiftState);
      procedure BN_DELClick(Sender: TObject);
      procedure BN_BCClick(Sender: TObject);
      procedure ED_CODEExit(Sender: TObject);
      procedure BN_PRNClick(Sender: TObject);
      procedure FormActivate(Sender: TObject);
      procedure ED_CODEKeyPress(Sender: TObject; var Key: Char);
      procedure CB_AREAExit(Sender: TObject);
      procedure bn_dwClick(Sender: TObject);
      procedure SG_JLGetCellColor(Sender: TObject; ARow, ACol: Integer;
         AState: TGridDrawState; ABrush: TBrush; AFont: TFont);
      procedure ED_NAMEExit(Sender: TObject);
      procedure SG_JLGetAlignment(Sender: TObject; ARow, ACol: Integer;
         var HAlign: TAlignment; var VAlign: TVAlignment);
   private
      { Private declarations }
   public
      { Public declarations }
   end;

var
   F_WEB_USER: TF_WEB_USER;

implementation
uses Pub_program, U_WEB_DM, U_WEB_GRIDPRN; //, U_WEB_DM_WY;
var
   m_bcolor: boolean;
   updrow, arow, m_diff: integer;
   {$R *.DFM}

procedure TF_WEB_USER.FormClose(Sender: TObject;
   var Action: TCloseAction);
begin
   action := cafree;
end;

procedure TF_WEB_USER.FormCreate(Sender: TObject);
var
   s: string;
   i: integer;
begin
   clearall(sender);
   updrow := -1;
   m_diff := g_diff;
   case m_diff of
      0:
         begin
            lb_code.Caption := iif(m_lang = 1, '编  码', 'CODE');
            lb_area.Caption := iif(m_lang = 1, '国籍区域', 'NATION');
            Caption := iif(m_lang = 1, '国籍/籍贯编码设置', 'NATION CODE SETTING');
            case m_lang of
               1: s := '编码*10*中文名称*32*英文名称*36*所属区域*20*数据状态*16*rec_flag*0*code_o*0*';
               2: s := 'CODE*10*NAME*32*E.NAME*36*AREA*20*DATA STS*16*rec_flag*0*code_o*0*';
            end;
         end;
      1:
         begin
            lb_code.Caption := iif(m_lang = 1, '编  码', 'CODE');
            lb_area.Caption := iif(m_lang = 1, '预定类型', 'METHOD');
            Caption := iif(m_lang = 1, '预定方式编码设置', 'BOOK METHOD SETTING');
            case m_lang of
               1: s := '编码*10*中文名称*32*英文名称*36*所属类型*20*数据状态*16*rec_flag*0*code_o*0*';
               2: s := 'CODE*10*NAME*32*E.NAME*36*TYPE*20*DATA STATUS*16*rec_flag*0*code_o*0*';
            end;
         end;
      2:
         begin
            lb_code.Caption := iif(m_lang = 1, '特服编码', 'CODE');
            lb_area.Caption := iif(m_lang = 1, '特服类型', 'TYPE');
            Caption := iif(m_lang = 1, '特服编码设置', 'SP.ENQ CODE SETTING');
            case m_lang of
               1: s := '编码*10*中文名称*32*英文名称*36*所属类型*20*数据状态*16*rec_flag*0*code_o*0*';
               2: s := 'CODE*10*NAME*32*E.NAME*36*TYPE*20*DATA STATUS*16*rec_flag*0*code_o*0*';
            end;
         end;
      3:
         begin
            lb_code.Caption := iif(m_lang = 1, '客源编码', 'CODE');
            lb_area.Caption := iif(m_lang = 1, '所属客源', 'TYPE');
            Caption := iif(m_lang = 1, '客人来源编码设置', 'GUEST SOURCE SETTING');
            case m_lang of
               1: s := '编码*10*中文名称*32*英文名称*36*所属客源*20*数据状态*16*rec_flag*0*code_o*0*';
               2: s := 'CODE*10*NAME*32*E.NAME*36*TYPE*20*DATA STATUS*16*rec_flag*0*code_o*0*';
            end;
         end;
      4:
         begin
            lb_code.Caption := iif(m_lang = 1, '编  码', 'CODE');
            lb_area.Caption := iif(m_lang = 1, '所属大类', 'TYPE');
            Caption := iif(m_lang = 1, '折扣类型大类设置', 'DISCOUNT TYPE SETTING');
            case m_lang of
               1: s := '编码*10*中文名称*32*英文名称*36*所属客源*20*数据状态*16*rec_flag*0*code_o*0*';
               2: s := 'CODE*10*NAME*32*E.NAME*36*TYPE*20*DATA STATUS*16*rec_flag*0*code_o*0*';
            end;
            //ed_name.ReadOnly := true;
            //ed_namee.ReadOnly := true;
            ed_code.ReadOnly := true;
            bn_del.Visible := false;
         end;
   end;
   title_sg_wy(sg_jl, s, false);
   cb_area.Clear;
   with f_web_dm.qy_wangy do
      begin
         close;
         sql.clear;
         case m_diff of
            0: sql.add('select area,name from gst_area order by area'); // ,idx
            1: sql.add('select area=code,name from rsv_method order by code'); // ,idx
            2: sql.add('select area=svrno,name from svr_type order by svrno'); // ,idx
            3: sql.add('select area=mktno,name from mkt_type order by mktno'); // ,idx
            4: sql.add('select area=code,name from dclass order by code'); // ,idx
         end;
         open;
         while not eof do
            begin
               s := fieldbyname('area').asstring + ' - ' + fieldbyname('name').asstring; // ' - ' + fieldbyname('idx').asstring +
               cb_area.Items.Add(s);
               next;
            end;
         close;
         sql.clear;
         case m_diff of
            0: sql.add('select code,name,nation,area from nation order by area,code'); // ,idx
            1: sql.add('select code,name,namee,method from rsv_type order by method,code'); // ,idx
            2: sql.add('select svrcode,name,namee,svrgrp from svrcode order by svrgrp,svrcode'); // ,idx
            3: sql.add('select code,name,namee,mktno from mkt_no order by mktno,code'); // ,idx
            4: sql.add('select dtype,name,namee,dclass from dtype order by dtype,dclass'); // ,idx
         end;
         open;
         with sg_jl do
            while not eof do
               begin
                  str_grid_wy(sg_jl, arow);
                  for i := 0 to colcount - 4 do
                     case i of
                        3:
                           begin
                              cb_area.ItemIndex := -1;
                              cb_area.Text := fields.fields[i].asstring;
                              analy_com_wy(cb_area, true);
                              cells[i, arow] := cb_area.Text;
                              cb_area.ItemIndex := -1;
                           end;
                        else
                           cells[i, arow] := fields.fields[i].asstring;
                     end;
                  cells[colcount - 1, arow] := fields.fields[0].asstring;
                  cells[colcount - 2, arow] := 'normal';
                  next;
               end;
         close;
         bztomc_wy(sg_jl, sg_jl.colcount - 2, sg_jl.colcount - 3);
      end;
end;

procedure TF_WEB_USER.BN_BACKClick(Sender: TObject);
begin
   if not noedit_sg(sg_jl, sg_jl.ColCount - 2) then
      if MessageDlg(asksave_msg, mtConfirmation, [mbyes, mbno], 0) = mrno then
         exit;
   close;
end;

procedure TF_WEB_USER.SG_JLDblClick(Sender: TObject);
begin
   with sg_jl do
      begin
         if (row = 0) then
            exit;
         if not check_sg(sg_jl, row, true) then
            exit;
         updrow := row;
         ed_code.Text := cells[0, row];
         ed_name.Text := cells[1, row];
         ed_namee.Text := cells[2, row];
         cb_area.Text := cells[3, row];
         sortSettings.show := false;
      end;
   bn_del.Enabled := true;
   //case m_diff of
   //   4: cb_area.SetFocus;
   //   else
   ed_name.SetFocus;
   //end;
end;

procedure TF_WEB_USER.FormKeyDown(Sender: TObject; var Key: Word;
   Shift: TShiftState);
begin
   case Key of
      VK_RETURN, VK_DOWN:
         Perform(WM_NEXTDLGCTL, 0, 0);
      VK_UP:
         Perform(WM_NEXTDLGCTL, 1, 0);
      VK_Escape: close;
      VK_F2:
         if bn_bc.Enabled then
            bn_bcclick(sender);
      VK_F3:
         if bn_prn.Enabled then
            bn_prnclick(sender);
      VK_F4:
         if bn_del.Enabled then
            bn_delclick(sender);
      VK_F8:
         if bn_dw.Enabled then
            bn_dwclick(sender);
   end;
end;

procedure TF_WEB_USER.BN_DELClick(Sender: TObject);
begin
   del_sg_wy(sg_jl, updrow, sg_jl.ColCount - 2, sg_jl.ColCount - 3);
   bn_del.Enabled := false;
   clearpn_wy(pn_fc, true);
end;

function TF_WEB_USER.saveroom(sender: TObject): boolean;
var
   i: integer;
   s: string;
begin
   {try //此过程只将所有STRING-GRID 中的数据存入数据库。
      f_reca_dm.hoteldb.Connected := true;
      f_reca_dm.hoteldb.StartTransaction;
      {with f_reca_dm_wy2.sp_bcnation_wangy do
         begin
            close;
            with sg_jl do
               for i := 1 to rowcount - 1 do
                  begin
                     s := cells[colcount - 2, i];
                     if (s = 'normal') or (s = '') then
                        continue;
                     parambyname('@ventry').asinteger := m_diff;
                     parambyname('@vcode').asstring := cells[0, i];
                     parambyname('@vname').asstring := cells[1, i];
                     parambyname('@vnation').asstring := cells[2, i];
                     parambyname('@varea').asinteger := strtoint(getpartstr(cells[3, i]));
                     parambyname('@vcode_o').asstring := cells[colcount - 1, i];
                     parambyname('@vflag').asstring := cells[colcount - 2, i];
                     prepare;
                     execproc;
                  end;
            close;
         end;
      f_reca_dm.hoteldb.Commit;
      result := true;
      if sender = BN_BC then
         MessageDlg(succ_msg, mtinformation, [mbok], 0);
   except
      f_reca_dm.hoteldb.Rollback;
      MessageDlg(err_msg, mtWarning, [mbok], 0);
      result := false;
   end;}
end;

procedure TF_WEB_USER.BN_BCClick(Sender: TObject);
begin
   if saveroom(bn_bc) then
      after_save_wy(sg_jl, true, sg_jl.ColCount - 2, sg_jl.ColCount - 3);
   bn_del.Enabled := false;
end;

procedure TF_WEB_USER.ED_CODEExit(Sender: TObject);
begin
   (sender as TFlatEdit).Text := uppercase_wy((sender as TFlatEdit).Text);
end;

procedure TF_WEB_USER.BN_PRNClick(Sender: TObject);
begin
   tran_str := 'caption:' + caption + '*colcount:' + inttostr(lastcol_sg(sg_jl)) + '*rowcount:' + inttostr(sg_jl.rowcount) + '*';
   F_WEB_GRIDPRN := TF_WEB_GRIDPRN.Create(self);
   F_WEB_GRIDPRN.colselecth(sg_jl);
   F_WEB_GRIDPRN.only_length;
   F_WEB_GRIDPRN.Showmodal;
end;

procedure TF_WEB_USER.FormActivate(Sender: TObject);
begin
   if windowstate <> wsMaximized then
      windowstate := wsMaximized;
end;

procedure TF_WEB_USER.ED_CODEKeyPress(Sender: TObject; var Key: Char);
begin
   case m_diff of
      0, 1, 3:
         key := only_chr(key);
      2:
         key := only_num(key);
   end;
end;

procedure TF_WEB_USER.CB_AREAExit(Sender: TObject);
begin
   if (ed_code.Text = '') then
      begin
         MessageDlg(lb_code.Caption + null_msg, mtinformation, [mbok], 0);
         ed_code.SetFocus;
         exit;
      end;
   if (trim(ed_name.text) = '') then
      begin
         MessageDlg(lb_name.Caption + null_msg, mtinformation, [mbok], 0);
         ed_name.SetFocus;
         exit;
      end;
   if (trim(ed_namee.text) = '') then
      begin
         MessageDlg(lb_namee.Caption + null_msg, mtinformation, [mbok], 0);
         ed_namee.SetFocus;
         exit;
      end;
   analy_com_wy(cb_area, true);
   {if (trim(cb_area.text) = '') then
      begin
         MessageDlg(lb_area.Caption + null_msg, mtinformation, [mbok], 0);
         cb_area.SetFocus;
         exit;
      end;}
   with sg_jl do
      begin
         if updrow <> -1 then
            begin
               arow := updrow;
               updrow := -1;
               if cells[colcount - 2, arow] <> 'add' then
                  cells[colcount - 2, arow] := 'modify';

            end
         else
            begin
               if m_diff = 4 then
                  exit;
               str_grid_wy(sg_jl, arow);
               cells[colcount - 2, arow] := 'add';
            end;
         cells[0, arow] := trim(ed_code.Text);
         cells[1, arow] := trim(ed_name.Text);
         cells[2, arow] := trim(ed_namee.Text);
         cells[3, arow] := trim(cb_area.Text);
         bztomc_wy(sg_jl, colcount - 2, colcount - 3);
         sortSettings.show := true;
      end;
   clearpn_wy(pn_fc, true);
   ed_code.SetFocus;
   bn_del.enabled := false;
end;

procedure TF_WEB_USER.bn_dwClick(Sender: TObject);
begin
   m_bcolor := false;
   sg_locate_wy(sg_jl, sg_jl.colcount + 8);
   m_bcolor := true;
   sg_jl.Repaint;
end;

procedure TF_WEB_USER.SG_JLGetCellColor(Sender: TObject; ARow,
   ACol: Integer; AState: TGridDrawState; ABrush: TBrush; AFont: TFont);
var
   i: integer;
begin
   if arow = 0 then
      exit;
   if not m_bcolor then
      exit;
   with sg_jl do
      begin
         ABrush.color := clwhite;
         i := strtoint(getstr(cells[colcount + 8, arow]));
         if i = 1 then
            ABrush.color := clInfoBk; //clyellow;
      end;
end;

procedure TF_WEB_USER.ED_NAMEExit(Sender: TObject);
begin
   (sender as TFlatEdit).Text := uppercase_wy((sender as TFlatEdit).Text);
end;

procedure TF_WEB_USER.SG_JLGetAlignment(Sender: TObject; ARow,
   ACol: Integer; var HAlign: TAlignment; var VAlign: TVAlignment);
begin
   case arow of
      0: HAlign := tacenter;
   end;
end;

end.