mainform.pas

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

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, ToolWin, ComCtrls, ExtCtrls, ScktComp, SBSimpleSftp, SBSftpCommon,
  SBSSHConstants, SBSSHKeyStorage, SBUtils, StdCtrls, ImgList;

type
  TfrmMain = class(TForm)
    tbToolbar: TToolBar;
    MainMenu: TMainMenu;
    mnuConnection: TMenuItem;
    mnuConnect: TMenuItem;
    mnuDisconnect: TMenuItem;
    N1: TMenuItem;
    mnuExit: TMenuItem;
    mnuHelp: TMenuItem;
    mnuAbout: TMenuItem;
    lvLog: TListView;
    lvFiles: TListView;
    tbConnect: TToolButton;
    tbDisconnect: TToolButton;
    tbDelim1: TToolButton;
    tbRename: TToolButton;
    tbMakeDir: TToolButton;
    tbDelete: TToolButton;
    tbDelim2: TToolButton;
    tbDownload: TToolButton;
    tbUpload: TToolButton;
    tbDelim3: TToolButton;
    tbRefresh: TToolButton;
    SftpClient: TElSimpleSFTPClient;
    spLog: TSplitter;
    pPath: TPanel;
    lPath: TLabel;
    SaveDialog: TSaveDialog;
    OpenDialog: TOpenDialog;
    imgListViews: TImageList;
    Image1: TImage;
    procedure tbConnectClick(Sender: TObject);
    procedure tbDisconnectClick(Sender: TObject);
    procedure tbRenameClick(Sender: TObject);
    procedure tbMakeDirClick(Sender: TObject);
    procedure tbDeleteClick(Sender: TObject);
    procedure tbDownloadClick(Sender: TObject);
    procedure tbUploadClick(Sender: TObject);
    procedure tbRefreshClick(Sender: TObject);
    procedure SftpClientAuthenticationFailed(Sender: TObject;
      AuthenticationType: Integer);
    procedure SftpClientAuthenticationSuccess(Sender: TObject);
    procedure SftpClientCloseConnection(Sender: TObject);
    procedure SftpClientError(Sender: TObject; ErrorCode: Integer);
    procedure SftpClientKeyValidate(Sender: TObject; ServerKey: TElSSHKey;
      var Validate: Boolean);
    procedure lvFilesDblClick(Sender: TObject);
    procedure mnuConnectClick(Sender: TObject);
    procedure mnuDisconnectClick(Sender: TObject);
    procedure mnuExitClick(Sender: TObject);
    procedure mnuAboutClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure SftpClientAuthenticationKeyboard(Sender: TObject;
      Prompts: TStringList; Echo: TBits; Responses: TStringList);
    procedure SftpClientProgress(Sender: TObject; Total, Current: Int64;
      var Cancel: Boolean);
  private
    FCurrentDir : string;
    FKeyStorage: TElSSHMemoryKeyStorage;
    function AbsPath(FileName : string) : string;
    procedure Connect;
    procedure Disconnect;
    procedure Rename;
    procedure MakeDir;
    procedure Delete;
    procedure Download;
    procedure Upload;
    procedure ChangeDir;
    procedure Refresh;
    procedure Log(const S : string; Error : boolean = false);
    procedure ClearFileList;
    function FormatRights(Attributes: TElSftpFileAttributes) : string;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

uses ConnPropsForm, ProgressForm, AboutForm, PromptForm;

{$R *.DFM}

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

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

procedure TfrmMain.tbRenameClick(Sender: TObject);
begin
  Rename;
end;

procedure TfrmMain.tbMakeDirClick(Sender: TObject);
begin
  MakeDir;
end;

procedure TfrmMain.tbDeleteClick(Sender: TObject);
begin
  Delete;
end;

procedure TfrmMain.tbDownloadClick(Sender: TObject);
begin
  Download;
end;

procedure TfrmMain.tbUploadClick(Sender: TObject);
begin
  Upload;
end;

procedure TfrmMain.tbRefreshClick(Sender: TObject);
begin
  Refresh;
end;

procedure TfrmMain.Connect;
var
  Key: TElSSHKey;
begin
  if SftpClient.Active then
  begin
    MessageDlg('Already connected', mtInformation, [mbOk], 0);
    Exit;
  end;

  if frmConnProps.ShowModal = mrOk then
  begin
    if Pos(':', frmConnProps.editHost.Text) > 0 then
    begin
      SftpClient.Address := Copy(frmConnProps.editHost.Text, 1, Pos(':', frmConnProps.editHost.Text) - 1);
      SftpClient.Port := StrToIntDef(Copy(frmConnProps.editHost.Text, Pos(':', frmConnProps.editHost.Text) + 1, Length(frmConnProps.editHost.Text)), 22);
    end
    else
    begin
      SftpClient.Address := frmConnProps.editHost.Text;
      SftpClient.Port := 22;
    end;

    SftpClient.CompressionAlgorithms[SSH_CA_ZLIB] := true;
    
    SftpClient.EncryptionAlgorithms[SSH_EA_3DES] := false;
    SftpClient.EncryptionAlgorithms[SSH_EA_DES] := false;
    SftpClient.EncryptionAlgorithms[SSH_EA_BLOWFISH] := false;
    SftpClient.Username := frmConnProps.editUsername.Text;
    SftpClient.Password := frmConnProps.editPassword.Text;

    FKeyStorage.Clear;
    Key := TElSSHKey.Create;
    if (frmConnProps.edPrivateKey.Text <> '') and FileExists(frmConnProps.edPrivateKey.Text) and
       (Key.LoadPrivateKey(frmConnProps.edPrivateKey.Text) = 0) then
    begin
      FKeyStorage.Add(Key);
      SftpClient.AuthenticationTypes := SftpClient.AuthenticationTypes or SSH_AUTH_TYPE_PUBLICKEY;
    end
    else
      SftpClient.AuthenticationTypes := SftpClient.AuthenticationTypes and not SSH_AUTH_TYPE_PUBLICKEY;

    Key.Free;

    Log('Connecting to ' + SftpClient.Address);
    try
      SftpClient.Open;
    except
      on E: Exception do
      begin
        Log('Sftp connection failed with message [' + E.Message + ']', true);
        SftpClient.Close;
        Exit;
      end;
    end;
    Log('Sftp connection established');
    FCurrentDir := '.';
    Refresh;
  end;
