SHOPPER32 за работой
SHOPPER32— базовое FTP-приложение, созданное с помощью компонента CsShopper, оно изображено на рис. 6.3. Создайте новый проект с именем SHOPPER32, вызовите главную форму frmMain и сохраните в модуле MAIN.PAS содержимое листинга 6.1.
Листинг 6.1. Модуль MAIN.PAS (* Модуль Main Написан для книги High Performance Delphi Programming - Джон К.Пенман 1997 За дополнительной информацией и помощью обращайтесь по адресу info@craiglockhart.com *)
unit main; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, FileCtrl, ComCtrls, CsSocket, CsShopper, MkDirFrm, CsFtpMsg, ToolWin, Registry, ExtCtrls;
Рис. 6.3. Приложение SHOPPER32
type TfrmMain = class(TForm) CsShopper1: TCsShopper; pcShopper: TPageControl; tsConnect: TTabSheet; tsOptions: TTabSheet; tsAbout: TTabSheet; gbLocal: TGroupBox; gbRemote: TGroupBox; gbActions: TGroupBox; dcbLocal: TDriveComboBox; dlbLocal: TDirectoryListBox; flbLocal: TFileListBox; sbStatus: TStatusBar; pbDataTransfer: TProgressBar; lbRemoteFiles: TListBox; bbtnExit: TBitBtn; bbtnConnect: TBitBtn; bbtnAbort: TBitBtn; gbUserName: TGroupBox; gbPassword: TGroupBox; gbDefLocalDir: TGroupBox; gbDefTextEditor: TGroupBox; edDefUserName: TEdit; edDefPassword: TEdit; edDefLocalDir: TEdit; edDefTextEditor: TEdit; bbtnFtpCmds: TBitBtn; bbtnLocateTxtEditor: TBitBtn; bbtnLocateDefLocalDir: TBitBtn; gbMoreActions: TGroupBox; bbtnRefresh: TBitBtn; bbtnFTPHelp: TBitBtn; bbtnSite: TBitBtn; bbtnNewDir: TBitBtn; bbtnDelDir: TBitBtn; bbtnViewFile: TBitBtn; memLog: TMemo; rgFileType: TRadioGroup; bbtnRestart: TBitBtn; bbtnQuit: TBitBtn; tsProfiles: TTabSheet; gbSetProfile: TGroupBox; gbPrName: TGroupBox; gbPrHostName: TGroupBox; gbPrUserName: TGroupBox; gbPrPassWord: TGroupBox; gbPrRemDir: TGroupBox; gbPrLocDir: TGroupBox; edPrName: TEdit; edPrHostName: TEdit; edPrUserName: TEdit; edPrPassword: TEdit; edPrRemDir: TEdit; edPrLocDir: TEdit; gbPrList: TGroupBox; lbPrList: TListBox; bbtnPrNew: TBitBtn; bbtnPrSave: TBitBtn; bbtnPrDelete: TBitBtn; rgFTPMode: TRadioGroup; sbbtnRetr: TSpeedButton; sbbtnStor: TSpeedButton; Panel1: TPanel; Label1: TLabel; Label2: TLabel; Label3: TLabel; Label4: TLabel; Label5: TLabel; bbtnStat: TBitBtn; gbHints: TGroupBox; cbHints: TCheckBox; gbFTPOptions: TGroupBox; BitBtn2: TBitBtn; rgFileStructure: TRadioGroup; rgTransfer: TRadioGroup; bbtnAddNew: TBitBtn; procedure bbtnConnectClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure bbtnFtpCmdsClick(Sender: TObject); procedure CsShopper1Info(Sender: TObject; Msg: String); procedure CsShopper1UpDateList(Sender: TObject; List: TStringList); procedure lbRemoteFilesDblClick(Sender: TObject); procedure CsShopper1List(Sender: TObject; List: TStringList); procedure bbtnSiteClick(Sender: TObject); procedure bbtnFTPHelpClick(Sender: TObject); procedure CsShopper1Busy(Sender: TObject; BusyFlag: Boolean); procedure CsShopper1Progress(Sender: TObject; Position: Integer); procedure rgFileTypeClick(Sender: TObject); procedure CsShopper1FileType(Sender: TObject; FileType: TFileTypes); procedure CsShopper1Error(Sender: TObject; Status: TConditions; Msg: String); procedure bbtnNewDirClick(Sender: TObject); procedure bbtnDelDirClick(Sender: TObject); procedure CsShopper1Connect(Sender: TObject; sSocket: Integer); procedure bbtnQuitClick(Sender: TObject); procedure rgFTPModeClick(Sender: TObject); procedure bbtnRefreshClick(Sender: TObject); procedure sbbtnRetrClick(Sender: TObject); procedure sbbtnStorClick(Sender: TObject); procedure CsShopper1DataDone(Sender: TObject; Done: Boolean); procedure bbtnStatClick(Sender: TObject); procedure bbtnRestartClick(Sender: TObject); procedure flbLocalDblClick(Sender: TObject); procedure lbRemoteFilesClick(Sender: TObject); procedure flbLocalClick(Sender: TObject); procedure lbPrListDblClick(Sender: TObject); procedure bbtnConnectMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure bbtnViewFileClick(Sender: TObject); procedure bbtnAbortClick(Sender: TObject); procedure bbtnPrSaveClick(Sender: TObject); procedure bbtnExitClick(Sender: TObject); procedure lbPrListClick(Sender: TObject); procedure bbtnPrNewClick(Sender: TObject); procedure bbtnAddNewClick(Sender: TObject); procedure edPrNameExit(Sender: TObject); procedure edPrHostNameExit(Sender: TObject); procedure edPrUserNameExit(Sender: TObject); procedure edPrPasswordExit(Sender: TObject); procedure edPrRemDirExit(Sender: TObject); procedure edPrLocDirExit(Sender: TObject); procedure bbtnPrDeleteClick(Sender: TObject); procedure bbtnLocateDefLocalDirClick(Sender : TObject); procedure bbtnLocateTxtEditorClick(Sender: TObject); procedure BitBtn2Click(Sender: TObject); private { Private declarations } public { Public declarations } HelpCmd : String; UsedProfile, UsedQFTP, NewProfile : Boolean; OldTransferMode, OldFileStruct : String; OldProfiles, HostNameList, UsernameList, PasswordList, RemoteDirList, LocalDirList, CurrentProfiles, ProfileNameList : TStringList; NoOfUsers, LastProfileUsed, NoProfiles : Integer; procedure LoadSettings; procedure SaveOptions; procedure SaveProfiles; end; var frmMain: TfrmMain; implementation uses RMDirFrm, HelpFrm, QuickFTPfrm, LocateDirFrm, LocateEdFrm; {$R *.DFM} const FtpClientKey = 'Software\High Performance Delphi\Shopper32'; procedure TfrmMain.LoadSettings; var Reg : TRegistry; Count : Integer; ProfileName : String; begin Reg := TRegistry.Create; // Считываем имя пользователя по умолчанию try Reg.OpenKey(FtpClientKey, TRUE); if Reg.ValueExists('UserName') then edDefUserName.Text := Reg.ReadString('UserName') else edDefUserName.Text := 'anonymous'; finally Reg.CloseKey; end; // Считываем пароль по умолчанию try Reg.OpenKey(FtpClientKey, TRUE); if Reg.ValueExists('Password') then edDefPassword.Text := Reg.ReadString('Password') else edDefPassword.Text := 'guest'; finally Reg.CloseKey; end; // Считываем локальный каталог по умолчанию try Reg.OpenKey(FtpClientKey, TRUE); if Reg.ValueExists('DefLocalDir') then edDefLocalDir.Text := Reg.ReadString('DefLocalDir') else edDefLocalDir.Text := 'C:\'; finally Reg.CloseKey; end; // Считываем редактор, используемый по умолчанию try Reg.OpenKey(FtpClientKey, TRUE); if Reg.ValueExists('Editor') then edDefTextEditor.Text := Reg.ReadString('Editor') else edDefTextEditor.Text := 'NOTEPAD '; finally Reg.CloseKey; end; // Задаем свойства try Reg.OpenKey(FtpClientKey, TRUE); if Reg.ValueExists('Asynchronous') then begin with CsShopper1 do begin Asynchronous := Reg.ReadBool('Asynchronous'); if Asynchronous then rgFTPMode.ItemIndex := 0 else rgFTPMode.ItemIndex := 1; end; end else begin CsShopper1.Asynchronous := FALSE; rgFTPMode.ItemIndex := 0; end; finally Reg.CloseKey; end; try Reg.OpenKey(FtpClientKey, TRUE); if Reg.ValueExists('Hints') then cbHints.Checked := Reg.ReadBool('Hints') else cbHints.Checked := FALSE; finally Reg.CloseKey; end; try Reg.OpenKey(FtpClientKey, TRUE); if Reg.ValueExists('DTransferMode') then begin OldTransferMode := Reg.ReadString('DTransferMode'); if UpperCase(OldTransferMode) = UpperCase(FtpTransferStr[STREAM]) then begin CsShopper1.Transfer := STREAM; rgTransfer.ItemIndex := 0; end; if UpperCase(OldTransferMode) = UpperCase(FtpTransferStr[BLOCK]) then begin CsShopper1.Transfer := BLOCK; rgTransfer.ItemIndex := 1; end; if UpperCase(OldTransferMode) = UpperCase(FtpTransferStr[COMPRESSED]) then begin CsShopper1.Transfer := COMPRESSED; rgTransfer.ItemIndex := 2; end; end else begin OldTransferMode := UpperCase(FtpTransferStr[STREAM]); CsShopper1.Transfer := STREAM; rgTransfer.ItemIndex := 0; end; finally Reg.CloseKey; end; // Свойство файловой структуры try Reg.OpenKey(FtpClientKey, TRUE); if Reg.ValueExists('DFileStructure') then begin OldFileStruct := Reg.ReadString('DFileStructure'); if UpperCase(OldFileStruct) = UpperCase(FtpFileStructStr[NOREC]) then begin CsShopper1.FileStruct := NOREC; rgFileStructure.ItemIndex := 0; end; if UpperCase(OldFileStruct) = UpperCase(FtpFileStructStr[REC]) then begin CsShopper1.FileStruct := REC; rgFileStructure.ItemIndex := 1; end; if UpperCase(OldFileStruct) = UpperCase(FtpFileStructStr[PAGE]) then begin CsShopper1.FileStruct := PAGE; rgFileStructure.ItemIndex := 2; end; end else begin OldFileStruct := UpperCase(FtpFileStructStr[NOREC]); CsShopper1.FileStruct := NOREC; rgFileStructure.ItemIndex := 0; end; finally Reg.CloseKey; end; try Reg.OpenKey(FtpClientKey, TRUE); if Reg.ValueExists('LastProfileUsed') then LastProfileUsed := Reg.ReadInteger('LastProfileUsed') else LastProfileUsed := 0; finally Reg.CloseKey; end; try Reg.OpenKey(FtpClientKey, TRUE); if Reg.ValueExists('NoProfiles') then NoProfiles := Reg.ReadInteger('NoProfiles') else NoProfiles := 1; finally Reg.CloseKey; end; // Список профилей for Count := 0 to NoProfiles - 1 do begin ProfileName := Concat('ProfileName', IntToStr(Count)); try Reg.OpenKey(FtpClientKey + '\Profiles' + '\ ' + ProfileName, TRUE); if Reg.ValueExists('ProfileName') then ProfileNameList.Add(Reg.ReadString ('ProfileName')) else ProfileNameList.Add('PROFILE'); OldProfiles.Add(Reg.ReadString('ProfileName')); if Reg.ValueExists('Host') then HostNameList.Add(Reg.ReadString('Host')) else HostNameList.Add('HOST'); if Reg.ValueExists('User') then UserNameList.Add(Reg.ReadString('User')) else UserNameList.Add('ANONYMOUS'); if Reg.ValueExists('Password') then PasswordList.Add(Reg.ReadString('Password')) else PasswordList.Add('GUEST'); if Reg.ValueExists('RemoteDir') then RemoteDirList.Add(Reg.ReadString('RemoteDir')) else RemoteDirList.Add('\'); if Reg.ValueExists('LocalDir') then LocalDirList.Add('LocalDir') else LocalDirList.Add('\'); finally Reg.CloseKey; end; end; // цикл for Reg.Free; lbPrList.Items := ProfileNameList; lbPrList.ItemIndex := LastProfileUsed; edPrName.Text := ProfileNameList.Strings[lbPrList.ItemIndex]; edPrHostName.Text := HostNameList.Strings[lbPrList.ItemIndex]; edPrUserName.Text := UserNameList.Strings[lbPrList.ItemIndex]; edPrPassword.Text := PasswordList.Strings[lbPrList.ItemIndex]; edPrRemDir.Text := RemoteDirList.Strings[lbPrList.ItemIndex]; edPrLocDir.Text := LocalDirList.Strings[lbPrList.ItemIndex]; CsShopper1.UserName := edPrUserName.Text; CsShopper1.Password := edPrPassword.Text; lbPrList.Refresh; end;procedure TfrmMain.SaveProfiles; var Reg : TRegistry; Count : Integer; ProfileName : String; begin Reg := TRegistry.Create; try Reg.OpenKey(FtpClientKey, TRUE); Reg.WriteInteger('LastProfileUsed', LastProfileUsed); finally Reg.CloseKey; end; NoProfiles := lbPrList.Items.Count; try Reg.OpenKey(FtpClientKey, TRUE); Reg.WriteInteger('NoProfiles',NoProfiles); finally Reg.CloseKey; end; for Count := 0 to NoProfiles - 1 do begin ProfileName := Concat('ProfileName', IntToStr(Count)); try Reg.OpenKey(FtpClientKey + '\Profiles' + '\ ' + ProfileName, TRUE); Reg.WriteString('ProfileName', lbPrList.Items.Strings[Count]); Reg.WriteString('ProfileName', ProfileNameList.Strings[Count]); Reg.WriteString('Host', HostNameList.Strings[Count]); Reg.WriteString('User', UserNameList.Strings[Count]); Reg.WriteString('Password', PasswordList.Strings[Count]); Reg.WriteString('RemoteDir', RemoteDirList.Strings[Count]); Reg.WriteString('LocalDir', LocalDirList.Strings[Count]); finally Reg.CloseKey; end; end; Reg.Free; end; procedure TfrmMain.SaveOptions; var Reg : TRegistry; begin Reg := TRegistry.Create; // Сохраняем имя пользователя по умолчанию try Reg.OpenKey(FtpClientKey, TRUE); Reg.WriteString('UserName', edDefUserName.Text); finally Reg.CloseKey; end; // Сохраняем пароль по умолчанию try Reg.OpenKey(FtpClientKey, TRUE); Reg.WriteString('Password', edDefPassword.Text); finally Reg.CloseKey; end; // Сохраняем локальный каталог по умолчанию try Reg.OpenKey(FtpClientKey, TRUE); Reg.WriteString('DefLocalDir', edDefLocalDir.Text); finally Reg.CloseKey; end; // Сохраняем редактор, используемый по умолчанию try Reg.OpenKey(FtpClientKey, TRUE); Reg.WriteString('Editor', edDefTextEditor.Text); finally Reg.CloseKey; end; try Reg.OpenKey(FtpClientKey,TRUE); case rgFTPMode.ItemIndex of 0 : Reg.WriteBool('Asynchronous',TRUE); 1 : Reg.WriteBool('Asynchronous',FALSE); end; finally Reg.CloseKey; end; try Reg.OpenKey(FtpClientKey, TRUE); if cbHints.Checked then Reg.WriteBool('Hints',TRUE) else Reg.WriteBool('Hints',FALSE); finally Reg.CloseKey; end; try Reg.OpenKey(FtpClientKey,TRUE); case rgTransfer.ItemIndex of 0 :Reg.WriteString('DTransferMode', FtpTransferStr[STREAM]); 1 :Reg.WriteString('DTransferMode', FtpTransferStr[BLOCK]); 2 :Reg.WriteString('DTransferMode', FtpTransferStr[COMPRESSED]); end; finally Reg.CloseKey; end; try Reg.OpenKey(FtpClientKey,TRUE); case rgFileStructure.ItemIndex of 0 :Reg.WriteString('DFileStructure', FtpFileStructStr[NOREC]); 1 :Reg.WriteString('DFileStructure', FtpFileStructStr[REC]); 2 :Reg.WriteString('DFileStructure', FtpFileStructStr[PAGE]); end; finally Reg.CloseKey; end; Reg.Free; end; procedure TfrmMain.bbtnConnectClick(Sender: TObject); begin if (not UsedQFtp) and (not UsedProfile) then begin with CsShopper1 do begin HostName := HomeServer; if Status = Success then Start; end; end else if UsedQFtp then CsShopper1.Start else if UsedProfile then begin with CsShopper1 do begin UserName := edPrUserName.Text; Password := edPrPassword.Text; RemoteDir:= edPrRemDir.Text; LocalDir := edPrLocDir.Text; EditName := edDefTextEditor.Text; HostName := edPrHostName.Text; if Status = Success then Start; end; end; end; procedure TfrmMain.FormCreate(Sender: TObject); begin bbtnQuit.Enabled := FALSE; bbtnRefresh.Enabled := FALSE; bbtnViewFile.Enabled := FALSE; bbtnFtpCmds.Enabled := FALSE; bbtnAbort.Enabled := FALSE; rgFileType.Enabled := FALSE; gbMoreActions.Visible := FALSE; pbDataTransfer.Visible := FALSE; sbbtnRetr.Enabled := FALSE; sbbtnStor.Enabled := FALSE; OldProfiles := TStringList.Create; ProfileNameList := TStringList.Create; HostNameList := TStringList.Create; UserNameList := TStringList.Create; PasswordList := TStringList.Create; RemoteDirList := TStringList.Create; LocalDirList := TStringList.Create; LoadSettings; if CsShopper1.Asynchronous then begin sbStatus.Panels[2].Text := Concat('Mode : ', 'Asynchronous'); rgFTPMode.ItemIndex := 0; end else begin sbStatus.Panels[2].Text := Concat('Mode : ', 'Non-Asynchronous'); rgFTPMode.ItemIndex := 1; end; sbStatus.Panels[0].Text := Concat('Local Host : ', CsShopper1.LocalName); sbStatus.Panels[3].Text := Concat('Status : ', 'Idle'); pcShopper.ActivePage := tsProfiles; UpDate; end; procedure TfrmMain.bbtnFtpCmdsClick(Sender: TObject); begin gbMoreActions.Visible := not gbMoreActions.Visible; if gbMoreActions.Visible then begin bbtnFtpCmds.Hint := 'Click here to close the panel of FTP commands'; bbtnFtpCmds.Caption := 'Close'; end else begin bbtnFtpCmds.Hint := 'Click here to get more FTP commands'; bbtnFtpCmds.Caption := 'FTP Cmds'; end; end; procedure TfrmMain.CsShopper1Info(Sender: TObject; Msg: String); begin memLog.Lines.Add(Msg); end; procedure TfrmMain.CsShopper1UpDateList(Sender: TObject; List: TStringList); begin LbRemoteFiles.Items := List; lbRemoteFiles.UpDate; gbRemote.Caption := Concat('Files on ', CsShopper1.HostName); sbStatus.Panels[1].Text := Concat('Remote Host : ',CsShopper1.HostName); end; procedure TfrmMain.lbRemoteFilesDblClick (Sender: TObject); begin pbDataTransfer.Visible := TRUE; if lbRemoteFiles.ItemIndex <> -1 then CsShopper1.Get := lbRemoteFiles.Items.Strings [lbRemoteFiles.ItemIndex] else pbDataTransfer.Visible := FALSE; end; procedure TfrmMain.CsShopper1List (Sender: TObject; List: TStringList); begin lbRemoteFiles.Clear; lbRemoteFiles.Items := List; lbRemoteFiles.UpDate; gbRemote.Caption := CsShopper1.RemoteDir; end; procedure TfrmMain.bbtnSiteClick(Sender: TObject); begin CsShopper1.SiteFtp; end; procedure TfrmMain.bbtnFTPHelpClick(Sender: TObject); var Counter : Integer; begin frmHelp := TfrmHelp.Create(Application); for Counter := SFtpUser to SFtpNoop do frmHelp.lbHelpFtpCmds.Items.Add (LoadStr(Counter)); frmHelp.ShowModal; CsShopper1.FtpHelp := HelpCmd; HelpFtpCmdList.Free; frmHelp.Free; end; procedure TfrmMain.CsShopper1Busy (Sender: TObject; BusyFlag: Boolean); begin if BusyFlag then begin lbRemoteFiles.Enabled := FALSE; sbStatus.Panels[3].Text := Concat('Status : ','Busy'); end else begin lbRemoteFiles.Enabled := TRUE; sbStatus.Panels[3].Text := Concat('Status : ','Idle'); end; Update; end; procedure TfrmMain.CsShopper1Progress (Sender: TObject; Position: Integer); begin pbDataTransfer.Position := Position; pbDataTransfer.UpDate; end; procedure TfrmMain.rgFileTypeClick (Sender: TObject); begin with CsShopper1 do case rgFileType.ItemIndex of 0 : FileType := ASCII; 1 : FileType := IMAGE; 2 : FileType := AUTO; end; end; procedure TfrmMain.CsShopper1FileType (Sender: TObject; FileType: TFileTypes); begin case FileType of ASCII : rgFileType.ItemIndex := 0; IMAGE : rgFileType.ItemIndex := 1; AUTO : rgFileType.ItemIndex := 2; end; end; procedure TfrmMain.CsShopper1Error (Sender: TObject; Status: TConditions; Msg: String); begin memLog.Lines.Add(Msg); end; procedure TfrmMain.bbtnNewDirClick (Sender: TObject); begin frmMkNewDir := TfrmMkNewDir.Create(Application); frmMkNewDir.ShowModal; if Length(NewDirName) > 0 then CsShopper1.MkDirName := NewDirName; frmMkNewDir.Free; end; procedure TfrmMain.bbtnDelDirClick(Sender: TObject); begin if lbRemoteFiles.ItemIndex <> -1 then CsShopper1.RmDirName := emoteFiles.Items.Strings[lbRemoteFiles.ItemIndex]; CsShopper1.FilesList; end; procedure TfrmMain.CsShopper1Connect(Sender: TObject; sSocket: Integer); begin bbtnQuit.Enabled := TRUE; bbtnRefresh.Enabled := TRUE; bbtnViewFile.Enabled := TRUE; bbtnFtpCmds.Enabled := TRUE; rgFileType.Enabled := TRUE; if rgFTPMode.ItemIndex = 1 then begin sbbtnRetr.Enabled := TRUE; sbbtnStor.Enabled := TRUE; end else begin sbbtnRetr.Enabled := FALSE; sbbtnStor.Enabled := FALSE; end; bbtnConnect.Enabled := FALSE; bbtnExit.Enabled := FALSE; rgFTPMode.Enabled := FALSE; gbRemote.Caption := 'Remote : ' + CsShopper1.RemoteDir; sbStatus.Panels[1].Text := 'Remote Host : ' + CsShopper1.HostName; sbStatus.Panels[3].Text := 'Status : Connected'; Update; end; procedure TfrmMain.bbtnQuitClick(Sender: TObject); begin bbtnQuit.Enabled := FALSE; bbtnRefresh.Enabled := FALSE; bbtnViewFile.Enabled := FALSE; bbtnFtpCmds.Enabled := FALSE; bbtnAbort.Enabled := FALSE; rgFileType.Enabled := FALSE; sbbtnRetr.Enabled := FALSE; sbbtnStor.Enabled := FALSE; gbMoreActions.Visible := FALSE; pbDataTransfer.Visible := FALSE; bbtnConnect.Enabled := TRUE; bbtnExit.Enabled := TRUE; rgFTPMode.Enabled := TRUE; with sbStatus do begin Panels[1].Text := 'Remote Host : '; Panels[3].Text := 'Status : Idle'; end; lbRemoteFiles.Clear; Update; CsShopper1.Finish; end; (* procedure TfrmMain.Exit1Click(Sender: TObject); begin Close; end; *) procedure TfrmMain.rgFTPModeClick(Sender: TObject); begin if rgFTPMode.ItemIndex = 0 then begin CsShopper1.Asynchronous := TRUE; sbStatus.Panels[2].Text := 'Mode : ' + 'Asynchronous'; sbbtnRetr.Enabled := FALSE; sbbtnStor.Enabled := FALSE; end else begin CsShopper1.Asynchronous := FALSE; sbStatus.Panels[2].Text := 'Mode : ' + 'Non-Asynchronous'; sbbtnRetr.Enabled := TRUE; sbbtnStor.Enabled := TRUE; end; sbStatus.Update; end; procedure TfrmMain.bbtnRefreshClick(Sender: TObject); begin CsShopper1.FilesList end; procedure TfrmMain.sbbtnRetrClick(Sender: TObject); begin pbDataTransfer.Visible := TRUE; bbtnAbort.Enabled := TRUE; CsShopper1.MGet; end; procedure TfrmMain.sbbtnStorClick(Sender: TObject); begin pbDataTransfer.Visible := TRUE; bbtnAbort.Enabled := TRUE; CsShopper1.MPut; end; procedure TfrmMain.CsShopper1DataDone(Sender: TObject; Done: Boolean); begin if Done then begin pbDataTransfer.Visible := FALSE; bbtnAbort.Enabled := FALSE end else begin pbDataTransfer.Visible := TRUE; bbtnAbort.Enabled := TRUE end; pbDataTransfer.Update; end; procedure TfrmMain.bbtnStatClick(Sender: TObject); begin CsShopper1.Stat; end; procedure TfrmMain.bbtnRestartClick(Sender: TObject); begin ShowMessage('Not implemented in this version'); end; procedure TfrmMain.flbLocalDblClick(Sender: TObject); begin pbDataTransfer.Visible := TRUE; if flbLocal.ItemIndex <> -1 then CsShopper1.Put := flbLocal.Items.Strings[flbLocal.ItemIndex] else pbDataTransfer.Visible := FALSE; end; procedure TfrmMain.lbRemoteFilesClick(Sender: TObject); begin CsShopper1.RemoteFiles.Add (lbRemoteFiles.Items.Strings [lbRemoteFiles.ItemIndex]); end; procedure TfrmMain.flbLocalClick(Sender: TObject); begin CsShopper1.LocalFiles.Add (flbLocal.Items.Strings[flbLocal.ItemIndex]); end; procedure TfrmMain.lbPrListDblClick(Sender: TObject); begin UsedProfile := TRUE; pcShopper.ActivePage := tsConnect; ActiveControl := bbtnConnect; bbtnConnect.Click; end; procedure TfrmMain.bbtnConnectMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbRight then // Выполняем упрощенный ftp begin UsedQFtp := TRUE; UsedProfile := FALSE; frmQuickFtp := TfrmQuickFTP.Create(Application); frmQuickFtp.ShowModal; with CsShopper1 do begin UserName := frmQuickFtp.edUserName.Text; Password := frmQuickFtp.edPassword.Text; HostName := frmQuickFtp.edHostName.Text; end; frmQuickFtp.Free; ActiveControl := bbtnConnect; bbtnConnect.Click; end else UsedQFtp := FALSE; end; procedure TfrmMain.bbtnViewFileClick(Sender: TObject); begin if lbRemoteFiles.ItemIndex <> -1 then CsShopper1.View := lbRemoteFiles.Items.Strings [lbRemoteFiles.ItemIndex]; end; procedure TfrmMain.bbtnAbortClick(Sender: TObject); begin CsShopper1.Abort; bbtnAbort.Enabled := FALSE; end; procedure TfrmMain.bbtnPrSaveClick(Sender: TObject); begin SaveProfiles; end; procedure TfrmMain.bbtnExitClick(Sender: TObject); begin OldProfiles.Free; ProfileNameList.Free; HostNameList.Free; UserNameList.Free; PasswordList.Free; RemoteDirList.Free; LocalDirList.Free; end; procedure TfrmMain.lbPrListClick(Sender: TObject); begin if lbPrList.ItemIndex <> -1 then begin LastProfileUsed := lbPrList.ItemIndex; edPrName.Text := ProfileNameList.Strings[LastProfileUsed]; edPrHostName.Text := HostNameList.Strings[LastProfileUsed]; edPrUserName.Text := UserNameList.Strings[LastProfileUsed]; edPrPassword.Text := PasswordList.Strings[LastProfileUsed]; edPrRemDir.Text := RemoteDirList.Strings[LastProfileUsed]; edPrLocDir.Text := LocalDirList.Strings[LastProfileUsed]; Update; end; end; procedure TfrmMain.bbtnPrNewClick(Sender: TObject); begin NewProfile := TRUE; edPrName.Text := ''; edPrHostName.Text := ''; edPrUserName.Text := edDefUserName.Text; edPrPassword.Text := edDefPassword.Text; edPrLocDir.Text := edDefLocalDir.Text; edPrRemDir.Text := '\'; lbPrList.Visible := FALSE; end; procedure TfrmMain.bbtnAddNewClick(Sender: TObject); begin ProfileNameList.Add(edPrName.Text); HostNameList.Add(edPrHostName.Text); UserNameList.Add(edPrUserName.Text); PasswordList.Add(edPrPassword.Text); RemoteDirList.Add(edPrRemDir.Text); LocalDirList.Add(edPrLocDir.Text); lbPrList.Items.Add(edPrName.Text); lbPrList.Visible := TRUE; lbPrList.refresh; NewProfile := FALSE; end; procedure TfrmMain.edPrNameExit(Sender: TObject); begin if (edPrName.Modified) and (not NewProfile) then begin lbPrList.Items.Strings[lbPrList.ItemIndex] := edPrName.Text; lbPrList.Refresh; ProfileNameList.Strings[lbPrList.ItemIndex] := edPrName.Text; end; end; procedure TfrmMain.edPrHostNameExit(Sender: TObject); begin if (edPrHostName.Modified) and (not NewProfile) then HostNameList.Strings[lbPrList.ItemIndex] := edPrHostName.Text; end; procedure TfrmMain.edPrUserNameExit(Sender: TObject); begin if (edPrUserName.Modified) and (not NewProfile) then UserNameList.Strings[lbPrList.ItemIndex] := edPrUserName.Text; end; procedure TfrmMain.edPrPasswordExit(Sender: TObject); begin if (edPrPassword.Modified) and (not NewProfile) then PasswordList.Strings[lbPrList.ItemIndex] := edPrPassword.Text; end; procedure TfrmMain.edPrRemDirExit(Sender: TObject); begin if (edPrRemDir.Modified) and (not NewProfile) then RemoteDirList.Strings[lbPrList.ItemIndex] := edPrRemDir.Text; end; procedure TfrmMain.edPrLocDirExit(Sender: TObject); begin if (edPrLocDir.Modified) and (not NewProfile) then LocalDirList.Strings[lbPrList.ItemIndex] := edPrLocDir.Text; end; procedure TfrmMain.bbtnPrDeleteClick(Sender: TObject); var Reg : TRegistry; Profile : String; begin Reg := TRegistry.Create; Profile := Concat('ProfileName',IntToStr (lbPrList.ItemIndex)); if Reg.DeleteKey(FtpClientKey + '\Profiles\' + Profile) then begin ProfileNameList.Delete(lbPrList.ItemIndex); HostNameList.Delete(lbPrList.ItemIndex); UserNameList.Delete(lbPrList.ItemIndex); PasswordList.Delete(lbPrList.ItemIndex); RemoteDirList.Delete(lbPrList.ItemIndex); LocalDirList.Delete(lbPrList.ItemIndex); lbPrList.Items.Delete(lbPrList.ItemIndex); edPrName.Clear; edPrHostName.Clear; edPrUserName.Clear; edPrRemDir.Clear; edPrLocDir.Clear; NoProfiles := lbPrList.Items.Count; lbPrList.Refresh; end; Reg.Free; end; procedure TfrmMain.bbtnLocateDefLocalDirClick (Sender: TObject); begin frmLocateDir := TfrmLocateDir.Create(Application); frmLocateDir.ShowModal; edDefLocalDir.Text := frmLocateDir.LocateDir; frmLocateDir.Free; end; procedure TfrmMain.bbtnLocateTxtEditorClick(Sender: TObject); begin frmLocateEditor := TfrmLocateEditor.Create (Application); frmLocateEditor.ShowModal; edDefTextEditor.Text := frmLocateEditor.EditorPath; frmLocateEditor.Free; end; procedure TfrmMain.BitBtn2Click(Sender: TObject); begin SaveOptions; end; end.
Не забудьте предварительно включить CsSocket и CsShopper в палитру компонентов. Поместите компонент CsShopper на главную форму. Создайте на форме кнопку для каждой команды FTP. Например, кнопка Connect вызывает процедуру
CsShopper1.Start:procedure TfrmMain.bbtnConnectClick(Sender: TObject); begin
if (not UsedQFtp) and (not UsedProfile) then begin
with CsShopper1 do
begin
HostName := HomeServer;
if Status = Success then
Start;
end;
end else
if UsedQFtp then
CsShopper1.Start
else
if UsedProfile then
begin
with CsShopper1 do
begin
UserName := edPrUserName.Text;
Password := edPrPassword.Text;
RemoteDir:= edPrRemDir.Text;
LocalDir := edPrLocDir.Text;
EditName := edDefTextEditor.Text;
HostName := edPrHostName.Text;
if Status = Success then
Start;
end;
end;
end;
Профили SHOPPER32
Перед тем как подключаться к FTP-серверу с помощью программы SHOPPER32, вы должны создать на вкладке Profiles некий «профиль», включающий имя FTP-сервера, а также пользовательское имя и пароль для регистрации (см. рис. 6.4).
Профили сохраняются в системном реестре Windows и извлекаются из него перед регистрацией, чтобы вам не пришлось всякий раз вводить информацию для доступа к FTP-серверу.
Чтобы добавить новый профиль, нажмите кнопку New; при этом стирается содержимое всех текстовых полей на вкладке Profiles. Затем введите имя профиля, имя FTP-сервера, имя пользователя и пароль в текстовых полях edPrName, edPrHostName, edPrUserName и edPrPassword соответственно. Для анонимной регистрации следует ввести в поле edPrUserName строку anonymous, а в поле edPrPassword — ваш адрес электронной почты.
Рис. 6.4. Типичный вид профиля на вкладке Profiles
Нажмите кнопку Add, чтобы внести профиль в список, и затем сохраните новые данные в реестре кнопкой Save. Если потребуется удалить профиль из реестра, выделите его имя в списке Profiles и нажмите кнопку Delete. Чтобы подключиться к FTP-серверу, щелкните на имени профиля в списке Profiles, перейдите на вкладку Connect и нажмите кнопку Connect. Существует и другой, более удобный способ — дважды щелкнуть на имени профиля в списке. При этом автоматически активизируется вкладка Connect, и на ней нажимается кнопка Connect, как показано в следующем фрагменте обработчика события OnDblClick для списка
lbPrList:procedure TfrmMain.lbPrListDblClick(Sender: TObject);
begin
UsedProfile := TRUE;
pcShopper.ActivePage := tsConnect; ActiveControl := bbtnConnect; bbtnConnect.Click;
end;
Чтобы процесс регистрации стал еще проще, мы сохраняем информацию о локальном и удаленном каталогах в текстовых полях edPrLocDir и edPrRemDir соответственно. CsShopper пользуется этой информацией для автоматиче ского, не требующего вмешательства пользователя, перехода к нужному каталогу.
Чтобы обратиться к редко используемому FTP-серверу, для которого нет смысла заводить специальный профиль, активизируйте кнопку Connect (на вкладке Connect) и щелкните на ней правой кнопкой мыши — на экране появится диалоговое окно Quick FTP. В нем следует ввести имя пользователя и пароль. Значения по умолчанию берутся с вкладки Options. Если они окажутся подходящими, вы сразу же начинаете сеанс работы кнопкой OK.
Замечание
Для получения доступа к некоторым FTP-серверам и выполнения некоторых FTP-команд (например, удаления каталога командой RMD) необходимо ввести информацию об используемом ресурсе (она посылается серверу командой ACCT). Если вы хотите работать с таким сервером, придется добавить на вкладку Profiles дополнительное текстовое поле и изменить компонент CsShopper для посылки команды ACCT с соответствующей информацией.
