mainf.pas

地理资源的录入程序运用了api的一些知识

unit mainf;

interface

uses
  {$IFDEF Linux}
  QGraphics, QControls, QForms, QDialogs, QStdCtrls, QExtCtrls, QComCtrls, QMenus, QTypes,
  {$ELSE}
  windows, messages, graphics, controls, forms, dialogs, stdctrls, extctrls, comctrls,
  menus,
  {$ENDIF}
  SysUtils, Classes, IdIntercept, IdLogBase, IdLogDebug, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdFTP,
  IdAntiFreezeBase, IdAntiFreeze, WinSkinStore, WinSkinData;

type
  TMainForm = class(TForm)
    Splitter1: TSplitter;
    DirectoryListBox: TListBox;
    DebugListBox: TListBox;
    StatusBar1: TStatusBar;
    ProgressBar1: TProgressBar;
    IdFTP1: TIdFTP;
    IdLogDebug1: TIdLogDebug;
    UploadOpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    IdAntiFreeze1: TIdAntiFreeze;
    PopupMenu1: TPopupMenu;
    Upload1: TMenuItem;
    Delete1: TMenuItem;
    N1: TMenuItem;
    Panel1: TPanel;
    Label1: TLabel;
    FtpServerEdit: TEdit;
    ConnectButton: TButton;
    Panel3: TPanel;
    CurrentDirEdit: TEdit;
    UploadButton: TButton;
    AbortButton: TButton;
    CommandPanel: TPanel;
    Label2: TLabel;
    N2: TMenuItem;
    N3: TMenuItem;
    Label3: TLabel;
    UserIDEdit: TEdit;
    PasswordEdit: TEdit;
    Label4: TLabel;
    Label5: TLabel;
    Edit1: TEdit;
    fh: TButton;
  procedure ConnectButtonClick(Sender: TObject);
  procedure IdLogDebug1LogItem(ASender: TComponent; var AText: String);
  procedure UploadButtonClick(Sender: TObject);
  procedure DirectoryListBoxDblClick(Sender: TObject);
  procedure DeleteButtonClick(Sender: TObject);
  procedure IdFTP1Disconnected(Sender: TObject);
  procedure AbortButtonClick(Sender: TObject);
  procedure BackButtonClick(Sender: TObject);
  procedure IdFTP1Status(axSender: TObject; const axStatus: TIdStatus;
  const asStatusText: String);
  procedure TraceCheckBoxClick(Sender: TObject);
  procedure FormCreate(Sender: TObject);
  procedure DirectoryListBoxClick(Sender: TObject);
  procedure IdFTP1Work(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCount: Integer);
  procedure IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCountMax: Integer);
  procedure IdFTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
  procedure ChDirButtonClick(Sender: TObject);
    procedure Upload1Click(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure Delete1Click(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure fhClick(Sender: TObject);
  private
  { Private declarations }
  AbortTransfer: Boolean;
  TransferrignData: Boolean;
  BytesToTransfer: LongWord;
  STime: TDateTime;
  procedure ChageDir(DirName: String);
  procedure SetFunctionButtons(AValue: Boolean);
  procedure SaveFTPHostInfo(Datatext, header: String);
  function GetHostInfo(header: String): String;
  procedure   UpLoadwjj(Remote_path,Local_path:string);
  public
  { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$IFDEF MSWINDOWS}{$R *.dfm}{$ELSE}{$R *.xfm}{$ENDIF}

Uses
  IniFiles,IdFTPList, IdFTPCommon,datam;

Var
  AverageSpeed: Double = 0;


 procedure   TmainForm.UpLoadwjj(Remote_path,Local_path:string);
  var   strl1,strl2,strl3:TStringList;
          sr:   TSearchRec;
          i,j,DirCount,FileCount:integer;
          str:string;
  begin
      IdFTP1.ChangeDir(Remote_path);

      DirCount:=0;FileCount:=0;

      IdFTP1.MakeDir(Copy(Local_path,LastDelimiter('\',Local_path)+1,length(Local_path)));

      if   FindFirst(Local_path   +   '\*.*',   faDirectory,   sr)   =   0   then
      begin
          strl1:=TStringList.Create;
          repeat
              if   (sr.Attr   =   faDirectory)   and(sr.Name<>'.')   and   (sr.Name<>'..')   then
              begin
                  strl1.Add(sr.Name);
                  Inc(DirCount);
              end;
          until   FindNext(sr)   <>   0;
          FindClose(sr);
      end;

      for   i:=0   to   DirCount-1   do   
      begin   
          UpLoadwjj(Remote_path+'/'+Copy(Local_path,LastDelimiter('\',Local_path)+1,length(Local_path)),Local_path+'\'+strl1.Strings[i]);//这里实现递归调用
      end;   

      if   FindFirst(Local_path   +   '\*.*',faAnyFile,   sr   )=0   then
      begin
          strl2:=TStringList.Create;
          repeat
              if   (sr.Attr   <>   faDirectory)   then   
              begin   
                  strl2.Add(sr.Name);   
                  Inc(FileCount);   
              end;
          until   FindNext(sr)   <>0;   
          FindClose(sr);   
      end;

      IdFTP1.ChangeDir(Remote_path+'/'+Copy(Local_path,LastDelimiter('\',Local_path)+1,length(Local_path)));

      for   j:=0   to   FileCount-1   do
      begin   
          try   
              IdFTP1.Put(Local_path+'\'+strl2[j],IdFTP1.RetrieveCurrentDir+'/'+strl2[j]);
              DirectoryListBox.Items.Add('^_^      '+strl2[j]+'上传成功!');
          except
              DirectoryListBox.Items.Add(':o       '+strl2[j]+'上传失败!');
              Continue;
          end;
      end;
  end;
procedure TMainForm.SetFunctionButtons(AValue: Boolean);
Var
  i: Integer;
begin
  with CommandPanel do
  for i := 0 to ControlCount - 1 do
  if Controls[i].Name <> 'AbortButton' then Controls[i].Enabled := AValue;

  with PopupMenu1 do
  for i := 0 to Items.Count - 1 do Items[i].Enabled := AValue;


end;

procedure TMainForm.ConnectButtonClick(Sender: TObject);
begin
  ConnectButton.Enabled := false;
  if IdFTP1.Connected then try
  if TransferrignData then IdFTP1.Abort;
  IdFTP1.Quit;
  finally

  CurrentDirEdit.Text := '/地理资源上传/';
  DirectoryListBox.Items.Clear;
 
  ConnectButton.Caption := '连接';
  connectBUTTON.Enabled :=TRUE;
  UPLOADBUTTON.Enabled :=FALSE;
   fh.Enabled :=false
  end
  else with IdFTP1 do try
  Username:= useridedit.Text;
  Password := passwordedit.Text;
  Host := ftpserveredit.Text;
  port:=strtoint(edit1.text);
  Connect;
  Self.ChageDir(CurrentDirEdit.Text);
  SetFunctionButtons(true);
  SaveFTPHostInfo(FtpServerEdit.Text, 'FTPHOST');
  finally
  ConnectButton.Enabled := true;
  if Connected then begin
  ConnectButton.Caption := '终止';
  ConnectButton.Default := false;
  connectBUTTON.Enabled :=TRUE;
  UPLOADBUTTON.Enabled :=TRUE;
   fh.Enabled :=true;
  end;
  end;
end;

procedure TMainForm.IdLogDebug1LogItem(ASender: TComponent;
  var AText: String);
begin
  DebugListBox.ItemIndex := DebugListBox.Items.Add(AText);
end;

procedure TMainForm.UploadButtonClick(Sender: TObject);
var path:string;
t:tstringlist;
i:integer;
f:boolean;
begin
  if IdFTP1.Connected then
   begin
      dm.conn.Close;
          try
              chagedir(idftp1.RetrieveCurrentDir+'/upload') ;
              showmessage('文件已存在!请先删除,或新建文件夹!');
           except
             ChageDir(idftp1.RetrieveCurrentDir);
             path := ExtractFilePath(Application.ExeName)+'upload';
             UpLoadwjj(IdFTP1.RetrieveCurrentDir,path);
             dm.conn.Open;
           end;
     end;
 end;
procedure TMainForm.ChageDir(DirName: String);
begin
  try
  IdFTP1.ChangeDir(DirName);
  CurrentDirEdit.Text := IdFTP1.RetrieveCurrentDir;
  DirectoryListBox.Items.Clear;
  IdFTP1.List(DirectoryListBox.Items);
  finally
  SetFunctionButtons(true);
  end;
end;

function GetNameFromDirLine(Line: String; Var IsDirectory: Boolean): String;
Var
  i: Integer;
  DosListing: Boolean;
begin
  IsDirectory := Line[1] = 'd';
  DosListing := false;
  for i := 0 to 7 do begin
  if (i = 2) and not IsDirectory then begin
  IsDirectory := Copy(Line, 1, Pos(' ', Line) - 1) = '<DIR>';
  if not IsDirectory then
  DosListing := Line[1] in ['0'..'9']
  else DosListing := true;
  end;
  Delete(Line, 1, Pos(' ', Line));
  While Line[1] = ' ' do Delete(Line, 1, 1);
  if DosListing and (i = 2) then break;
  end;
  Result := Line;
end;

procedure TMainForm.DirectoryListBoxDblClick(Sender: TObject);
Var
  Name, Line: String;
  IsDirectory: Boolean;
begin
  if not IdFTP1.Connected then exit;
  Line := DirectoryListBox.Items[DirectoryListBox.ItemIndex];
  Name := GetNameFromDirLine(Line, IsDirectory);
  if IsDirectory then begin
  // Change directory

  ChageDir(Name);

  end
  else begin

  end;
end;

procedure TMainForm.DeleteButtonClick(Sender: TObject);
Var
  Name, Line: String;
  IsDirectory: Boolean;
begin
  if not IdFTP1.Connected then exit;
  Line := DirectoryListBox.Items[DirectoryListBox.ItemIndex];
  Name := GetNameFromDirLine(Line, IsDirectory);
  if IsDirectory then try
  SetFunctionButtons(false);
  idftp1.RemoveDir(Name);
  ChageDir(idftp1.RetrieveCurrentDir);
  finally
  end
  else
  try
  SetFunctionButtons(false);
  idftp1.Delete(Name);
  ChageDir(idftp1.RetrieveCurrentDir);
  finally
  end;
end;

procedure TMainForm.IdFTP1Disconnected(Sender: TObject);
begin
  StatusBar1.Panels[1].Text := 'Disconnected.';
end;

procedure TMainForm.AbortButtonClick(Sender: TObject);
begin
  AbortTransfer := true;
end;

procedure TMainForm.BackButtonClick(Sender: TObject);
begin
  if not IdFTP1.Connected then exit;
  try
  ChageDir('..');
  finally end;
end;

procedure TMainForm.IdFTP1Status(axSender: TObject; const axStatus: TIdStatus;
  const asStatusText: String);
begin
  DebugListBox.ItemIndex := DebugListBox.Items.Add(asStatusText);
  StatusBar1.Panels[1].Text := asStatusText;
end;

procedure TMainForm.TraceCheckBoxClick(Sender: TObject);
begin
 //IdLogDebug1.Active := TraceCheckBox.Checked;
 // DebugListBox.Visible := TraceCheckBox.Checked;
//  if DebugListBox.Visible then Splitter1.Top := DebugListBox.Top + 5;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin

  IdLogDebug1.Active := true;
  UPLOADBUTTON.Enabled :=FALSE;
  fh.Enabled :=false;


  ProgressBar1.Parent := StatusBar1;
  ProgressBar1.Top := 2;
  ProgressBar1.Left := 1;
  {$IFDEF Linux}
  ProgressBar1.Width := 142;
  {$ENDIF}
end;
 procedure FTP_DeleteAllFiles(var idFTP : TIdFtp;RemoteDir,RootDir : string);

label Files;

var

i,DirCount : integer;

Temp : string;

begin

idFTP.ChangeDir(RemoteDir);

if Pos(RootDir,idFTP.RetrieveCurrentDir) = 0 then Exit;

Files :

idFTP.List(nil);

DirCount := idFTP.DirectoryListing.Count ;

while DirCount = 0 do

begin

Temp := idFTP.RetrieveCurrentDir;

idFTP.ChangeDirUp;

idFTP.RemoveDir(Temp);

idFTP.List(nil);

DirCount := idFTP.DirectoryListing.Count ;

for i := 0 to DirCount - 1 do

if idFTP.DirectoryListing[i].FileName = RootDir then Exit;

end;

for i := 0 to DirCount - 1 do

begin

if Pos(RootDir,idFTP.RetrieveCurrentDir) = 0 then Break ;

if idFTP.DirectoryListing[i].ItemType = ditDirectory then

begin

FTP_DeleteAllFiles(idFTP,idFTP.DirectoryListing[i].FileName,RootDir);

end
else
begin

idFTP.Delete(idFTP.DirectoryListing[i].FileName);
//Form1.lb_num.Caption := IntToStr(StrToInt(Form1.lb_num.Caption) + 1);

//Form1.lb_num.Update;

goto Files ;

end;

end;

end;
procedure TMainForm.DirectoryListBoxClick(Sender: TObject);
Var
  Line: String;
  IsDirectory: Boolean;
begin
  if not IdFTP1.Connected then exit;
  Line := DirectoryListBox.Items[DirectoryListBox.ItemIndex];
  GetNameFromDirLine(Line, IsDirectory);

end;

procedure TMainForm.IdFTP1Work(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCount: Integer);
Var
  S: String;
  TotalTime: TDateTime;
  H, M, Sec, MS: Word;
  DLTime: Double;
begin
  TotalTime :=  Now - STime;
  DecodeTime(TotalTime, H, M, Sec, MS);
  Sec := Sec + M * 60 + H * 3600;
  DLTime := Sec + MS / 1000;
  if DLTime > 0 then
  AverageSpeed := {(AverageSpeed + }(AWorkCount / 1024) / DLTime{) / 2};

  S := FormatFloat('0.00 KB/s', AverageSpeed);
  case AWorkMode of
  wmRead: StatusBar1.Panels[1].Text := 'Download speed ' + S;
  wmWrite: StatusBar1.Panels[1].Text := 'Uploade speed ' + S;
  end;

  if AbortTransfer then IdFTP1.Abort;

  ProgressBar1.Position := AWorkCount;
  AbortTransfer := false;
end;

procedure TMainForm.IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCountMax: Integer);
begin
  TransferrignData := true;
  AbortButton.Visible := true;
  AbortTransfer := false;
  STime := Now;
  if AWorkCountMax > 0 then ProgressBar1.Max := AWorkCountMax
  else ProgressBar1.Max := BytesToTransfer;
  AverageSpeed := 0;
end;

procedure TMainForm.IdFTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
  AbortButton.Visible := false;
  StatusBar1.Panels[1].Text := 'Transfer complete.';
  BytesToTransfer := 0;
  TransferrignData := false;
  ProgressBar1.Position := 0;
  AverageSpeed := 0;
end;

procedure TMainForm.ChDirButtonClick(Sender: TObject);
begin
  SetFunctionButtons(false);
  ChageDir(CurrentDirEdit.Text);
  SetFunctionButtons(true);
end;

procedure TMainForm.SaveFTPHostInfo(Datatext, header: String);
var
  ServerIni: TIniFile;
begin
  ServerIni := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'FtpHost.ini');
  ServerIni.WriteString('Server', header, Datatext);
  ServerIni.UpdateFile;
  ServerIni.Free;
end;

function TMainForm.GetHostInfo(header: String): String;
var
  ServerName: String;
  ServerIni: TIniFile;
begin
  ServerIni := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'FtpHost.ini');
  ServerName := ServerIni.ReadString('Server', header, header);

  ServerIni.Free;
  result := ServerName;
end;


procedure TMainForm.Upload1Click(Sender: TObject);
begin
uploadbutton.Click ;
end;

procedure TMainForm.N3Click(Sender: TObject);
Var
  S: String;
begin
  S := InputBox('输入新的文件夹', '文件名', '');
  if S <> '' then
  try

  IdFTP1.MakeDir(S);
  ChageDir(CurrentDirEdit.Text);
  finally

  end;
end;

procedure TMainForm.Delete1Click(Sender: TObject);
Var
  Name, Line: String;
  IsDirectory: Boolean;
begin

if not IdFTP1.Connected then exit;
  Line := DirectoryListBox.Items[DirectoryListBox.ItemIndex];
  Name := GetNameFromDirLine(Line, IsDirectory);
  if IsDirectory then   try
 // SetFunctionButtons(false);
  //ChageDir(idftp1.RetrieveCurrentDir);
 // FTP_DeleteAllFiles(IdFTP1,'upload','upload');
  idftp1.RemoveDir(Name);
  ChageDir(idftp1.RetrieveCurrentDir);
 except
  application.MessageBox('删除目录失败!!请确定目录下已没有文件!', '删除信息提示', MB_ICONINFORMATION);
  end
  else
  try
//  SetFunctionButtons(false);
  idftp1.Delete(Name);
  ChageDir(idftp1.RetrieveCurrentDir);
  finally
  end;



end;

procedure TMainForm.N2Click(Sender: TObject);
begin
    if not IdFTP1.Connected then exit;
  try
  ChageDir('..');
  finally
  end;
end;

procedure TMainForm.fhClick(Sender: TObject);
begin
if not IdFTP1.Connected then exit;
  try
  ChageDir('..');
  finally
   end;
end;

end.