zbsunit.pas

本系统在一些大中型企业(跨多达24个区域)一直都在很好的服务过

unit zbsunit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ComCtrls, lmdctrl, lmdstdcS, ExtCtrls, tcpip;

type
  Tzbsform = class(TForm)
    StatusBar1: TStatusBar;
    Panel1: TPanel;
    Image1: TImage;
    LMDSimpleLabel2: TLMDSimpleLabel;
    LMDSimpleLabel1: TLMDSimpleLabel;
    Edit1: TEdit;
    DateTimePicker1: TDateTimePicker;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    LMDSimpleLabel3: TLMDSimpleLabel;
    Image2: TImage;
    Image3: TImage;
    edit2: TEdit;
    FTP: T_FTP;
    LMDSimpleLabel4: TLMDSimpleLabel;
    Edit3: TEdit;
    restory: TMemo;
    Image4: TImage;
    Panel2: TPanel;
    Image5: TImage;
    Bevel1: TBevel;
    procedure FormActivate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure DateTimePicker1Change(Sender: TObject);
    procedure edit2Change(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
      procedure ftp_data(Sender:TObject; mode: t_ftp_mode; data:integer);
    procedure FTPTrace(const s: String; level: TTraceLevel);
    procedure Edit3Change(Sender: TObject);
    procedure Edit3Enter(Sender: TObject);
  private
     function makescreat(s:string) :string;
   function showscreat(s:string) :string;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  zbsform: Tzbsform;

implementation

uses REMain1, sendUnit, ipdress, newunit;

{$R *.DFM}
 var
 uploadsize:integer;
 size:word;
 downloadfile:boolean;
 y:word;
m:word;
d:word;
Fdate:Tdatetime;
zy:word;
zm:word;
zd:word;

procedure Tzbsform.FormActivate(Sender: TObject);
begin
edit3.Text:=restory.Lines.Text;
BitBtn1.Enabled:=true;
mainform.enabled:=false;
edit3Change(nil);
StatusBar1.Panels[1].text:='';

end;

procedure Tzbsform.FormClose(Sender: TObject; var Action: TCloseAction);
begin
mainform.enabled:=true;
 screen.Cursor:=crdefault;
end;





procedure Tzbsform.FormCreate(Sender: TObject);
begin
DateTimePicker1.date:=Date;
DecodeDate(date,zy,zm,zd);
if fileexists('c:\newstar\save\story\Z'+inttostr(zy)+inttostr(zm)+inttostr(zd)+'.dat') then
    begin
     restory.Lines.Clear;
     restory.Lines.LoadFromFile('c:\newstar\save\story\Z'+inttostr(zy)+inttostr(zm)+inttostr(zd)+'.dat');
    end else
    begin
     restory.Lines.Clear;
     restory.Lines.Text:='0';
     restory.Lines.SaveToFile('c:\newstar\save\story\Z'+inttostr(zy)+inttostr(zm)+inttostr(zd)+'.dat');
    end;
end;

procedure Tzbsform.BitBtn2Click(Sender: TObject);
begin
CLOSE;
end;




procedure Tzbsform.DateTimePicker1Change(Sender: TObject);
begin
Fdate:=DateTimePicker1.date;
DecodeDate(fdate,y,m,d);

DecodeDate(fdate,zy,zm,zd);
if fileexists('c:\newstar\save\story\Z'+inttostr(zy)+inttostr(zm)+inttostr(zd)+'.dat') then
    begin
     restory.Lines.Clear;
     restory.Lines.LoadFromFile('c:\newstar\save\story\Z'+inttostr(zy)+inttostr(zm)+inttostr(zd)+'.dat');

    end else
    begin
     restory.Lines.Clear;
     restory.Lines.Text:='0';
     restory.Lines.SaveToFile('c:\newstar\save\story\Z'+inttostr(zy)+inttostr(zm)+inttostr(zd)+'.dat');
    end;

       edit3.Text:=restory.Lines.Text;
       Edit1.Text:='ZB'+inttostr(y)+inttostr(m)+inttostr(d)+'-'+trim(edit3.text)+'.rdx';


end;

procedure Tzbsform.edit2Change(Sender: TObject);
begin

Fdate:=DateTimePicker1.date;
DecodeDate(fdate,y,m,d);
Edit1.Text:='ZB'+inttostr(y)+inttostr(m)+inttostr(d)+'-'+trim(edit3.text)+'.rdx';


end;

procedure Tzbsform.BitBtn1Click(Sender: TObject);
var
file1name:string;
ffilename:string;
begin

 if (edit1.Text<>'') and (edit2.Text='Sky2000') then
   begin
   end else
   begin
   showmessage('    系统检测到你录入的数据资料不正确,你将无法使用此功能,请重试!...');
   exit;
   end;

{===========================}

        with mainform do
                     begin

       {=============================}
    Archiver1.Close;
    deletefile(pchar('C:\Sky\tmp.tmp'));
    screen.Cursor:=crHourGlass;
    FFileName:='c:\sky\'+zbsform.edit1.text;
    Editor.Lines.SaveToFile('C:\Sky\tmp.tmp');
    Editor.Modified := False;
     if fileexists(FFileName) then
       deletefile(pchar(FFileName));

      with Archiver1 do
    begin
      FileName :=  FFileName   ;
      Archiver1.DeleteFiles;
      Open;
      try
       AddFile('C:\Sky\tmp.tmp');
         if fileexists('C:\Sky\tmp.tmp') then
          deletefile(pchar('C:\Sky\tmp.tmp'));
          screen.Cursor:=crDefault;
      finally
        Close;
      end;
    end;
{+====================}

      screen.Cursor:=crDefault;
{============================================================}

                        end;

       file1name:=FFileName ;
       BitBtn1.Enabled:=false;

         {===============ftp==========}

                           {FTP }
        ftp.hostname:=showscreat(trim(mainform.hostsiteLabel.Caption));
        ftp.Password:=showscreat(trim(mainform.datpassLabel.Caption));
        ftp.Port:=21;
        ftp.Username:=showscreat(trim(mainform.datuserLabel.Caption));

        StatusBar1.Panels[1].text:=' 正在试图和服务器 '+ ftp.hostname+' 进行连接...';
        try
            ftp.login;
            ftp.getdir('.');
            ftp.changedir('dat');
            ftp.getdir('.');
        except

           StatusBar1.Panels[1].text:=' 登陆FTP服务器 '+ ftp.hostname+' 失败,请重试!!!...';

                 screen.Cursor:=crDefault;
           ftp.abort;
           ftp.logout;
                                         BitBtn1.Enabled:=true;

           exit;
        end;

        try



                          ftp.Mode:=tftp_upload;
                          ftp.uri:=extractfilename(file1name);
                          TMemorystream(ftp.stream).loadfromfile(file1name);
                          ftp.upload;
                          ftp.getdir('.');
                          ftp.abort;
                          ftp.logout;
                          {==========================================}
     restory.Lines.Text:=inttostr((strtoint(restory.Lines.Text)+1));
     restory.Lines.SaveToFile('c:\newstar\save\story\Z'+inttostr(zy)+inttostr(zm)+inttostr(zd)+'.dat');



                          {==========================================}
                     StatusBar1.Panels[1].text:=' 已经和数据服务器 '+ ftp.hostname+' 断开,数据全部处理完毕...';
                     screen.Cursor:=crdefault;

          except
                 screen.Cursor:=crDefault;
           ftp.abort;
           ftp.logout;
                                         BitBtn1.Enabled:=true;
                    StatusBar1.Panels[1].text:=' 发送数据时出现意外错误，请关闭程序重试!';
                    screen.Cursor:=crdefault;
           end;

         {=================ftpend;===========}

  ftp.abort;
  ftp.logout;

  close;

{===========================}
end;






procedure Tzbsform.FTPTrace(const s: String; level: TTraceLevel);
begin
if ftp.busy then
 begin
     screen.Cursor:=crDefault;
 end else
 begin

   screen.Cursor:=crHourGlass;

 end;
  case level of
    tt_proto_sent, tt_proto_get: begin

    if trim(s)<>'200 Type set to I.' then begin
    if ftp.mode=tftp_upload then begin
    StatusBar1.Panels[1].text:=' @NewStar正在发送数据....';

    end else
    begin
   StatusBar1.Panels[1].text:=' @NewStar 正在处理命令...: '+s;

    end;