mainform.pas

来自「著名的SecureBlackBox控件完整源码」· PAS 代码 · 共 617 行 · 第 1/2 页

        try
          FSFTPCLient.MessageLoop:=frmProgress.MessageLoop;
          FSFTPClient.Get(AbsPath(TIdSFTPListItem(lvFiles.Selected.Data).FileName), F);
        finally
          FSFTPCLient.MessageLoop:=InternalMessageLoop;
          frmProgress.Hide;
          F.Free;
        end;
      except
        on E : Exception do
        begin
          Log('Error during download: ' + E.Message, true);
        end;
      end;

      Log('Download finished');
    end;
  end;
end;

procedure TfrmMain.Upload;
var
  ShortName : string;
  Processed, Size : integer;
  F : TFileStream;
begin
  if FSFTPClient.Active then
  begin
    if OpenDialog.Execute then
    begin
      try
        F := TFileStream.Create(OpenDialog.Filename, fmOpenRead or fmShareDenyWrite);
      except
        on E : Exception do
        begin
          Log('Failed to open source file: ' + E.Message, true);
          Exit;
        end;
      end;
      Log('Uploading file ' + OpenDialog.Filename);

      ShortName := ExtractFileName(OpenDialog.Filename);
      Processed := 0;
      Size := F.Size;
      frmProgress.lDestFilename.Caption := AbsPath(ShortName);
      frmProgress.lSourceFilename.Caption := OpenDialog.Filename;
      frmProgress.lProgress.Caption := '0 / ' + IntToStr(Size);
      frmProgress.pbProgress.Position := Processed;
      frmProgress.Canceled := false;
      frmProgress.Caption := 'Upload';
      FSFTPCLient.MessageLoop:=frmProgress.MessageLoop;
      frmProgress.Show;
      try
        try
          FSFTPClient.Put(F, AbsPath(ShortName));
          Processed := Size;
          frmProgress.pbProgress.Position := (Processed * 100) div Size;
          frmProgress.lProgress.Caption := IntToStr(Processed) + ' / ' + IntToStr(Size);
        finally
          FSFTPCLient.MessageLoop:=InternalMessageLoop;
          frmProgress.Hide;
          F.Free;
        end;
      except
        on E : Exception do
        begin
          Log('Error during upload : ' + E.Message, true);
          Exit;
        end;
      end;

      Log('Upload finished');
      Refresh;
    end;
  end;
end;

procedure TfrmMain.ChangeDir;
begin
  if Assigned(lvFiles.Selected) and Assigned(lvFiles.Selected.Data) and
    (TIdSFTPListItem(lvFiles.Selected.Data).ItemType = ditDirectory) then
  begin
    Log('Changing directory to ' + TIdSFTPListItem(lvFiles.Selected.Data).FileName);
    try
      FSFTPClient.ChangeDir(AbsPath(TIdSFTPListItem(lvFiles.Selected.Data).FileName));
    except
      on E : Exception do
      begin
        Log('Unable to change directory: [' + E.Message + ']', true);
        Exit;
      end;
    end;
    Refresh;
  end;
end;

procedure TfrmMain.FileListSort(Sender: TObject; Item1, Item2: TListItem; Data: Integer; var Compare: Integer);
var
  Info1, Info2 : TIdSFTPListItem;
begin
  Info1 := TIdSFTPListItem(Item1.Data);
  Info2 := TIdSFTPListItem(Item2.Data);
  if (Info1.ItemType = ditDirectory) and (Info2.ItemType = ditDirectory) then
    Compare := CompareText(Info1.FileName, Info2.FileName)
  else
  begin
    if Info1.ItemType = ditDirectory then
      Compare := -1
    else
      Compare := 1;
  end;
end;

procedure TfrmMain.Refresh;
var
  I : integer;
  Info : TIdSFTPListItem;
  Item : TListItem;
begin
  ClearFileList;
  if not FSFTPClient.Active then Exit;
  lPath.Caption := FSFTPClient.RetrieveCurrentDir;
  Log('Retrieving file list for ' + lPath.Caption);
  try
    FSFTPClient.List(FDirList);
    for I := 0 to FDirList.Count - 1 do
    begin
      Info := FDirList[I];
      Item := lvFiles.Items.Add;
      Item.Data := Info;
      Item.Caption := Info.FileName;
      if Info.ItemType <> ditDirectory then
      begin
        Item.SubItems.Add(IntToStr(Info.Size));
        Item.ImageIndex := 9;
      end
      else
      begin
        Item.SubItems.Add('');
        Item.ImageIndex := 8;
      end;
      Item.SubItems.Add(DateTimeToStr(Info.ModifiedDate));
      Item.SubItems.Add(Info.OwnerName);
      Item.SubItems.Add(Info.UnixPermissions);
    end;
    lvFiles.AlphaSort;
  except
    on E : Exception do
    begin
      Log('Failed to retrieve file list');
      Exit;
    end;
  end;
end;

procedure TfrmMain.Log(const S : string; Error : boolean = false);
var
  Item : TListItem;
