unit1.pas

通过ODBC/ADO等方式进行数据库连接及数据导入源码

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Grids, DB, DBTables, StdCtrls, Buttons, ComCtrls, ToolWin, ExtCtrls, Menus;
type R2string = record
    s: string;
    t: string;
  end;

type
  Tfrmsjdr = class(TForm)
    stb: TStatusBar;
    ControlBar1: TControlBar;
    ToolBar1: TToolBar;
    tsrc: TTable;
    tto: TTable;
    Panel2: TPanel;
    BitBtn1: TBitBtn;
    ed_tname: TEdit;
    odlg: TOpenDialog;
    ToolButton1: TToolButton;
    Panel1: TPanel;
    SpeedButton1: TSpeedButton;
    SpeedButton3: TSpeedButton;
    Label1: TLabel;
    SpeedButton2: TSpeedButton;
    SpeedButton4: TSpeedButton;
    GroupBox1: TGroupBox;
    lb_to: TListBox;
    GroupBox2: TGroupBox;
    lb_src: TListBox;
    GroupBox3: TGroupBox;
    lb_gx: TListBox;
    CB_aliasn: TComboBox;
    Label2: TLabel;
    cb_sjbn: TComboBox;
    TemDATA: TDatabase;
    GroupBox4: TGroupBox;
    ed_username: TEdit;
    ed_psw: TEdit;
    BitBtn2: TBitBtn;
    Label3: TLabel;
    Label4: TLabel;
    procedure doadd;
    procedure dofetch;
    procedure dobyname;
