ffrmfiletransfer.pas

代码齐全

///////////////////////////////////////////////////////////////
//		程序说明                                             //
//	程序员：胥小华                                           //
//	日  期：2000.7                                           //
//	版  本：V1.0                                             //
//	E-MAIL:[e-mail]                                   //
//  TEL:[phone]                                    //
//                                                           //
//	若您引用或对程序有什么好的改进,别忘了告诉我一声!         //
///////////////////////////////////////////////////////////////

unit FfrmFileTransfer;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, Menus, Psock, NMFtp, Gauges,Registry, ComCtrls,
  ExtCtrls, Db, DBTables, FileCtrl,inifiles, TrayIcon, CheckLst, MenuBar,
  ToolWin, NeoForm,ShellApi;

type
  TfrmFileTransfer =class(TzypNeoForm)
    ftp1: TNMFTP;
    dlgSave: TSaveDialog;
    dlgOpen: TOpenDialog;
    memPopupMenu: TPopupMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    Database1: TDatabase;
    qryCS: TQuery;
    Timer1: TTimer;
    mnTrayIcon: TPopupMenu;
    N4: TMenuItem;
    N5: TMenuItem;
    N6: TMenuItem;
    TrayIcon1: TTrayIcon;
    Timer2: TTimer;
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    Bevel1: TBevel;
    GroupBox5: TGroupBox;
    Label10: TLabel;
    Label11: TLabel;
    prgTransfer: TGauge;
    Label12: TLabel;
    Label13: TLabel;
    stxtMsg: TStaticText;
    stxtTotal: TStaticText;
    stxtRcv: TStaticText;
    BitBtn2: TBitBtn;
    btnUpLoad: TBitBtn;
    btnDownLoad: TBitBtn;
    btnDisconnect: TBitBtn;
    btnConnect: TBitBtn;
    BitBtn1: TBitBtn;
    GroupBox2: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    sbtnSave: TSpeedButton;
    edtDownSourseFile: TEdit;
    edtDownDestinationFile: TEdit;
    GroupBox3: TGroupBox;
    Label4: TLabel;
    Label8: TLabel;
    sbtnOpen: TSpeedButton;
    edtUpSourseFile: TEdit;
    edtUpDestinationFile: TEdit;
    memLog: TMemo;
    TabSheet2: TTabSheet;
    Bevel2: TBevel;
    GroupBox1: TGroupBox;
    Label3: TLabel;
    Label5: TLabel;
    edtHost: TEdit;
    edtPort: TEdit;
    GroupBox4: TGroupBox;
    Label6: TLabel;
    Label7: TLabel;
    edtUserID: TEdit;
    edtPassword: TEdit;
    GroupBox7: TGroupBox;
    chkSaveHost: TCheckBox;
    chkSaveUpload: TCheckBox;
    chkSaveUser: TCheckBox;
    chkSaveDownload: TCheckBox;
    GroupBox8: TGroupBox;
    chkOverwrite: TCheckBox;
    chkAutoReceive: TCheckBox;
    chkSendDelete: TCheckBox;
    chkAutoSend: TCheckBox;
    TabSheet3: TTabSheet;
    Bevel3: TBevel;
    prgCollection: TGauge;
    Label16: TLabel;
    Label17: TLabel;
    Image1: TImage;
    Label9: TLabel;
    Label19: TLabel;
    btnCollection: TBitBtn;
    slblCollectionMsg: TStaticText;
    Memo2: TMemo;
    clstSendTable: TCheckListBox;
    edtReceivePath: TEdit;
    TabSheet4: TTabSheet;
    Bevel4: TBevel;
    prgReceive: TGauge;
    Label15: TLabel;
    Label18: TLabel;
    Label14: TLabel;
    btnReceive: TBitBtn;
    slblReceiveMsg: TStaticText;
    memDataFile: TMemo;
    FileListBox1: TFileListBox;
    Memo1: TMemo;
    StaticText1: TStaticText;
    TabSheet5: TTabSheet;
    Bevel5: TBevel;
    Image2: TImage;
    Image3: TImage;
    BitBtn5: TBitBtn;
    BitBtn6: TBitBtn;
    BitBtn7: TBitBtn;
    BitBtn8: TBitBtn;
    memTransferLog: TMemo;
    slblLogMsg: TStaticText;
    btnOpenLink: TBitBtn;
    BitBtn3: TBitBtn;
	procedure btnConnectClick(Sender: TObject);
	procedure btnDisconnectClick(Sender: TObject);
	procedure btnDownLoadClick(Sender: TObject);
	procedure btnUpLoadClick(Sender: TObject);
	procedure ftp1Failure(var Handled: Boolean; Trans_Type: TCmdType);
	procedure ftp1UnSupportedFunction(Trans_Type: TCmdType);
	procedure ftp1Success(Trans_Type: TCmdType);
	procedure ftp1Connect(Sender: TObject);
	procedure ftp1ConnectionFailed(Sender: TObject);
	procedure ftp1Disconnect(Sender: TObject);
	procedure ftp1Error(Sender: TComponent; Errno: Word; Errmsg: String);
	procedure ftp1TransactionStart(Sender: TObject);
	procedure ftp1TransactionStop(Sender: TObject);
	procedure btnAboutClick(Sender: TObject);
	procedure BitBtn1Click(Sender: TObject);
	procedure ftp1PacketRecvd(Sender: TObject);
	procedure ftp1PacketSent(Sender: TObject);
	procedure sbtnSaveClick(Sender: TObject);
	procedure sbtnOpenClick(Sender: TObject);
	procedure FormCreate(Sender: TObject);
	procedure N1Click(Sender: TObject);
	procedure btnCollectionClick(Sender: TObject);
	procedure btnReceiveClick(Sender: TObject);
	procedure BitBtn6Click(Sender: TObject);
	procedure BitBtn8Click(Sender: TObject);
	procedure btnViewLog(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Image1Click(Sender: TObject);
    procedure TrayIcon1Click(Sender: TObject);
    procedure N4Click(Sender: TObject);
    procedure TrayIcon1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image2Click(Sender: TObject);
    procedure Image3DblClick(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);
    procedure btnOpenLinkClick(Sender: TObject);
  private
	{ Private declarations }
	function DataToFile(f,tn,fieldlist:String):Boolean;
	function FileToData(f,tn,fieldlist:String):Boolean;
	procedure SaveReg;
	procedure LoadSendTables;
	procedure SaveSendTables;
  public
	{ Public declarations }
  end;

var
  frmFileTransfer: TfrmFileTransfer;
  Overwrite,SendDelete:Boolean;

implementation

uses FBasFunction, Draw;

{$R *.DFM}

procedure WriteCollectionLog(l:String);
var
	LogCol:TextFile;
	AppDir:String;
begin
	AppDir:=ExtractFileDir(Application.ExeName);
	AssignFile(LogCol,AppDir+'\Log\Collection.log');
	if not fileexists(AppDir+'\Log\Collection.log') then Rewrite(LogCol) else Append(LogCol);
	Write(LogCol,FormatDateTime('yyyyy-mm-dd hh:mm',Now)+l+#13+#10);
	CloseFile(LogCol);
end;

procedure WriteReceiveLog(l:String);
var
	LogCol:TextFile;
	AppDir:String;
begin
	AppDir:=ExtractFileDir(Application.ExeName);
	AssignFile(LogCol,AppDir+'\Log\Receive.log');
	if not fileexists(AppDir+'\Log\Receive.log') then Rewrite(LogCol) else Append(LogCol);
	Write(LogCol,FormatDateTime('yyyyy-mm-dd hh:mm',Now)+l+#13+#10);
	CloseFile(LogCol);
end;

procedure TfrmFileTransfer.LoadSendTables;
var
	FreePrintIni:TIniFile;
	i:Integer;
	AppDir,sini,s:String;
begin
	AppDir:=ExtractFileDir(Application.ExeName);

	if not fileexists(AppDir+'\CSCollection.ini') then
	begin
		MessageBox(Handle,'未发现数据汇总设置文件(CSCollection.ini) !','提示信息',MB_ICONINFORMATION);
		exit;
	end;
	FreePrintIni := TIniFile.Create(AppDir+'\CSCollection.ini');
	clstSendTable.Clear ;
	sini:=FreePrintIni.ReadString('表名', '表名列表','表1');
	i:=1;
	while i<=Length(sini) do
	begin
		s:='';
		while sini[i]<>',' do
		begin
			s:=s+sini[i];
			i:=i+1;
			if i>Length(sini) then break;
		end;
		i:=i+1;
		clstSendTable.Items.Add(s);
	end;

	for i:=0 to clstSendTable.Items.Count -1 do
	begin
		if FreePrintIni.ReadString(clstSendTable.Items[i],'传输标志','1')='1' then
			clstSendTable.Checked[i]:=True;
	end;
	FreePrintIni.Free;
end;

procedure TfrmFileTransfer.SaveSendTables;
var
	FreePrintIni:TIniFile;
	i:Integer;
	AppDir:String;
begin
	AppDir:=ExtractFileDir(Application.ExeName);
	FreePrintIni := TIniFile.Create(AppDir+'\CSCollection.ini');
	for i:=0 to clstSendTable.Items.Count -1 do
		FreePrintIni.WriteString(clstSendTable.Items[i], '传输标志',IntToStr(Ord(clstSendTable.Checked[i])));
	FreePrintIni.Free;
end;

procedure TfrmFileTransfer.btnConnectClick(Sender: TObject);
begin
	 if (edtHost.Text='') or (edtPort.Text='') then
	 begin
		ShowMessage('请先填写服务器信息！');
		exit;
	 end;
	 ftp1.Host:=edthost.Text;
	 ftp1.Port:=StrToInt(edtPort.text);
     ftp1.UserID:=edtUserID.Text;
     ftp1.Password:=edtPassword.Text ;
	 try
		ftp1.Connect;
	 except
		begin
//			 Showmessage('连接发生错误！');
			 memLog.Lines.Add('连接发生错误！');
		end;
     end;
end;

procedure TfrmFileTransfer.btnDisconnectClick(Sender: TObject);
begin
  ftp1.Disconnect;
end;

procedure TfrmFileTransfer.btnDownLoadClick(Sender: TObject);
begin
     if (edtDownSourseFile.Text ='') or (edtDownDestinationFile.Text='') then
     begin
      ShowMessage('请先填写下载文件信息！');
	  exit;
	 end;
	 ftp1.Download(edtDownSourseFile.text,edtDownDestinationFile.text);

end;

procedure TfrmFileTransfer.SaveReg;
var
	Reg:TRegistry;
begin
	 reg:=TRegistry.Create;
	 if not Reg.OpenKey('\FTPFileTransfer',False) then
	 begin
		 Reg.CreateKey('\FTPFileTransfer');
		 Reg.CloseKey;
	 end;
	 Reg.OpenKey('\FTPFileTransfer',True);
	 Reg.WriteString('Host',edtHost.Text);
	 Reg.WriteString('Port',edtPort.Text);
	 Reg.WriteString('DownSourseFile',edtDownSourseFile.Text);
	 Reg.WriteString('DownDestinationFile',edtDownDestinationFile.Text);
	 Reg.WriteString('UpSourseFile',edtUpSourseFile.Text);
	 Reg.WriteString('UpDestinationFile',edtUpDestinationFile.Text);
	 Reg.WriteString('User',edtUserID.Text);
	 Reg.WriteString('Pwd',edtPassword.Text);
	 Reg.WriteString('SaveHost',IntToStr(Ord(chkSaveHost.Checked)));
	 Reg.WriteString('SaveUser',IntToStr(Ord(chkSaveUser.Checked)));
	 Reg.WriteString('SaveUpLoad',IntToStr(Ord(chkSaveUpLoad.Checked)));
	 Reg.WriteString('SaveDownload',IntToStr(Ord(chkSaveDownload.Checked)));

	 Reg.WriteString('Overwrite',IntToStr(Ord(chkOverwrite.Checked)));
	 Reg.WriteString('AutoReceive',IntToStr(Ord(chkAutoReceive.Checked)));
   Reg.WriteString('AutoSend',IntToStr(Ord(chkAutoSend.Checked)));
	 Reg.WriteString('SendDelete',IntToStr(Ord(chkSendDelete.Checked)));
	 Reg.WriteString('ReceivePath',edtReceivePath.Text);
	 Application.Terminate ;
end;

procedure TfrmFileTransfer.btnUpLoadClick(Sender: TObject);
begin
	 if (edtUpSourseFile.Text ='') or (edtUpDestinationFile.Text='') then
	 begin
	   ShowMessage('请先填写上载文件信息！');
	   exit;
	 end;
	 ftp1.Upload(edtUpSourseFile.text,edtUpDestinationFile.text);

end;

procedure TfrmFileTransfer.ftp1Failure(var Handled: Boolean;
  Trans_Type: TCmdType);
begin
       Case Trans_Type of
    cmdChangeDir: memLog.Lines.Add( '改变目录失败 !');
    cmdMakeDir: memLog.Lines.Add( '建立目录失败 !');
    cmdDelete: memLog.Lines.Add( '删除失败 !');
    cmdRemoveDir: memLog.Lines.Add( '删除目录失败 !');
    cmdList: memLog.Lines.Add( '列表失败 !');
    cmdRename: memLog.Lines.Add( '改名失败 !');
	cmdUpRestore: memLog.Lines.Add( '上载恢复失败 !');
    cmdDownRestore: memLog.Lines.Add( '正载恢复失败 !');
    cmdDownload: memLog.Lines.Add( '下载失败 !');
    cmdUpload: memLog.Lines.Add( '上载失败 !');
    cmdAppend: memLog.Lines.Add( '上载追加失败 !');
    cmdReInit: memLog.Lines.Add( '重新初始化失败 !');
    cmdAllocate: memLog.Lines.Add( '定位失败 !');
    cmdNList: memLog.Lines.Add( 'NList 失败 !');
    cmdDoCommand: memLog.Lines.Add( '执行命令失败 !');
  end;
end;

procedure TfrmFileTransfer.ftp1UnSupportedFunction(Trans_Type: TCmdType);
begin
  Case Trans_Type of
    cmdChangeDir: memLog.Lines.Add('改变目录不支持 !');
    cmdMakeDir: memLog.Lines.Add('建立目录不支持 !');
    cmdDelete: memLog.Lines.Add('删除不支持 !');
    cmdRemoveDir: memLog.Lines.Add('删除目录不支持 !');
    cmdList: memLog.Lines.Add('列表不支持 !');
    cmdRename: memLog.Lines.Add('改名不支持 !');
    cmdUpRestore: memLog.Lines.Add('上载恢复不支持 !');
    cmdDownRestore: memLog.Lines.Add('下载恢复不支持 !');
	cmdDownload: memLog.Lines.Add('下载不支持 !');
    cmdUpload: memLog.Lines.Add('上载不支持 !');
    cmdAppend: memLog.Lines.Add('上载追加不支持 !');
    cmdReInit: memLog.Lines.Add('重新初始化不支持 !');
    cmdAllocate: memLog.Lines.Add('定位不支持 !');
    cmdNList: memLog.Lines.Add('NList 不支持 !');
    cmdDoCommand: memLog.Lines.Add('执行命令不支持 !');
  end;
end;

procedure TfrmFileTransfer.ftp1Success(Trans_Type: TCmdType);
begin
  Case Trans_Type of
    cmdChangeDir: memLog.Lines.Add( '改变目录成功 !');
	cmdMakeDir: memLog.Lines.Add( '建立目录成功 !');
    cmdDelete: memLog.Lines.Add( '删除成功 !');
    cmdRemoveDir: memLog.Lines.Add( '删除目录成功 !');
    cmdList: memLog.Lines.Add( '列表成功 !');
    cmdRename: memLog.Lines.Add( '改名成功 !');
    cmdUpRestore: memLog.Lines.Add( '上载恢复成功 !');
    cmdDownRestore: memLog.Lines.Add( '下载恢复成功 !');
    cmdDownload:
        begin
		   //????
           //stxtRcv.Caption :=IntToStr(ftp1.BytesTotal);
           //prgTransfer.Progress :=ftp1.BytesTotal;
           stxtRcv.Caption :=stxtTotal.Caption ;
           prgTransfer.Progress :=StrToInt(stxtTotal.Caption);
           memLog.Lines.Add( '下载成功 !');
        end;
    cmdUpload:
        begin
           stxtRcv.Caption :=IntToStr(ftp1.BytesTotal);
           prgTransfer.Progress :=ftp1.BytesTotal;
           memLog.Lines.Add( '上载成功 !');
        end;
    cmdAppend: memLog.Lines.Add( '上载追加成功 !');
	cmdReInit: memLog.Lines.Add( '重新初始化成功 !');
    cmdAllocate: memLog.Lines.Add( '定位成功 !');
    cmdNList: memLog.Lines.Add( 'NList 成功 !');
    cmdDoCommand: memLog.Lines.Add( '执行命令成功 !');
  end;
end;

procedure TfrmFileTransfer.ftp1Connect(Sender: TObject);
begin
	 stxtMsg.Caption :='连接成功 !';
     memLog.Lines.Add('连接成功 !');
end;

procedure TfrmFileTransfer.ftp1ConnectionFailed(Sender: TObject);
begin
     stxtMsg.Caption :='连接失败 !';
     memLog.Lines.Add('连接失败 !');
end;

procedure TfrmFileTransfer.ftp1Disconnect(Sender: TObject);
begin
     stxtMsg.Caption :='与服务器断开连接 !';
     memLog.Lines.Add('与服务器断开连接 !');
end;

procedure TfrmFileTransfer.ftp1Error(Sender: TComponent; Errno: Word;
  Errmsg: String);
begin
     stxtMsg.Caption :='错误 '+IntToStr(Errno)+': '+Errmsg;
	 memLog.Lines.Add('错误 '+IntToStr(Errno)+': '+Errmsg);
end;

procedure TfrmFileTransfer.ftp1TransactionStart(Sender: TObject);
begin
	 stxtMsg.Caption :='开始传输 ...';
	 memLog.Lines.Add('开始传输 ...');
     stxtTotal.Caption := IntToStr(ftp1.BytesTotal);
     stxtRcv.Caption :='0';
     prgTransfer.MinValue :=0;
     prgTransfer.MaxValue :=ftp1.BytesTotal;
     prgTransfer.Progress :=0;

end;

procedure TfrmFileTransfer.ftp1TransactionStop(Sender: TObject);
begin
	 stxtMsg.Caption :='停止下载 !';
     memLog.Lines.Add('停止下载 !');
end;

procedure TfrmFileTransfer.btnAboutClick(Sender: TObject);
var
  Icon:Integer;
  Title,Msg:String;
begin
  Icon:=LoadIcon(hinstance,'mainicon');
  Title:='天翔远程文件传输管理 V2001';
  Msg:='胥小华 于 2001.03 E-mail:[e-mail]';
  ShellAbout(Handle,PChar(Title),PChar(Msg),Icon);
end;

procedure TfrmFileTransfer.BitBtn1Click(Sender: TObject);
begin
	if MessageBox(handle,'确定要退出文件传输管理吗？','提示窗口',MB_ICONQUESTION+MB_YESNO)=IDYES then
	begin
		SaveReg;
		SaveSendTables;
		Application.Terminate ;