begin
  Item := lvLog.Items.Add;
  Item.Caption := TimeToStr(Now);
  Item.SubItems.Add(S);
  if Error then
    Item.ImageIndex := 11
  else
    Item.ImageIndex := 10;
end;

procedure TfrmMain.ClearFileList;
begin
  try
    FDirList.Clear;
  finally
    lvFiles.Items.Clear;
  end;
end;

procedure TfrmMain.SftpClientAuthenticationFailed(Sender: TObject;
  AuthenticationType: Integer);
begin
  Log('Authentication type [' + IntToStr(AuthenticationType) + '] failed', true);
end;

procedure TfrmMain.SftpClientAuthenticationSuccess(Sender: TObject);
begin
  Log('Authentication succeeded');
end;

procedure TfrmMain.SftpClientCloseConnection(Sender: TObject);
begin
  Log('Sftp connection closed');
end;

procedure TfrmMain.SftpClientError(Sender: TObject; ErrorCode: Integer);
begin
  Log('Error ' + IntToStr(ErrorCode), true);
end;

procedure TfrmMain.SftpClientKeyValidate(Sender: TObject;
  ServerKey: TElSSHKey; var Validate: Boolean);
begin
  Log('Server key [' + DigestToStr(ServerKey.FingerprintMD5) + '] received');
  Validate := true;
end;

procedure TfrmMain.lvFilesDblClick(Sender: TObject);
begin
  ChangeDir;
end;

procedure TfrmMain.mnuConnectClick(Sender: TObject);
begin
  Connect;
end;

procedure TfrmMain.mnuDisconnectClick(Sender: TObject);
begin
  Disconnect;
end;

procedure TfrmMain.mnuExitClick(Sender: TObject);
begin
  Close;
end;

procedure TfrmMain.mnuAboutClick(Sender: TObject);
begin
  frmAbout.ShowModal;
end;

constructor TfrmMain.Create(AOwner: TComponent);
begin
  inherited;

  FSFTPClient := TElIdSFTPClient.Create(Self);
  FDirList := TIdSFTPListItems.Create;
  lvFiles.SortType := stNone;
  lvFiles.OnCompare := FileListSort;

  FKeyStorage := TElSSHMemoryKeyStorage.Create(Self);
  FSFTPClient.KeyStorage := FKeyStorage;
  FSFTPClient.OnKeyValidate := SftpClientKeyValidate;

  // If you get "Parameter lists differ" error,
  // see lines 1 to 4 of the current unit
  FSFTPClient.OnWork := SftpClientWork;
  FSFTPClient.OnWorkBegin := SftpClientWorkBegin;
end;


destructor TfrmMain.Destroy;
begin
  FreeAndNil(FKeyStorage);
  FSFTPClient.Free;
  FDirList.Free;

  inherited;
end;

procedure TfrmMain.SftpClientWork(Sender: TObject; AWorkMode: TWorkMode;
  {$ifdef INDY90}const{$endif} AWorkCount: Integer);
begin
  Processed := AWorkCount;
  frmProgress.lProgress.Caption := IntToStr(Processed) + ' / ' + IntToStr(ToProcess);
  frmProgress.pbProgress.Position := Processed;
end;

procedure TfrmMain.SftpClientWorkBegin(Sender: TObject;
  AWorkMode: TWorkMode; {$ifdef INDY90}const{$endif} AWorkCountMax: Integer);
begin
  ToProcess := AWorkCountMax;
  Processed := 0;
  frmProgress.pbProgress.Max := AWorkCountMax;
end;


function TfrmMain.InternalMessageLoop: boolean;
begin
  Application.ProcessMessages;
  Result:=True;
end;


function TfrmMain.AbsPath(FileName: string): string;
var CurrentDir : string;
begin
  CurrentDir := FSFTPClient.RetrieveCurrentDir;
  if (Length(CurrentDir) = 0) or ((CurrentDir[Length(CurrentDir)] <> '\')
    and (CurrentDir[Length(CurrentDir)] <> '/')) then
    result := CurrentDir + '/' + FileName
  else
    result := CurrentDir + FileName;
end;


initialization

SetLicenseKey('ADDCD14AD06709806817E0B3D7BFD0A2222D536FE156466C5D5FE65DB5DEAE76' + 
  'FFDEBC07E915A5751C12C01C783958872A38E4A5EDA140E7247E0F2E56442A3C' + 
  'F3E9347AD8FDE52083A0DFC86BC00ECB0FD0CF1B51159A2BCB84F6EA6349EF47' + 
  '5C15A59AFCC55F7C3AAD26C279628B5D91B1DC94BD2385354A70CCA3B76101D9' + 
  'F41C84A639FC3CCE4BA8F0CC4A66DCD150114A3F58C1AD46B7B94643741BC20A' + 
  '8DCA83AB921480951B423CAA19EF1863A47CA2C3422E7E5634BED98939A5AE43' + 
  'DE1E4BAD79E66D8A5C973B3455656C8C9B6FF024FADD6CDA02D0F506D98493C8' + 
  'BD1ED7B237DB75FA31F2C82654490CDDDEE24E19939137B9E1DB05508733B22F');

end.