我可以打开呢,给你贴上
(*
* The contents of this file are subject to the Mozilla Public
* License Version 1.1 (the "License"
; you may not use this file
* except in compliance with the License. You may obtain a copy of
* the License at http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS
* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
* implied. See the License for the specific language governing
* rights and limitations under the License.
*
* The Original Code is bt_ddftp.
*
* The Initial Developers of the Original Code is Michael Justin.
* Portions created The Initial Developer are Copyright (C) 1998-2003.
* All rights reserved.
*
* Contributor(s):
*
*)
{** BTDragDropFTP}
unit bt_ddftp;
interface
uses
Math, Windows, Messages, SysUtils, Classes, Controls, Menus, buttons,
Forms, Dialogs, StdCtrls, Extctrls, ComCtrls, wininet;
resourcestring
rsUploading = 'Uploading "%s"';
rsNewFolder = 'Create folder "%s"';
rsUploadStats = '%0:s%1:s at %2:s kb/sec. (remaining time: %3:s)';
rsConnectingTo = 'Connecting to %0:s as %1:s';
rsRemoteDir = 'Remote directory: %0:s';
rsConnectedTo = '%0:s connected to %1:s';
rsDisconnecting = 'Disconnecting from %0:s';
rsDisconnected = '%0:s disconnected from %1:s';
rsTransferringData = 'Transferring data for %0:s' ;
rsTransferCompleted = 'Transfer completed (%0:s bytes in %1:s files)';
rsFileDownloadDone = 'File download complete for "%0:s" (%1:s bytes)';
rsPutFile = 'put "%0:s"';
rsTransferType = 'Transfer type set to %0:s';
// confirmation
rscDeleteFolder = 'Delete folder "%0:s" ?';
rscDeleteFile = 'Delete File "%0:s" ?';
rscDeleteSelected = 'Delete %0:s selected items ?';
rscOverwriteLocal = 'Local file "%0:s" already exists, overwrite?';
// error messages
rseDeleteFile = 'Could not delete file "%0:s" (Win32 Error %1:s)';
rseDeleteFolder = 'Could not delete folder "%0:s" (Win32 Error %1:s)';
rseNoHost = 'No connection to host.';
rseCouldNotConnect = 'Could not connect to %0:s';
rseCouldNotRename = 'Could not rename "%0:s" (Win32 Error %1:s)';
rseCouldNotCWD = 'Could not change to directory %0:s';
// listview
rslName = 'Name';
rslSize = 'Size';
rslDate = 'Date';
rslType = 'Type';
// menu items
rsiOpen = 'Open';
rsiGet = 'Get';
rsiDelete = 'Delete';
rsiRename = 'Rename';
rsiNewFolder = 'New folder';
rsiView = 'View';
rsiLargeIcons = 'Large icons';
rsiSmallIcons = 'Small icons';
rsiList = 'List';
rsiDetails = 'Details';
rsiOrder = 'Order';
rsibyName = 'by Name';
rsibySize = 'by Size';
rsibyDate = 'by Date';
rsibyType = 'by Type';
rsiTransfertype = 'Transfer type';
rsiRefresh = 'Refresh';
rsiBack = 'Back';
// other messages
rsNotConnected = 'Not connected';
rsNoDirectory = 'Could not get current directory';
rsUploadComplete = 'Upload complete';
rsInProgress = 'File upload in progress!';
const
Revision = '$Revision: 4.10 $';
cAgentName = 'BTDragDropFTP';
// Listview column indices
ixSize = 0;
ixDate = 1;
ixType = 2;
type
TTransferType = (ttUnknown, ttASCII, ttBinary);
TftpOptions = (doAllowDelete,
doAllowDownload,
doAllowNewFolder,
doAllowRename,
doAllowUpload,
doDisplayProgress,
doShowHourglass,
doShowTransferType);
TdoOptions = set of TftpOptions;
TOrderBy = (sbName, sbDate, sbSize, sbType);
TDisplayMessageEvent = procedure(Sender: TObject;
const Messagetext: string;
const IsError: boolean) of object;
TGetLocalFileEvent = procedure(Sender: TObject;
const RemoteFilename: string;
var LocalFileName: string) of object;
TGetConfirmationEvent = procedure(Sender: TObject;
const Messagetext: string;
var Confirm: boolean) of object;
TDisplayProgressEvent = procedure(Sender: TObject;
const DoneSize, ToBeDoneSize, TotalSize: integer;
const BytesPerSecond: integer;
const RemoteFilename, LocalFileName: string) of object;
TLocalizeEvent = procedure(Sender: TObject;
const StrResult: string; var Format: string; const Args: array of const) of object;
{** Storage class for remote file objects }
TExtraFileData = class(TObject)
SizeInBytes: integer;
IsFolder: boolean;
IsLink: boolean;
LinkTarget: string;
function IsRoot(const Caption: string): boolean;
function CanDelete(const Caption: string): boolean;
function CanRename(const Caption: string): boolean;
end;
TAccessType = (atDirect, atNamedProxy);
TBTDragDropFTP = class;
{** FTP connection wrapper class }
TBTFTPConnection = class(TObject)
hConnect: HInternet;
BTDragDropFTP: TBTDragDropFTP;
AccessType: TAccessType;
TransferType: TTransferType;
DoneSize, ToBeDoneSize, BytesRead: integer;
StartTime,
LastTime: DWord;
BytesPSec: integer;
function ConnectTo(const HostName, LoginName, Password, RemoteDir: string;
const Passive: boolean; const Port: integer): boolean;
function Connected: boolean;
{** }
function PutFile(const Filename: string): boolean;
{** }
function PutFile2(const LocalFile, RemoteFile: string): boolean;
function GetFile(const RemoteFile, LocalFile: string;
const RemoteFilesize: integer): boolean;
function SetCurrentDirectory(const RemoteDir: string): boolean;
function GetCurrentDirectory: string;
function DeleteFile(const Filename: string): boolean;
function CreateDirectory(const DirName: string): boolean;
function RemoveDirectory(const Filename: string): boolean;
function RenameFile(const OldFile, Newfile: string): boolean;
procedure ShowProgress(const TotalFileSize: integer; LocalFile, RemoteFile: string);
procedure Disconnect;
constructor Create(ABTDragDropFTP: TBTDragDropFTP);
end;
{** Visual FTP client class }
TBTDragDropFTP = class(TPanel)
private
FConnection: TBTFTPConnection;
stateDesc,
nameDesc,
ageDesc,
sizeDesc: boolean;
OrderBy: TOrderBy;
ViewMenu, OrderMenu, TransferTypeMenu: TMenuItem;
FirstItem: integer;
FileCount: integer;
FActive: boolean;
FFTPOptions: TdoOptions;
FHostName: string;
FLoginName: string;
FPassive: boolean;
FPassword: string;
FPort: integer;
FProxyName: string;
FTransferType: TTransferType;
FUploading: boolean;
FUsedDiskSpace: Cardinal;
FOnChange: TNotifyEvent;
FOnConnect: TNotifyEvent;
FOnDisconnect: TNotifyEvent;
FOnDblClick: TNotifyEvent;
FOnDisplayMessage: TDisplayMessageEvent;
FOnGetConfirmation: TGetConfirmationEvent;
FOnGetLocalFilename: TGetLocalFileEvent;
FOnFTPTransferProgress: TDisplayProgressEvent;
FOnLocalize: TLocalizeEvent;
FCurrentRemoteDir: string;
FInitialRemoteDir: string;
UrlPanel: TPanel;
UrlEdit: TEdit;
LogSplitter: TSplitter;
LogWindow: TMemo;
FShowLogWindow: boolean;
FShowDirectory: boolean;
//--------------------------------------------------------------------------
// moved from public to private
//--------------------------------------------------------------------------
function ConnectTo(HostName, LoginName, Password: string): boolean;
function DeleteFile(const FileName: string): boolean;
function DeleteFolder(const FolderName: string): boolean;
function Localize(const Format: string; const Args: array of const): string;
function NewFolder(const DirName: string): boolean;
function Rename(const OldName, Newname: string): boolean;
function CanDownLoad: boolean;
property UsedDiskSpace: Cardinal read FUsedDiskSpace;
function FileName: string;
//--------------------------------------------------------------------------
procedure AddFile(lpFindFileData: TWin32FindData);
procedure Change; dynamic;
function Confirm(const Messagetext: string; const Args: array of const): boolean;
procedure BackOnClick(Sender: TObject);
procedure DeleteOnClick(Sender: TObject);
procedure MyOnURLPanelResize(Sender: TObject);
procedure MyListviewOnChange(Sender: TObject; Item: TListItem; Change: TItemChange);
procedure MyListViewOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure MyOnGetLocalFilename(Sender: TObject;
const RemoteFilename: string;
var LocalFileName: string);
procedure DoDblClick(Sender: TObject);
function ShowLastResponseInfo(const wait: boolean): boolean;
procedure MyPopupMenuOnPopup(Sender: TObject);
procedure MakeDirOnClick(Sender: TObject);
procedure RenameOnClick(Sender: TObject);
procedure SetActive(Value: boolean);
procedure SetFTPOptions(Value: TdoOptions);
procedure Log(const Messagetext: string; const Args: array of const);
procedure LogSimple(const Messagetext: string);
procedure DoShowErrorMessage(const Messagetext: string; const Args: array of const);
procedure WMDropFiles(var msg: TMessage); message WM_DROPFILES;
procedure ListViewCompare(Sender: TObject; Item1,
Item2: TListItem; Data: integer; var Compare: integer);
procedure ListViewColumnClick(Sender: TObject; Column: TListColumn);
procedure ListviewEdited(Sender: TObject; Item: TListItem; var S: string);
procedure UploadComplete;
procedure SetProxyName(const Value: string);
function GetRemoteDir: string;
procedure SetRemoteDir(const Value: string);
procedure SetShowLogWindow(const Value: boolean);
procedure SetTransferType(const Value: TTransferType);
function GetTransferType: TTransferType;
procedure SetTransferTypeASCII(Sender: TObject);
procedure SetTransferTypeBinary(Sender: TObject);
function GetVersion: string;
procedure SetVersion(const Value: string);
function VersionString: string;
procedure SetCurrentRemoteDir(const Value: string);
procedure SetShowDirectory(const Value: boolean);
property CurrentRemoteDir: string read FCurrentRemoteDir write SetCurrentRemoteDir;
public
ListView: TListView;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Loaded; override;
function Connect: boolean;
function Connected: boolean;
procedure Disconnect;
procedure OrderByName(Sender: TObject);
procedure OrderBySize(Sender: TObject);
procedure OrderByDate(Sender: TObject);
procedure OrderByType(Sender: TObject);
{** upload a file to a given remote file name (may include a directory name) }
function PutFile(const LocalFile, RemoteFile: string): boolean;
procedure RefreshFileList(Sender: TObject);
{** upload all files in the list to the current directory }
function Upload(Files: string; wait: boolean): boolean;
procedure ViewLargeIcons(Sender: TObject);
procedure ViewSmallIcons(Sender: TObject);
procedure ViewList(Sender: TObject);
procedure ViewReport(Sender: TObject);
property Connection: TBTFTPConnection read FConnection;
property Uploading: boolean read FUploading;
published
{** Enables drag and drop file upload }
property Active: boolean read FActive write SetActive;
{** FTP server name (example: ftp.server.com }
property HostName: string read FHostName write FHostName;
{** FTP account (user name) }
property LoginName: string read FLoginName write FLoginName;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnConnect: TNotifyEvent read FOnConnect write FOnConnect;
property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
property OnGetConfirmation: TGetConfirmationEvent
read FOnGetConfirmation write FOnGetConfirmation;
property OnDisplayMessage: TDisplayMessageEvent
read FOnDisplayMessage write FOnDisplayMessage;
property OnGetLocalFile: TGetLocalFileEvent
read FOnGetLocalFileName write FOnGetLocalFileName;
property OnDisplayProgress: TDisplayProgressEvent
read FOnFTPTransferProgress write FOnFTPTransferProgress;
property OnLocalize: TLocalizeEvent read FOnLocalize write FOnLocalize;
property FTPOptions: TdoOptions read FFTPOptions write SetFTPOptions;
property Passive: boolean read FPassive write FPassive;
property Password: string read FPassword write FPassword;
property Port: integer read FPort write FPort;
// property ProxyName: string read FProxyName write SetProxyName;
property RemoteDir: string read GetRemoteDir write SetRemoteDir;
property ShowLogWindow: boolean read FShowLogWindow write SetShowLogWindow;
property ShowDirectory: boolean read FShowDirectory write FShowDirectory;
property TransferType: TTransferType read GetTransferType write SetTransferType;
property Version: string read GetVersion write SetVersion stored false;
end;
{** Thread which handles a complete upload sequence }
TUploadThread = class(TThread)
BTDragDropFTP: TBTDragDropFTP;
UPhConnect: HInternet;
FFileList: TStringList;
constructor CreateFor(ABTDragDropFTP: TBTDragDropFTP; const Files: string);
function MyLogFunction(const FileName: string): boolean;
procedure UploadRecursive(const path: string);
procedure Execute; override;
end;
procedure Register;
implementation
uses Registry, ShellApi, FileCtrl;
procedure AddSlash(var Path: string);
begin
if Path[length(Path)] <> '/' then
Path := Path + '/';
end;
function GetTempPath: string;
var
Res: DWORD;
begin
SetLength(Result, MAX_PATH);
Res := windows.GetTempPath(MAX_PATH, PChar(Result));
SetLength(Result, Res);
AddSlash(Result);
end;
function GetFileType(const FileName: string; const isFolder: boolean): string;
var
TheKey, Ext: string;
begin
Result := '';
with TRegistry.Create do begin
RootKey := HKEY_CLASSES_ROOT;
Ext := ExtractFileExt(Filename);
if (OpenKey(Ext, False)) or IsFolder then begin
TheKey := ReadString('');
CloseKey;
if isFolder then
TheKey := 'Folder';
if OpenKey(TheKey, False) then
Result := ReadString('')
else
Result := '';
CloseKey;
end
else begin
system.Delete(Ext, 1, 1);
Result := UpperCase(Ext) + ' file';
end;
Free;
end;
end;
function GetIconIndex(const AFile: string; Attrs: DWORD): integer;
var
SFI: TSHFileInfo;
begin
SHGetFileInfo(PChar(AFile), Attrs, SFI, SizeOf(TSHFileInfo),
SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES);
Result := SFI.iIcon;
end;
{----------------------------------------------------------------------
----------------------------------------------------------------------}
function TExtraFileData.IsRoot;
begin
Result := IsFolder and (Caption = '..');
end;
function TExtraFileData.CanDelete;
begin
Result := not IsRoot(Caption);
end;
function TExtraFileData.CanRename;
begin
Result := not IsRoot(Caption);
end;
{----------------------------------------------------------------------
TUploadThread
----------------------------------------------------------------------}
constructor TUploadThread.CreateFor;
begin
Create(True);
FreeOnTerminate := True;
FFilelist := TStringList.Create;
FFilelist.Text := Files;
BTDragDropFTP := ABTDragDropFTP;
UPhConnect := BTDragDropFTP.Connection.hConnect;
end;
function TUploadThread.MyLogFunction;
begin
BTDragDropFTP.Log(rsUploading, [ExtractFileName(Filename)]);
if not BTDragDropFTP.Connection.PutFile(Filename) then
BTDragDropFTP.ShowLastResponseInfo(False);
Result := True; (* proceed with recursion *)
end;
procedure TUploadThread.UploadRecursive;
var
fullpath: string;
function Recurse(var path: string; const mask: string): boolean;
var
SRec: TSearchRec;
retval: integer;
oldlen: integer;
begin
Result := True;
oldlen := Length(path);
(* phase 1, look for normal files *)
retval := FindFirst(path + mask, faAnyFile, SRec);
while retval = 0 do begin
if (SRec.Attr and (faDirectory or faVolumeID)) = 0 then
(* we found a file, not a directory or volume label,
log it. Bail out if the log function returns false. *)
if not MyLogFunction(path + SRec.Name) then begin
Result := False;
Break;
end;
retval := FindNext(SRec);
end;
FindClose(SRec);
if not Result then Exit;
(* Phase II, look for subdirectories and recurse thru them *)
retval := FindFirst(path + '*.*', faDirectory, SRec);
while retval = 0 do begin
if (SRec.Attr and faDirectory) <> 0 then (* we have a directory *)
if (SRec.Name <> '.') and (SRec.Name <> '..') then begin
BTDragDropFTP.Log(rsNewFolder, [SRec.Name]);
BTDragDropFTP.Connection.CreateDirectory(SRec.Name);
BTDragDropFTP.Connection.SetCurrentDirectory(SRec.Name);
path := path + SRec.Name + '/';
if not Recurse(path, mask) then begin
Result := False;
Break;
end;
Delete(path, oldlen + 1, 255);
end;
retval := FindNext(SRec);
end;
FindClose(SRec);
BTDragDropFTP.Connection.SetCurrentDirectory('..');
end;
begin
if DirectoryExists(path) then begin
// it is a folder
if path = '' then
GetDir(0, fullpath)
else
fullpath := path;
BTDragDropFTP.Connection.CreateDirectory(ExtractFilename(Path));
BTDragDropFTP.Connection.SetCurrentDirectory(ExtractFilename(Path));
if fullpath[Length(fullpath)] <> '/' then
fullpath := fullpath + '/';
Recurse(fullpath, '*.*');
end
else begin
// it is a file
MyLogFunction(path);
end;
end;
procedure TUploadThread.Execute;
var
i: integer;
begin
for i := 0 to FFilelist.Count - 1 do
UploadRecursive(FFilelist
);
try
FFilelist.Free;
finally
Synchronize(BTDragDropFTP.UploadComplete);
end;
end;
{----------------------------------------------------------------------
TBTFTPConnection
this class manages all low level FTP procedure
----------------------------------------------------------------------}
constructor TBTFTPConnection.Create(ABTDragDropFTP: TBTDragDropFTP);
begin
inherited Create;
self.BTDragDropFTP := ABTDragDropFTP;
end;
function TBTFTPConnection.Connected;
begin
Result := Assigned(hConnect)
end;
function TBTFTPConnection.ConnectTo;
var
hSession: HInternet;
PassiveMode: integer;
begin
Result := False;
hSession := nil;
case AccessType of
atDirect:
begin
hSession := InternetOpen(cAgentName, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
end;
(*
atNamedProxy:
begin
hSession := InternetOpen('BTDragDropFTP', INTERNET_OPEN_TYPE_PROXY,
PChar(BTDragDropFTP.ProxyName), nil, 0);
end;
*)
end;
if Assigned(hSession) then begin
if Passive then
PassiveMode := INTERNET_FLAG_PASSIVE
else
PassiveMode := 0;
hConnect := InternetConnect(hSession,
PChar(Hostname),
Port,
PChar(LoginName),
PChar(Password),
INTERNET_SERVICE_FTP,
PassiveMode,
0);
if Connected and ((RemoteDir = '') or SetCurrentDirectory(RemoteDir)) then
Result := True;
end;
end;
function TBTFTPConnection.SetCurrentDirectory;
begin
Result := wininet.FtpSetCurrentDirectory(hConnect, PChar(RemoteDir));
end;
function TBTFTPConnection.GetCurrentDirectory: string;
var
lpszCurrentDirectory: PChar;
lpdwCurrentDirectory: DWORD;
begin
lpdwCurrentDirectory := INTERNET_MAX_PATH_LENGTH;
GetMem(lpszCurrentDirectory, lpdwCurrentDirectory - 1);
if wininet.FtpGetCurrentDirectory(hConnect,
lpszCurrentDirectory,
lpdwCurrentDirectory) then
Result := string(lpszCurrentDirectory);
FreeMem(lpszCurrentDirectory);
end;
function TBTFTPConnection.CreateDirectory;
begin
Result := wininet.FTPCreateDirectory(hConnect, PChar(DirName))
end;
procedure TBTFTPConnection.ShowProgress;
begin
try
DoneSize := DoneSize + BytesRead;
if DoneSize > TotalFileSize then
DoneSize := TotalFileSize;
ToBeDoneSize := TotalFileSize - DoneSize;
if ToBeDoneSize < 0 then
ToBeDoneSize := 0;
if (GetTickCount - LastTime > 1000) or (ToBeDoneSize = 0) then begin
if LastTime = StartTime then
LastTime := StartTime + 10
else
LastTime := GetTickCount;
BytesPSec := 1000 * Ceil(DoneSize / (LastTime - StartTime));
if Assigned(BTDragDropFTP.OnDisplayProgress) then
BTDragDropFTP.OnDisplayProgress(self, DoneSize, ToBeDoneSize,
TotalFileSize, BytesPSec, RemoteFile, LocalFile)
else if (TotalFileSize <> 0) and (BytesPSec <> 0) then
BTDragDropFTP.Log(rsUploadStats,
[IntToStr(Ceil(100 * DoneSize / TotalFileSize)),
'%',
FormatFloat('0.#', BytesPSec / 1024),
TimeToStr(Ceil(ToBeDoneSize / BytesPSec) / (24 * 60 * 60))]);
end;
except
// do nothing
end
end;
function TBTFTPConnection.GetFile;
var
MyInet: HInternet;
FBuffer: array[0..1023] of byte;
temp: DWord;
InFile: file;
intTransferType: integer;
begin
Result := False;
DoneSize := 0;
ToBeDoneSize := RemoteFilesize;
case TransferType of
ttASCII: intTransferType := FTP_TRANSFER_TYPE_ASCII;
ttBinary: intTransferType := FTP_TRANSFER_TYPE_BINARY;
else
intTransferType := FTP_TRANSFER_TYPE_UNKNOWN;
end;
MyInet := wininet.FtpOpenFile(hConnect, PChar(ExtractFileName(RemoteFile)),
GENERIC_READ, intTransferType, 0);
if MyInet = nil then
Exit;
try
AssignFile(InFile, LocalFile);
try
rewrite(InFile, 1);
if doShowHourglass in BTDragDropFTP.FTPOptions then
Screen.Cursor := crHourglass;
LastTime := GetTickCount;
StartTime := LastTime;
if InternetReadFile(myInet, @FBuffer, SizeOf(FBuffer), temp) and (temp > 0) then
repeat
Application.ProcessMessages;
blockwrite(InFile, FBuffer, temp);
if doDisplayProgress in BTDragDropFTP.FTPOptions then
ShowProgress(RemoteFileSize, LocalFile, RemoteFile);
InternetReadFile(myInet, @FBuffer, SizeOf(FBuffer), temp);
until temp = 0;
finally
CloseFile(InFile);
Result := True; // ToBeDoneSize = 0;
end;
finally
InternetCloseHandle(myinet);
end;
Screen.Cursor := crDefault;
end;
function TBTFTPConnection.PutFile;
var
MyInet: HInternet;
FBuffer: array[0..1023] of byte;
temp: DWord;
InFile: file;
RemoteFileName: string;
TotalSize: integer;
intTransferType: integer;
begin
Result := False;
RemoteFileName := ExtractFileName(FileName);
DoneSize := 0;
ToBeDoneSize := -1;
case TransferType of
ttASCII: intTransferType := FTP_TRANSFER_TYPE_ASCII;
ttBinary: intTransferType := FTP_TRANSFER_TYPE_BINARY;
else
intTransferType := FTP_TRANSFER_TYPE_UNKNOWN;
end;
MyInet := wininet.FtpOpenFile(hConnect, PChar(RemoteFileName), GENERIC_WRITE, intTransferType, 0);
if MyInet = nil then Exit;
try
AssignFile(InFile, FileName);
try
reset(InFile, 1);
if doShowHourglass in BTDragDropFTP.FTPOptions then
Screen.Cursor := crHourglass;
LastTime := GetTickCount;
StartTime := LastTime;
TotalSize := FileSize(InFile);
while not EOF(InFile) do begin
Application.ProcessMessages;
blockread(InFile, FBuffer, SizeOf(FBuffer), BytesRead);
InternetWriteFile(myInet, @FBuffer, BytesRead, temp);
if doDisplayProgress in BTDragDropFTP.FTPOptions then
ShowProgress(TotalSize, FileName, RemoteFileName);
end;
finally
CloseFile(InFile);
Result := True;
end
finally
InternetCloseHandle(myinet);
end;
Screen.Cursor := crDefault;
end;
function TBTFTPConnection.PutFile2;
var
MyInet: HInternet;
FBuffer: array[0..1023] of byte;
temp: DWord;
InFile: file;
TotalSize: integer;
intTransferType: integer;
begin
Result := False;
DoneSize := 0;
ToBeDoneSize := -1;
case TransferType of
ttASCII: intTransferType := FTP_TRANSFER_TYPE_ASCII;
ttBinary: intTransferType := FTP_TRANSFER_TYPE_BINARY;
else
intTransferType := FTP_TRANSFER_TYPE_UNKNOWN;
end;
MyInet := wininet.FtpOpenFile(hConnect, PChar(RemoteFile), GENERIC_WRITE, intTransferType, 0);
if MyInet = nil then Exit;
try
AssignFile(InFile, LocalFile);
try
reset(InFile, 1);
if doShowHourglass in BTDragDropFTP.FTPOptions then
Screen.Cursor := crHourglass;
LastTime := GetTickCount;
StartTime := LastTime;
TotalSize := FileSize(InFile);
while not EOF(InFile) do begin
Application.ProcessMessages;
blockread(InFile, FBuffer, SizeOf(FBuffer), BytesRead);
InternetWriteFile(myInet, @FBuffer, BytesRead, temp);
if doDisplayProgress in BTDragDropFTP.FTPOptions then
ShowProgress(TotalSize, LocalFile, RemoteFile);
end;
finally
CloseFile(InFile);
Result := True;
end
finally
InternetCloseHandle(myinet);
end;
Screen.Cursor := crDefault;
end;
function TBTFTPConnection.DeleteFile;
begin
Result := wininet.FTPDeleteFile(hConnect, PChar(Filename));
end;
function TBTFTPConnection.RenameFile;
begin
Result := wininet.FTPRenameFile(hConnect, PChar(OldFile), PChar(NewFile));
end;
function TBTFTPConnection.RemoveDirectory;
begin
Result := wininet.FTPRemoveDirectory(hConnect, PChar(Filename))
end;
procedure TBTFTPConnection.Disconnect;
begin
wininet.InternetCloseHandle(hConnect);
hConnect := nil;
end;
{----------------------------------------------------------------------
----------------------------------------------------------------------}
destructor TBTDragDropFTP.Destroy;
begin
if Connected then
Disconnect;
Connection.Free;
inherited;
end;
constructor TBTDragDropFTP.Create;
var
SysIL: THandle;
SysSIL: THandle;
SFI: TSHFileInfo;
begin
inherited; // Create(AOwner);
FConnection := TBTFTPConnection.Create(self);
FHostName := 'localhost';
FLoginName := 'anonymous';
FPort := INTERNET_DEFAULT_FTP_PORT;
FPassive := True;
parent := Owner as TWinControl;
if csDesigning in ComponentState then begin
Active := True;
TransferType := ttBinary;
Borderwidth := 3;
FFTPOptions := [doAllowDelete, doAllowDownload,
doAllowRename, doAllowNewFolder,
doAllowUpload, doShowHourglass, doDisplayProgress];
end;
URLEdit := TEdit.Create(self);
with URLEdit do begin
Text := '';
ReadOnly := true;
end;
URLPanel := TPanel.Create(self);
with URLPanel do begin
Parent := self;
Align := alTop;
Caption := '';
BevelOuter := bvNone;
BorderWidth := 3;
Height := (2*BorderWidth) + URLEdit.Height;
OnResize := MyOnURLPanelResize;
end;
URLEdit.Parent := URLPanel;
ListView := TListView.Create(self);
with ListView do begin
parent := self;
ReadOnly := False;
align := alClient;
viewstyle := vsReport;
MultiSelect := True;
OnMouseMove := self.OnMouseMove; //3.101
OnMouseDown := self.OnMouseDown; //3.101
OnMouseUp := self.OnMouseUp; //3.101
OnChange := MyListviewOnChange;
OnKeyUp := MyListViewOnKeyUp;
with Columns.Add do begin
Caption := rslName;
{#todo1 property }
Width := 150;
end;
with Columns.Add do begin
Caption := rslSize;
Width := 75;
Alignment := taRightJustify;
end;
with Columns.Add do begin
Caption := rslDate;
Width := 120
end;
with Columns.Add do begin
Caption := rslType;
Width := 200;
end;
LargeImages := TImageList.Create(self);
with LargeImages do begin
Width := 32;
Height := 32;
SysIL := SHGetFileInfo('', 0, SFI, SizeOf(SFI),
SHGFI_SYSICONINDEX or SHGFI_LARGEICON);
if SysIL <> 0 then begin
LargeImages.Handle := SysIL;
ShareImages := True;
end;
end;
SmallImages := TImageList.Create(self);
with SmallImages do begin
Width := 16;
Height := 16;
SysSIL := SHGetFileInfo('', 0, SFI, SizeOf(SFI),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
if SysSIL <> 0 then begin
SmallImages.Handle := SysSIL;
ShareImages := True;
end;
end;
end; // Listview
LogSplitter := TSplitter.Create(self);
LogSplitter.Parent := self;
LogSplitter.Align := alBottom;
LogSplitter.Height := 3;
LogSplitter.Beveled := False;
LogSplitter.Cursor := crVSplit;
LogSplitter.MinSize := 48;
LogWindow := TMemo.Create(self);
LogWindow.Parent := self;
LogWindow.Align := alBottom;
LogWindow.Height := 64;
LogWindow.ScrollBars := ssVertical;
ShowLogWindow := True;
ShowDirectory := True;
Height := 250;
Width := 250;
end;
procedure TBTDragDropFTP.MyPopupMenuOnPopup;
begin
if (ListView.Selected <> nil) and TExtraFileData(ListView.Selected.Data).IsFolder then
self.PopupMenu.items[FirstItem].Caption := Localize(rsiOpen, [])
else
self.PopupMenu.items[FirstItem].Caption := Localize(rsiGet, []);
// Don't "get" 'nil' or directories
self.PopupMenu.items[FirstItem].Enabled := (doAllowDownload in FFTPOptions)
and Connected and (ListView.Selected <> nil) and (ListView.SelCount = 1);
// Don't delete 'nil'
self.PopupMenu.items[FirstItem + 2].Enabled :=
(doAllowDelete in FFTPOptions) and Connected and (ListView.Selected <> nil) and
TExtraFileData(ListView.Selected.Data).CanDelete(ListView.Selected.Caption);
// don't rename 'nil'
self.PopupMenu.items[FirstItem + 3].Enabled :=
(doAllowRename in FFTPOptions) and Connected and (ListView.Selected <> nil) and
(ListView.SelCount = 1) and TExtraFileData(ListView.Selected.Data).CanRename
(ListView.Selected.Caption);
// New folder
PopupMenu.items[FirstItem + 4].Enabled := (doAllowNewFolder in FFTPOptions) and Connected;
// View
PopupMenu.items[FirstItem + 5].Enabled := Connected;
// Order
PopupMenu.items[FirstItem + 7].Enabled := Connected;
// Refresh
PopupMenu.items[FirstItem + 10].Enabled := Connected;
// Back
PopupMenu.items[FirstItem + 12].Enabled := Connected and (CurrentRemoteDir <> '/');
end;
procedure TBTDragDropFTP.MyOnGetLocalFilename(Sender: TObject;
const RemoteFilename: string;
var LocalFileName: string);
begin
with TSaveDialog.Create(self) do
try
FileName := RemoteFilename;
if Execute then
LocalFileName := FileName;
finally
Free;
end;
end;
procedure TBTDragDropFTP.SetShowLogWindow;
begin
if Value <> FShowLogWindow then begin
FShowLogWindow := Value;
LogWindow.Visible := Value;
LogSplitter.Visible := Value;
end;
end;
procedure TBTDragDropFTP.SetShowDirectory(const Value: boolean);
begin
if Value <> FShowDirectory then begin
FShowDirectory := Value;
URLPanel.Visible := Value;
end;
end;
procedure TBTDragDropFTP.Loaded;
procedure AddSeparator;
begin
PopupMenu.items.Add(TMenuItem.Create(self));
PopupMenu.items[PopupMenu.items.Count - 1].Caption := '-';
end;
procedure AddItem(const aCaption: string; aOnClick: TNotifyEvent);
begin
PopupMenu.items.Add(TMenuItem.Create(self));
with PopupMenu.items[PopupMenu.items.Count - 1] do begin
Caption := aCaption;
OnClick := aOnClick;
end;
end;
begin
inherited;
if not (csDesigning in ComponentState) then begin
if not Assigned(FOnGetLocalFilename) then
FOnGetLocalFilename := MyOnGetLocalFilename;
URLPanel.Visible := FShowDirectory;
// localize listview columns
ListView.Columns[0].Caption := Localize(rslName, []);
ListView.Columns[1].Caption := Localize(rslSize, []);
ListView.Columns[2].Caption := Localize(rslDate, []);
ListView.Columns[3].Caption := Localize(rslType, []);
// build popup menu
if not Assigned(PopupMenu) then
PopupMenu := TPopupMenu.Create(self);
FirstItem := PopupMenu.items.Count;
PopupMenu.OnPopup := MyPopupMenuOnPopup;
AddItem('assigned at runtime', DoDblClick);
PopupMenu.items[FirstItem].Default := True;
AddSeparator;
AddItem(Localize(rsiDelete, []), DeleteOnClick);
AddItem(Localize(rsiRename, []), RenameOnClick);
AddItem(Localize(rsiNewFolder, []), MakeDirOnClick);
ViewMenu := TMenuItem.Create(self);
PopupMenu.items.Add(ViewMenu);
with PopupMenu.items[PopupMenu.items.Count - 1] do begin
Caption := Localize(rsiView, []);
Add(TMenuItem.Create(self));
items[0].Caption := Localize(rsiLargeIcons, []);
items[0].RadioItem := True;
items[0].OnClick := ViewLargeIcons;
Add(TMenuItem.Create(self));
items[1].Caption := Localize(rsiSmallIcons, []);
items[1].RadioItem := True;
items[1].OnClick := ViewSmallIcons;
Add(TMenuItem.Create(self));
items[2].Caption := Localize(rsiList, []);
items[2].RadioItem := True;
items[2].OnClick := ViewList;
Add(TMenuItem.Create(self));
items[3].Caption := Localize(rsiDetails, []);
items[3].RadioItem := True;
items[3].OnClick := ViewReport;
items[3].Checked := True;
end;
AddSeparator;
OrderMenu := TMenuItem.Create(self);
PopupMenu.items.Add(OrderMenu);
with PopupMenu.items[PopupMenu.items.Count - 1] do begin
Caption := Localize(rsiOrder, []);
Add(TMenuItem.Create(self));
items[0].Caption := Localize(rsibyName, []);
items[0].RadioItem := True;
items[0].Checked := True;
items[0].OnClick := OrderByName;
Add(TMenuItem.Create(self));
items[1].Caption := Localize(rsibySize, []);
items[1].RadioItem := True;
items[1].OnClick := OrderBySize;
Add(TMenuItem.Create(self));
items[2].Caption := Localize(rsibyDate, []);
items[2].RadioItem := True;
items[2].OnClick := OrderByDate;
Add(TMenuItem.Create(self));
items[3].Caption := Localize(rsibyType, []);
items[3].RadioItem := True;
items[3].OnClick := OrderByType;
end;
AddSeparator;
// Transfer Type
TransferTypeMenu := TMenuItem.Create(self);
PopupMenu.items.Add(TransferTypeMenu);
with PopupMenu.items[PopupMenu.items.Count - 1] do begin
Visible := doShowTransferType in FTPOptions;
Caption := Localize(rsiTransfertype, []);
Add(TMenuItem.Create(self));
items[0].Caption := 'ASCII';
items[0].RadioItem := True;
items[0].OnClick := SetTransferTypeASCII;
Add(TMenuItem.Create(self));
items[1].Caption := 'Binary';
items[1].RadioItem := True;
items[1].Checked := True;
items[1].OnClick := SetTransferTypeBinary;
end;
AddItem(Localize(rsiRefresh, []), RefreshFileList);
AddSeparator;
AddItem(Localize(rsiBack, []), BackOnClick);
ListView.OnColumnClick := self.ListViewColumnClick;
ListView.OnCompare := self.ListViewCompare;
ListView.OnEdited := self.ListviewEdited;
ListView.OnClick := self.OnClick;
ListView.OnDblClick := self.DoDblClick;
LogSimple(rsNotConnected);
end;
end;
function TBTDragDropFTP.ShowLastResponseInfo;
var
lpdwError: dword;
lpszBuffer: PChar;
lpdwBufferLength: dword;
sl: TStringList;
begin
lpdwBufferLength := 256;
GetMem(lpszBuffer, lpdwBufferLength - 1);
Result := False;
if InternetGetLastResponseInfo(lpdwError, lpszBuffer, lpdwBufferLength) then begin
Result := True;
sl := TStringList.Create;
try
sl.Text := Trim(string(lpszBuffer));
if sl.Text <> '' then begin
DoShowErrorMessage(sl.Strings[sl.Count - 1], []);
if wait then
Sleep(200)
end;
finally
sl.Free;
end;
end
end;
procedure TBTDragDropFTP.RenameOnClick;
begin
if (ListView.Selected <> nil) then
ListView.Selected.EditCaption;
end;
function TBTDragDropFTP.DeleteFile;
begin
Result := False;
if Connection.DeleteFile(FileName) then begin
RefreshFileList(self);
Result := True;
end;
if not ShowLastResponseInfo(False) then
DoShowErrorMessage(rseDeleteFile, [FileName, IntToStr(GetLastError)]);
end;
function TBTDragDropFTP.DeleteFolder;
begin
Result := False;
if Connection.RemoveDirectory(FolderName) then begin
RefreshFileList(self);
Result := True;
end
else if not ShowLastResponseInfo(True) then
DoShowErrorMessage(rseDeleteFolder, [FolderName, IntToStr(GetLastError)])
end;
procedure TBTDragDropFTP.BackOnClick(Sender: TObject);
begin
Connection.SetCurrentDirectory('..');
RefreshFileList(self);
end;
procedure TBTDragDropFTP.DeleteOnClick;
var
i: integer;
FileName: string;
begin
if ListView.SelCount = 0 then
Exit;
FileName := ListView.Selected.Caption;
if (ListView.SelCount = 1) then begin
if TExtraFileData(ListView.Selected.Data).IsFolder then begin
if not Confirm(rscDeleteFolder, [FileName]) then
Exit;
end
else begin
if not Confirm(rscDeleteFile, [FileName]) then
Exit;
end;
end
else begin
if not Confirm(rscDeleteSelected, [IntToStr(ListView.SelCount)]) then
exit;
end;
for i := ListView.Selected.Index to ListView.Items.Count - 1 do
if ListView.Items.Selected then begin
FileName := ListView.Items.Caption;
if TExtraFileData(ListView.Items.Data).IsFolder then begin
if not Connection.RemoveDirectory(FileName) then
ShowLastResponseInfo(True);
end
else begin
Connection.DeleteFile(FileName);
end;
end;
RefreshFileList(self);
end;
function TBTDragDropFTP.NewFolder;
begin
Result := False;
if not Connected then
DoShowErrorMessage(rseNoHost, []);
if (not Connected) or (Trim(DirName) = '') then exit;
if Connection.CreateDirectory(DirName) then begin
RefreshFileList(self);
Result := True;
end
else
ShowLastResponseInfo(True);
end;
function TBTDragDropFTP.GetRemoteDir: string;
begin
Result := FInitialRemoteDir;
end;
procedure TBTDragDropFTP.SetRemoteDir(const Value: string);
begin
FInitialRemoteDir := Value;
end;
function TBTDragDropFTP.GetTransferType;
begin
Result := FTransferType;
end;
procedure TBTDragDropFTP.SetTransferType;
begin
FTransferType := Value;
Connection.TransferType := Value;
ShowLastResponseInfo(False);
end;
procedure TBTDragDropFTP.SetTransferTypeASCII;
begin
TransferType := ttASCII;
Log(rsTransferType, ['ASCII']);
end;
procedure TBTDragDropFTP.SetTransferTypeBinary;
begin
TransferType := ttBinary;
Log(rsTransferType, ['binary']);
end;
procedure TBTDragDropFTP.SetProxyName(const Value: string);
begin
FProxyName := Value;
if FProxyName = '' then
Connection.AccessType := atDirect
else
Connection.AccessType := atNamedProxy;
end;
procedure TBTDragDropFTP.MakeDirOnClick;
var
DirName: string;
begin
InputQuery('New folder', 'Folder name:', DirName);
NewFolder(DirName);
end;
function TBTDragDropFTP.ConnectTo;
begin
self.HostName := HostName;
self.LoginName := LoginName;
self.Password := Password;
Result := Connect;
end;
function TBTDragDropFTP.Connect;
var
aPassword: string;
begin
Result := False;
if Connected then Disconnect;
if HostName = '' then raise Exception.Create('HostName must be specified');
if LoginName = '' then raise Exception.Create('LoginName must be specified');
if Password = '' then begin
if not InputQuery('Login to ' + Hostname, 'Password for ' + Loginname, aPassword) then
exit;
// 3.107 !
Password := aPassword;
end;
Log(rsConnectingTo, [Hostname, Loginname]);
if RemoteDir <> '' then
Log(rsRemoteDir, [RemoteDir]);
if Connection.ConnectTo(HostName, LoginName, Password, RemoteDir, Passive, Port) then
begin
Result := True;
Log(rsConnectedTo, [Loginname, Hostname]);
if Assigned(FOnConnect) then
FOnConnect(Self);
RefreshFileList(self);
end
else begin
if not ShowLastResponseInfo(True) then
DoShowErrorMessage(rseCouldNotConnect, [HostName]);
Disconnect;
end;
end;
(* broken since IE 5 (additional result parameter not included in wininet.pas)
Sends commands directly to an FTP server.
BOOL FtpCommand(
HINTERNET hConnect,
BOOL fExpectResponse,
DWORD dwFlags,
LPCTSTR lpszCommand,
DWORD_PTR dwContext,
HINTERNET* phFtpCommand
);
Parameters
hConnect
[in] Handle returned from a call to InternetConnect.fExpectResponse
[in] Indicates whether or not the application expects a response from the FTP server. This must be set to TRUE if a response is expected, or FALSE otherwise.dwFlags
[in] Controls this function. This parameter can be set to one of the following values.
Value Meaning
FTP_TRANSFER_TYPE_ASCII Transfers the file using FTP's ASCII (Type A) transfer method. Control and formatting information is converted to local equivalents.
FTP_TRANSFER_TYPE_BINARY Transfers the file using FTP's Image (Type I) transfer method. The file is transferred exactly as it exists with no changes. This is the default transfer method.
lpszCommand
[in] Pointer to a string that contains the command to send to the FTP server.dwContext
[in] Pointer to a variable that contains an application-defined value that is used to identify the application context in callbacks.phFtpCommand
[out] Pointer to a handle that will be created if a valid data socket is opened. The fExpectResponse parameter must be set to TRUE for phFtpCommand to be filled.
Return Values
Returns TRUE if successful, or FALSE otherwise. To get a specific error message, call GetLastError.
Remarks
GetLastError can return ERROR_INTERNET_NO_DIRECT_ACCESS if the client application is offline. If one or more of the parameters are invalid, GetLastError will return ERROR_INVALID_PARAMETER.
Requirements
Windows NT/2000/XP: Included in Windows NT 4.0 or later.
Windows 95/98/Me: Included in Windows 95 or later.
Version: Requires Internet Explorer 5.0 or later.
Header: Declared in Wininet.h.
Library: Use Wininet.lib.
function TBTDragDropFTP.FTPCommand;
var
hOutConn: Cardinal;
begin
Result := False;
Log(Command);
try
Result := wininet.FtpCommand(Connection.hConnect, false, FTP_TRANSFER_TYPE_ASCII,
'cwd ..', 0);
if Result then
Log('Ok'); // RefreshFileList(self);
// ShowLastResponseInfo(False);
except
on e: Exception do
Log(e.message);
end;
end;
*)
function TBTDragDropFTP.Connected;
begin
Result := Connection.Connected;
end;
procedure TBTDragDropFTP.Disconnect;
begin
Log(rsDisconnecting, [Hostname]);
wininet.InternetCloseHandle(Connection.hConnect);
Connection.hConnect := nil;
ListView.items.Clear;
Log(rsDisconnected, [Loginname, Hostname]);
if Assigned(FOnDisconnect) then
FOnDisconnect(Self);
end;
procedure TBTDragDropFTP.AddFile(lpFindFileData: TWin32FindData);
var
Seconds, Minutes, Hours, Day, Month, Year: word;
Systemtime: TSystemtime;
extra: TExtraFileData;
cLinkTarget: array[0..259] of char;
Filesize: extended;
procedure FillExtraData;
var
i, Pos: integer;
begin
extra := TExtraFileData.Create;
Pos := StrLen(lpFindFileData.cFilename) + 1;
extra.isLink := (lpFindFileData.cFilename[Pos] = '-') and
(lpFindFileData.cFilename[Pos + 1] = '>') and
(lpFindFileData.cFilename[Pos + 2] = ' ') and
(lpFindFileData.cFilename[Pos + 3] <> #0);
if extra.islink then begin
for i := 0 to 259 - Pos - 3 do
cLinkTarget := lpFindFileData.cFilename[i + Pos + 3];
extra.LinkTarget := string(cLinkTarget);
end;
Extra.isFolder := ((lpFindFileData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) =
FILE_ATTRIBUTE_DIRECTORY) or extra.IsLink;
end;
begin
Application.ProcessMessages;
if string(lpFindFileData.cFilename) = '.' then
exit;
if string(lpFindFileData.cFilename) = '..' then
exit;
FillExtraData;
with Listview.items.add do begin
Data := extra;
if Extra.isFolder then begin
Caption := PChar(string(lpFindFileData.cFilename));
ImageIndex := GetIconIndex('.', FILE_ATTRIBUTE_NORMAL or FILE_ATTRIBUTE_DIRECTORY);
subitems.add('');
Extra.SizeInBytes := -1;
end else begin
Caption := lpFindFileData.cFilename;
Inc(FileCount);
ImageIndex := GetIconIndex(Caption, FILE_ATTRIBUTE_NORMAL);
Filesize := lpFindFileData.nFileSizeLow / 1024 + 0.0;
Extra.SizeInBytes := lpFindFileData.nFileSizeLow;
if Filesize < 1 then
Filesize := 1;
subitems.add(Format('%.0n', [Filesize]) + ' KB');
Inc(FUsedDiskSpace, lpFindFileData.nFileSizeLow);
end;
FileTimeToSystemTime(lpFindFileData.ftLastWriteTime, systemtime);
Day := systemtime.wDay;
Month := systemtime.wMonth;
Year := systemTime.wYear;
Seconds := systemTime.wSecond;
Minutes := systemTime.wMinute;
Hours := systemTime.wHour;
SubItems.Add(DateTimeToStr(EncodeDate(Year, Month, Day) +
EncodeTime(Hours, Minutes, Seconds, 0)));
SubItems.Add(GetFileType(lpFindFileData.cFilename, Extra.isFolder));
end;
end;
procedure TBTDragDropFTP.RefreshFileList;
var
lpFindFileData: TWin32FindData;
hFind: HInternet;
CurDirName: PAnsiChar;
leng: DWord;
begin
if not Connected then
Exit;
ListView.items.Clear;
FUsedDiskSpace := 0;
FileCount := 0;
GetMem(CurDirName, INTERNET_MAX_PATH_LENGTH + 1);
Leng := INTERNET_MAX_PATH_LENGTH;
if wininet.FtpGetCurrentDirectory(Connection.hConnect, CurDirName, Leng) then begin
CurrentRemoteDir := CurDirName;
Log(rsTransferringData, [CurDirName]);
LockWindowUpdate(ListView.handle);
ListView.items.Clear;
if CurDirName <> '/' then
with ListView.items.add do begin
Caption := '..';
ImageIndex := GetIconIndex('.', FILE_ATTRIBUTE_NORMAL or FILE_ATTRIBUTE_DIRECTORY);
SubItems.Add(''); // Size
SubItems.Add(''); // Date
SubItems.Add(''); // Type
Data := TExtraFileData.Create;
TExtraFileData(Data).IsFolder := True;
end;
hFind := wininet.FtpFindFirstFile(Connection.hConnect, nil, lpFindFileData,
INTERNET_FLAG_DONT_CACHE, 0);
if Assigned(hFind) then begin
if GetLastError <> ERROR_NO_MORE_FILES then begin
AddFile(lpFindFileData);
while InternetFindNextFile(hFind, @lpFindFileData) do
AddFile(lpFindFileData);
end;
InternetCloseHandle(hFind);
end;
Log(rsTransferCompleted, [FormatFloat('#,##0', UsedDiskSpace), IntToStr(FileCount)]);
ListView.SortType := stBoth;
LockWindowUpdate(0);
Change;
end
else begin // FtpGetCurrentDirectory failed
LogSimple(rsNoDirectory);
DisConnect;
end;
FreeMem(CurDirName);
end;
procedure TBTDragDropFTP.Change;
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
function TBTDragDropFTP.Confirm;
var
s : string;
begin
s := Localize(MessageText, Args);
if Assigned(FOnGetConfirmation) then
FOnGetConfirmation(self, s, Result)
else
Result := mrYes = MessageDlg(s, mtConfirmation, [mbYes, mbNo], 0);
end;
function TBTDragDropFTP.Rename;
begin
Result := False;
if Connection.RenameFile(OldName, NewName) then
with ListView.Selected do begin
Result := True;
Caption := NewName;
ImageIndex := GetIconIndex(NewName, FILE_ATTRIBUTE_NORMAL);
SubItems[ixType] := GetFileType(NewName, False);
end
else if not ShowLastResponseInfo(True) then
DoShowErrorMessage(rseCouldNotRename, [OldName, IntToStr(GetLastError)]);
end;
procedure TBTDragDropFTP.ListviewEdited;
begin
if (not (doAllowRename in FFTPOptions)) or (ListView.Selected.Caption = s) then
Exit;
Rename(ListView.Selected.Caption, s);
end;
// Upload folder
procedure TBTDragDropFTP.SetActive;
begin
if Value <> FActive then begin
FActive := Value;
if not (csDesigning in ComponentState) then DragAcceptFiles(Handle, Value);
end;
end;
procedure TBTDragDropFTP.SetCurrentRemoteDir;
begin
if Value <> FCurrentRemoteDir then begin
FCurrentRemoteDir := Value;
if FShowDirectory then
URLEdit.Text := Value;
end;
end;
procedure TBTDragDropFTP.SetFTPOptions;
begin
FFTPOptions := Value;
// upload allowed?
Active := doAllowUpload in FFTPOptions;
// Transfer Type menu visible?
if Assigned(TransferTypeMenu) then
TransferTypeMenu.Visible := doShowTransferType in FFTPOptions;
end;
procedure TBTDragDropFTP.WMDropFiles;
var
FileName: PChar;
Files: string;
i, Count, size, Drop: integer;
begin
if not (doAllowUpload in FFTPOptions) then
exit;
FileName := '';
Files := '';
Application.BringToFront;
Drop := msg.WParam;
Count := DragQueryFile(Drop, $FFFFFFFF, '', 0);
for i := 1 to Count do begin
size := DragQueryFile(Drop, i - 1, nil, 1);
GetMem(filename, size + 1);
DragQueryFile(Drop, i - 1, FileName, size + 1);
Files := Files + FileName + #13#10;
end;
DragFinish(Drop);
FreeMem(filename);
Upload(Files, False);
while Uploading do
Application.ProcessMessages;
end;
function TBTDragDropFTP.Localize(const Format: string; const Args: array of const): string;
var
f: string;
begin
result := '';
f := Format;
// allow to change the message format
if Assigned(FOnLocalize) then
FOnLocalize(self, result, f, Args);
FmtStr(result, f, Args);
end;
procedure TBTDragDropFTP.Log;
var
s: string;
begin
if csDestroying in ComponentState then
exit;
s := Localize(MessageText, Args);
if Assigned(FOnDisplayMessage) then
FOnDisplayMessage(self, s, False);
if Assigned(LogWindow) then
LogWindow.Lines.Add({DateTimeToStr(Now) + ' ' +} s);
end;
procedure TBTDragDropFTP.LogSimple;
begin
Log(MessageText, []);
end;
procedure TBTDragDropFTP.DoShowErrorMessage;
var
s : string;
begin
s := Localize(MessageText, Args);
if Assigned(FOnDisplayMessage) then
FOnDisplayMessage(self, s, True)
else
MessageDlg(s, mtError, [mbOK], 0);
end;
procedure TBTDragDropFTP.DoDblClick;
var
RemoteFile, LocalFileName: string;
begin
if (ListView.Selected <> nil) then begin
RemoteFile := ListView.Selected.Caption;
if not TExtraFileData(ListView.Selected.Data).IsFolder then begin
LocalFileName := '';
FOnGetLocalFileName(self, RemoteFile, LocalFileName);
if LocalFileName <> '' then begin
if FileExists(LocalFileName) and not Confirm(rscOverwriteLocal, [LocalFileName]) then
exit;
if Connection.GetFile(RemoteFile, LocalFileName,
TExtraFileData(ListView.Selected.Data).SizeInBytes) then
Log(rsFileDownloadDone,
[RemoteFile, IntToStr(TExtraFileData(ListView.Selected.Data).SizeInBytes)])
else
ShowLastResponseInfo(False);
end
end
else begin
{if TExtraFileData(ListView.Selected.Data).IsLink
then RemoteFile := TExtraFileData(ListView.Selected.Data).LinkTarget;}
if Connection.SetCurrentDirectory(RemoteFile) then
RefreshFileList(self)
else if not ShowLastResponseInfo(True) then
DoShowErrorMessage(rseCouldNotCWD, [RemoteFile]);
end;
end;
if Assigned(FOnDblClick) then
FOnDblClick(Sender)
end;
procedure TBTDragDropFTP.UploadComplete;
begin
FUploading := False;
DragAcceptFiles(Handle, Active);
LogSimple(rsUploadComplete);
RefreshFileList(self);
end;
function TBTDragDropFTP.CanDownload;
begin
if ListView.Selected <> nil then
Result := not TExtraFileData(ListView.Selected.Data).IsFolder
else
Result := False;
end;
function TBTDragDropFTP.FileName;
begin
if ListView.Selected <> nil then
Result := ListView.Selected.Caption
else
Result := '';
end;
(*
function TBTDragDropFTP.DragDropDownload;
var
RemoteFile, LocalFileName: string;
begin
Result := False;
if Uploading then begin
Log('File upload in progress!');
exit;
end;
if CanDownload then begin
RemoteFile := ListView.Selected.Caption;
LocalFileName := GetTempPath + RemoteFile;
Result := wininet.FTPGetFile(Connection.hConnect,
PChar(RemoteFile),
PChar(LocalFileName),
False, 0, 0, 0);
end;
end;
*)
function TBTDragDropFTP.PutFile(const LocalFile, RemoteFile: string): boolean;
begin
Result := False;
if Uploading then begin
LogSimple(rsInProgress);
exit;
end;
if not Connected then
Connect;
Log(rsPutFile, [RemoteFile]);
FUploading := True;
DragAcceptFiles(Handle, False);
Result := Connection.PutFile2(LocalFile, RemoteFile);
DragAcceptFiles(Handle, Active);
FUploading := False;
LogSimple(rsUploadComplete);
end;
function TBTDragDropFTP.Upload;
begin
Result := False;
if Uploading then begin
LogSimple(rsInProgress);
exit;
end;
if not Connected then
Connect;
FUploading := True;
DragAcceptFiles(Handle, False);
with TUploadThread.CreateFor(self, Files) do begin
Resume;
if Wait then
WaitFor;
end;
Result := True; // Thread started
end;
procedure TBTDragDropFTP.ViewLargeIcons;
begin
if not Connected then exit;
ListView.ViewStyle := vsIcon;
ViewMenu.items[0].Checked := True;
end;
procedure TBTDragDropFTP.ViewSmallIcons;
begin
if not Connected then exit;
ListView.ViewStyle := vsSmallIcon;
ViewMenu.items[1].Checked := True;
end;
procedure TBTDragDropFTP.ViewList;
begin
if not Connected then exit;
ListView.ViewStyle := vsList;
ViewMenu.items[2].Checked := True;
end;
procedure TBTDragDropFTP.ViewReport;
begin
if not Connected then exit;
ListView.ViewStyle := vsReport;
ViewMenu.items[3].Checked := True;
end;
procedure TBTDragDropFTP.OrderByName;
begin
if not Connected then exit;
OrderBy := sbName;
OrderMenu.items[0].Checked := True;
ListView.AlphaSort;
end;
procedure TBTDragDropFTP.OrderBySize;
begin
if not Connected then exit;
OrderBy := sbSize;
OrderMenu.items[1].Checked := True;
ListView.AlphaSort;
end;
procedure TBTDragDropFTP.OrderByDate;
begin
if not Connected then exit;
OrderBy := sbDate;
OrderMenu.items[2].Checked := True;
ListView.AlphaSort;
end;
procedure TBTDragDropFTP.OrderByType;
begin
if not Connected then exit;
OrderBy := sbType;
OrderMenu.items[3].Checked := True;
ListView.AlphaSort;
end;
procedure TBTDragDropFTP.ListViewCompare(Sender: TObject; Item1,
Item2: TListItem; Data: integer; var Compare: integer);
var
ci1, ci2: string;
desc: boolean;
begin
desc := False;
Compare := 0;
try
case OrderBy of
sbName:
begin
ci1 := UpperCase(Item1.Caption);
ci2 := UpperCase(Item2.Caption);
if TExtraFileData(Item1.Data).IsFolder then ci1 := ' ' + Item1.Caption;
if TExtraFileData(Item2.Data).IsFolder then ci2 := ' ' + Item2.Caption;
desc := nameDesc;
if ci1 < ci2 then
Compare := -1
else if ci1 > ci2 then
Compare := 1;
end;
sbDate:
begin
if (ixDate < Item1.Subitems.Count) and (ixDate < Item2.Subitems.Count) then
begin
ci1 := Item1.SubItems[ixDate];
ci2 := Item2.SubItems[ixDate];
desc := ageDesc;
if ci1 = '' then ci1 := DateToStr(0);
if ci2 = '' then ci2 := DateToStr(0);
if StrToDateTime(ci1) < StrToDateTime(ci2) then
Compare := -1
else if StrToDateTime(ci1) > StrToDateTime(ci2) then
Compare := 1;
end;
end;
sbSize:
begin
if TExtraFileData(Item1.Data).SizeInBytes <
TExtraFileData(Item2.Data).SizeInBytes then
Compare := -1
else if TExtraFileData(Item1.Data).SizeInBytes >
TExtraFileData(Item2.Data).SizeInBytes then
Compare := 1;
desc := sizeDesc;
end;
sbType:
begin
ci1 := Item1.SubItems[ixType];
ci2 := Item2.SubItems[ixType];
if Item1.SubItems[ixSize] = '' then ci1 := ' ' + Item1.Caption;
if Item2.SubItems[ixSize] = '' then ci2 := ' ' + Item2.Caption;
desc := stateDesc;
if ci1 < ci2 then
Compare := -1
else if ci1 > ci2 then
Compare := 1;
end;
end;
if desc then Compare := Compare * -1;
except
end;
end;
procedure TBTDragDropFTP.ListViewColumnClick(Sender: TObject;
Column: TListColumn);
begin
if Column.Caption = Localize(rslName, []) then begin
if OrderBy = sbName then
NameDesc := not NameDesc
else
OrderBy := sbName;
end;
if Column.Caption = Localize(rslDate, []) then begin
if OrderBy = sbDate then
ageDesc := not ageDesc
else
OrderBy := sbDate;
end;
if Column.Caption = Localize(rslSize, []) then begin
if OrderBy = sbSize then
sizeDesc := not sizeDesc
else
OrderBy := sbSize;
end;
if Column.Caption = Localize(rslType, []) then begin
if OrderBy = sbType then
stateDesc := not stateDesc
else
OrderBy := sbType;
end;
ListView.AlphaSort;
end;
function TBTDragDropFTP.GetVersion;
begin
Result := VersionString;
end;
procedure TBTDragDropFTP.SetVersion;
begin
// ;
end;
function TBTDragDropFTP.VersionString;
begin
Result := Copy(Revision, 12, Length(Revision) - 12);
end;
procedure TBTDragDropFTP.MyOnURLPanelResize;
begin
URLEdit.Width := URLPanel.Width;
end;
procedure TBTDragDropFTP.MyListviewOnChange;
begin
if Change = ctState then begin
if CurrentRemoteDir = '/' then
URLEdit.Text := CurrentRemoteDir + Item.Caption
else
URLEdit.Text := CurrentRemoteDir + '/' + Item.Caption
end
end;
procedure TBTDragDropFTP.MyListViewOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if not Connected then
exit;
case Key of
VK_DELETE: DeleteOnClick(self);
VK_F2: RenameOnClick(self);
VK_F5: RefreshFileList(self);
end;
end;
procedure Register;
begin
RegisterComponents('BetaTools', [TBTDragDropFTP]);
end;
end.
]