end;

procedure TfrmMain.Disconnect;
begin
  Log('Disconnecting');
  SftpClient.Close;
end;

procedure TfrmMain.Rename;
var
  NewName: string;
begin
  if SftpClient.Active and Assigned(lvFiles.Selected) and Assigned(lvFiles.Selected.Data) then
  begin
    NewName := InputBox('Rename', 'Please enter the new name for ' + TElSftpFileInfo(lvFiles.Selected.Data).Name, '');
    if NewName = '' then Exit;
    Log('Renaming ' + TElSftpFileInfo(lvFiles.Selected.Data).Name + ' to ' + NewName);
    try
      SftpClient.RenameFile(AbsPath(TElSftpFileInfo(lvFiles.Selected.Data).Name),
        AbsPath(NewName));
    except
      on E: Exception do
      begin
        Log('Failed to rename file "' + TElSftpFileInfo(lvFiles.Selected.Data).Name + '" to "' +
          NewName + '", ' + E.Message, true);
      end;
    end;
    Refresh;
  end;
end;

procedure TfrmMain.MakeDir;
var
  DirName : string;
begin
  if SftpClient.Active then
  begin
    DirName := InputBox('Make directory', 'Please enter the name for new directory', '');
    if DirName = '' then Exit;
    Log('Creating directory ' + DirName);
    try
      SftpClient.MakeDirectory(AbsPath(DirName), nil);
    except
      on E: Exception do
      begin
        Log('Failed to create directory "' + DirName + '", ' + E.Message, true);
      end;
    end;
    Refresh;
  end;
end;

procedure TfrmMain.Delete;
var FName : string;
begin
  if SftpClient.Active and Assigned(lvFiles.Selected) and Assigned(lvFiles.Selected.Data) then
  begin
    if MessageDlg('Please confirm that you want to delete "' +
      TElSftpFileInfo(lvFiles.Selected.Data).Name + '"', mtConfirmation,
      [mbYes, mbNo], 0) = mrYes then
    begin
      Log('Removing item ' + TElSftpFileInfo(lvFiles.Selected.Data).Name);
      FName := AbsPath(TElSftpFileInfo(lvFiles.Selected.Data).Name);
      try
        if TElSftpFileInfo(lvFiles.Selected.Data).Attributes.Directory then
          SftpClient.RemoveDirectory(FName)
        else
          SftpClient.RemoveFile(FName);
      except
        on E: Exception do
        begin
          Log('Failed to delete "' + TElSftpFileInfo(lvFiles.Selected.Data).Name + '", ' +
            E.Message, true);
        end;
      end;
      Refresh;
    end;
  end;
end;

procedure TfrmMain.Download;
var
  Size : integer;
  FName : string;
begin
  if SftpClient.Active and Assigned(lvFiles.Selected) and Assigned(lvFiles.Selected.Data) and
    (not TElSftpFileInfo(lvFiles.Selected.Data).Attributes.Directory) then
  begin
    SaveDialog.FileName := TElSftpFileInfo(lvFiles.Selected.Data).Name;
    if SaveDialog.Execute then
    begin
      Log('Downloading file ' + TElSftpFileInfo(lvFiles.Selected.Data).Name);
      FName := AbsPath(TElSftpFileInfo(lvFiles.Selected.Data).Name);
      Size := TElSftpFileInfo(lvFiles.Selected.Data).Attributes.Size;
      frmProgress.lSourceFilename.Caption := FName;
      frmProgress.lDestFilename.Caption := SaveDialog.Filename;
      frmProgress.lProgress.Caption := '0 / ' + IntToStr(Size);
      frmProgress.pbProgress.Position := 0;
      frmProgress.Canceled := false;
      frmProgress.Caption := 'Download';
      frmProgress.Show;
      try
        try
          SftpClient.DownloadFile(FName, SaveDialog.Filename);
        finally
          frmProgress.Hide;
          Log('Download finished');
        end;
      except
        on E : Exception do
        begin
          Log('Error during download: ' + E.Message, true);
        end;
      end;
    end;
  end;
end;

procedure TfrmMain.Upload;
var
  shortName : string;
  Size : integer;
  FName : string;
  function GetFileSize(const Name : string): Int64;
  var
    F : TFileStream;
  begin
    try