//    procedure doclear;
    procedure dodatain;
    procedure BitBtn1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure CB_aliasnChange(Sender: TObject);
    procedure update_lb_to;
    procedure update_lb_src;
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton4Click(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
    procedure ToolButton1Click(Sender: TObject);
    function getst(i: integer): R2string;
    procedure SpeedButton2Click(Sender: TObject);
    procedure cb_sjbnChange(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
  private
    { Private declarations }
  public
    strpath: string; { Public declarations }
  end;

var
  frmsjdr: Tfrmsjdr;

implementation

{$R *.dfm}

procedure Tfrmsjdr.BitBtn1Click(Sender: TObject);
begin
  odlg.InitialDir := strpath;
  if odlg.Execute then
    if odlg.FileName <> '' then
    begin
      ed_tname.text := odlg.FileName;
      try
        tsrc.Active := false;
        tsrc.TableName := ed_tname.Text;
        tsrc.Active := true;
        update_lb_src;
      except
      end;
    end;
end;

procedure Tfrmsjdr.FormCreate(Sender: TObject);
var temlist: TsTringlist;
begin
  strpath := extractfilepath(application.ExeName);
  temlist := Tstringlist.Create;
  cb_sjbn.Clear;
  Session.GetAliasNames(temlist);
  cb_aliasn.items := temlist;
  temlist.Free;
end;

procedure Tfrmsjdr.CB_aliasnChange(Sender: TObject);
var temlist: TsTringlist;
begin
 if trim(cb_aliasn.Text)='' then exit;
  temdata.Connected :=false;
  temdata.LoginPrompt :=true;
  temdata.AliasName :=trim(cb_aliasn.Text );
  temdata.DatabaseName :=trim(cb_aliasn.Text );
  temdata.Connected :=true;
  tto.DatabaseName :=temdata.AliasName;
  temlist := Tstringlist.Create;
  cb_sjbn.Clear;
  temdata.Session.GetTableNames(trim(cb_aliasn.Text), '', False, False, temlist);
  cb_sjbn.items := temlist;
  temlist.Free;
end;

procedure Tfrmsjdr.update_lb_to;
var i: integer;
begin
  if not tto.Active then exit;
  lb_to.Clear;
  for i := 0 to tto.FieldDefs.Count - 1 do
  begin
    lb_to.Items.Add(AnsiUpperCase(tto.FieldDefs[i].Name));
  end;
end;

procedure Tfrmsjdr.update_lb_src;
var i: integer;
begin
  if not tsrc.Active then exit;
  lb_src.Clear;
  for i := 0 to tsrc.FieldDefs.Count - 1 do
  begin
    lb_src.Items.Add(AnsiUpperCase(tsrc.FieldDefs[i].Name));
  end;
end;

procedure Tfrmsjdr.SpeedButton1Click(Sender: TObject);
begin
  doadd;
end;

procedure Tfrmsjdr.doadd;
var temstr: string;
begin
//  增加

  try
    temstr := format('%6s|%s', [lb_to.items[lb_to.itemindex], lb_src.items[lb_src.itemindex]]);
    lb_gx.Items.Add(temstr);
    lb_to.Items.Delete(lb_to.ItemIndex);
//    lb_src.Items.Delete(lb_src.ItemIndex);
  except
  end;
end;

procedure Tfrmsjdr.dobyname;
var i, j: integer;
  arr_i: array[0..100] of string;
begin
//
  j := 0;
  for i := 0 to lb_to.Items.Count - 1 do
  begin
    if lb_src.Items.IndexOf(lb_to.Items[i]) <> -1 then
    begin
      arr_i[j] := lb_to.Items[i];
      inc(j);
    end;
  end;
  for i := 0 to j - 1 do
  begin
    lb_gx.Items.Add(format('%6s|%s', [arr_i[i], arr_i[i]]));
    lb_to.Items.Delete(lb_to.Items.IndexOf(arr_i[i]));
  end;

end;

procedure Tfrmsjdr.dofetch;
var temR2: R2string;
begin
//取回
  try
    temr2 := getst(lb_gx.ItemIndex);
    lb_to.Items.Add(temr2.s);
    lb_gx.Items.Delete(lb_gx.ItemIndex);
  except
  end;
end;

procedure Tfrmsjdr.SpeedButton4Click(Sender: TObject);
begin
  dofetch;
end;

procedure Tfrmsjdr.SpeedButton3Click(Sender: TObject);
begin
  update_lb_to;
  lb_gx.Clear;
  dobyname;
end;

procedure Tfrmsjdr.ToolButton1Click(Sender: TObject);
begin
  dodatain;
end;

procedure Tfrmsjdr.dodatain;
var i: integer;
var psb: TProgressBar;
begin
//开始导入数据
 if (not tto.Active) or (not tsrc.Active) then exit;
  try
    psb := TProgressBar.Create(application);
    psb.Parent := stb;
    psb.Height := 17;
    psb.Width :=300;
    psb.Top := 1;
    psb.Left := 1;
    psb.Max := tsrc.RecordCount;
    psb.Position := 1;
    tsrc.First;
    while not tsrc.Eof do
    begin
      tto.Append;
      for i := 0 to lb_gx.Items.Count - 1 do
      begin
        tto.FieldByName(getst(i).s).AsString := tsrc.fieldbyname(getst(i).t).AsString;
      end;
      tto.Post;
      tsrc.Next;
      psb.Position := psb.Position + 1;
    end;
  finally
    psb.Free;
  end;
end;

function Tfrmsjdr.getst(i: integer): R2string;
var temstr: string;
begin
//
  temstr := lb_gx.Items[i];
  result.s := trim(copy(temstr, 1, 6));
  result.t := trim(copy(temstr, 8, (strlen(pchar(temstr)) - 6)));
end;

procedure Tfrmsjdr.SpeedButton2Click(Sender: TObject);
begin
  update_lb_to;
  lb_gx.Clear;
end;

procedure Tfrmsjdr.cb_sjbnChange(Sender: TObject);
begin
 try
  tto.Active :=false;
  tto.DatabaseName :=trim(cb_aliasn.Text);
  tto.TableName :=trim(cb_sjbn.Text);
  tto.Active :=true;
  update_lb_to;
  except
  showmessage('竟然打不开');
  end;
end;

procedure Tfrmsjdr.BitBtn2Click(Sender: TObject);
var temlist: TsTringlist;
begin
 if trim(cb_aliasn.Text)='' then exit;
  temdata.Connected :=false;
  temdata.Params.Clear;
  temdata.Params.Add('USER NAME='+trim(ed_username.Text));
  temdata.Params.Add('PASSWORD='+trim(ed_psw.Text ));
  temdata.LoginPrompt:=False;
  temdata.AliasName :=trim(cb_aliasn.Text );
  temdata.DatabaseName :=trim(cb_aliasn.Text );
  temdata.Connected :=true;

  temlist := Tstringlist.Create;
  cb_sjbn.Clear;
 temdata.Session.GetTableNames(trim(cb_aliasn.Text), '', False, False, temlist);
  cb_sjbn.items := temlist;
  temlist.Free;
end;

end.