© BigSpeed Computing Inc. - Secure private networking
// *** Delphi example of secure file sharing client ***
unit uMain;
interface
uses
ActiveX, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ShlObj, StdCtrls, ComCtrls, ToolWin, Menus, ActnList, ImgList, StrUtils, Contnrs,
ExtCtrls, Registry, Variants, ShellAPI, Buttons, IniFiles, uInpBox2,
bsFileClnLib_tlb;
type
TFileObj = class
Folder: Boolean;
Size: Int64;
ModTime: TFileTime;
ListItem: TListItem;
end;
TfMain = class(TForm)
StatusBar: TStatusBar;
dlgOpen: TOpenDialog;
Timer1: TTimer;
GroupBox2: TGroupBox;
lvFiles: TListView;
pnlFolder: TPanel;
btnDownload: TButton;
btnUpload: TButton;
btnRename: TButton;
btnDelete: TButton;
btnNew: TButton;
btnIn: TButton;
btnUp: TButton;
btnOpenStream: TButton;
CoolBar1: TCoolBar;
ToolBar1: TToolBar;
btnConnect: TToolButton;
btnDisconnect: TToolButton;
grpDownload: TGroupBox;
GroupBox4: TGroupBox;
pnlDownFile: TPanel;
pnlDownInfo: TPanel;
btnAbortDownload: TButton;
grpUpload: TGroupBox;
pnlUpFile: TPanel;
pnlUpInfo: TPanel;
btnAbortUpload: TButton;
lbStream: TListBox;
btnCloseStream: TButton;
pnlStream: TPanel;
btnSeek: TButton;
ToolButton3: TToolButton;
btnMyIP: TToolButton;
btnAbout: TToolButton;
btnExit: TToolButton;
btnCancel: TToolButton;
ilFiles: TImageList;
btnList: TButton;
btnUnzip: TButton;
btnZip: TButton;
btnSearch: TButton;
GroupBox5: TGroupBox;
pnlFindInfo: TPanel;
btnStopSearch: TButton;
grpZip: TGroupBox;
pnlZipFile: TPanel;
pnlZipInfo: TPanel;
btnAbortZip: TButton;
grpUnzip: TGroupBox;
pnlUnzipFile: TPanel;
pnlUnzipInfo: TPanel;
btnAbortUnzip: TButton;
dlgSave: TSaveDialog;
lvFind: TListView;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnExitClick(Sender: TObject);
procedure btnAboutClick(Sender: TObject);
procedure btnMyIPClick(Sender: TObject);
procedure lvClientsChange(Sender: TObject; Item: TListItem; Change: TItemChange);
procedure btnConnectClick(Sender: TObject);
procedure btnCancelClick(Sender: TObject);
procedure btnDisconnectClick(Sender: TObject);
procedure lvFilesCompare(Sender: TObject; Item1, Item2: TListItem;
Data: Integer; var Compare: Integer);
procedure lvFilesColumnClick(Sender: TObject; Column: TListColumn);
procedure lvFilesChange(Sender: TObject; Item: TListItem;
Change: TItemChange);
procedure btnInClick(Sender: TObject);
procedure btnUpClick(Sender: TObject);
procedure lvFilesDblClick(Sender: TObject);
procedure btnListClick(Sender: TObject);
procedure btnNewClick(Sender: TObject);
procedure btnRenameClick(Sender: TObject);
procedure btnDeleteClick(Sender: TObject);
procedure btnDownloadClick(Sender: TObject);
procedure btnAbortDownloadClick(Sender: TObject);
procedure btnUploadClick(Sender: TObject);
procedure btnAbortUploadClick(Sender: TObject);
procedure btnZipClick(Sender: TObject);
procedure btnAbortZipClick(Sender: TObject);
procedure btnUnzipClick(Sender: TObject);
procedure btnAbortUnzipClick(Sender: TObject);
procedure btnSearchClick(Sender: TObject);
procedure btnStopSearchClick(Sender: TObject);
procedure btnOpenStreamClick(Sender: TObject);
procedure btnCloseStreamClick(Sender: TObject);
procedure btnSeekClick(Sender: TObject);
private
{ Private declarations }
FileList: TObjectList;
FileCln: TBSFileClnX;
SortCol: Integer;
DescSortOrder: Boolean;
NowList, NowCreateFolder, NowDeleteFolder, NowDeleteFile, NowRenameFolder, NowRenameFile: Boolean;
NowDownload, NowUpload, NowOpen, NowClose, NowSeek, NowRead, NowZip, NowUnzip, NowSearch: Boolean;
StreamName, UpldFol, ZipFol, UnzipFol: String;
procedure LoadForm;
procedure SaveForm;
procedure CheckError(aCode: Integer);
procedure UpdateStatus;
procedure UpdateButtons;
function GetUsername: WideString;
procedure GoUpFolder;
procedure GoInFolder(aName: String);
procedure ListFolder;
//Event handlers
procedure doConnected(Sender: TObject);
procedure doClosed(Sender: TObject);
procedure doDisconnected(Sender: TObject);
procedure doKeyChanged(Sender: TObject);
procedure doSigninDone(Sender: TObject; aCode: Integer);
procedure doHaveListItem(Sender: TObject; const aName: WideString; aFolder:WordBool; aSizeLo, aSizeHi, aTimeLo, aTimeHi: Integer);
// procedure TForm1.BSFileClnX1HaveListItem(ASender: TObject; const aName: WideString; aFolder: WordBool; aSizeLo, aSizeHi, aTimeLo,
// aTimeHi: Integer);
procedure doListDone(Sender: TObject; aCode: Integer);
procedure doCreateFolderDone(Sender: TObject; aCode: Integer);
procedure doDeleteFolderDone(Sender: TObject; aCode: Integer);
procedure doDeleteFileDone(Sender: TObject; aCode: Integer);
procedure doRenameFolderDone(Sender: TObject; aCode: Integer);
procedure doRenameFileDone(Sender: TObject; aCode: Integer);
procedure doDownloadProgress(Sender: TObject; aLoCount, aHiCount, aLoSize, aHiSize: Integer);
procedure doDownloadDone(Sender: TObject; aCode: Integer);
procedure doUploadProgress(Sender: TObject; aLoCount, aHiCount, aLoSize, aHiSize: Integer);
procedure doUploadDone(Sender: TObject; aCode: Integer);
procedure doZipDone(Sender: TObject; aCode: Integer);
procedure doZipProgress(Sender: TObject; aFileCount, aFileTotal, aLoByteCount, aHiByteCount, aLoByteTotal, aHiByteTotal: Integer);
procedure doUnzipDone(Sender: TObject; aCode: Integer);
procedure doUnzipProgress(Sender: TObject; aFileCount, aFileTotal, aLoByteCount, aHiByteCount, aLoByteTotal, aHiByteTotal: Integer);
procedure doSearchDone(Sender: TObject; aCode: Integer);
procedure doHaveFindFile(Sender: TObject; const aName: WideString; aSizeLo, aSizeHi, aTimeLo, aTimeHi: Integer);
procedure doSearchProgress(Sender: TObject; aCount: Integer);
procedure doOpenDone(Sender: TObject; aCode: Integer);
procedure doCloseDone(Sender: TObject; aCode: Integer);
procedure doStreamSizeDone(Sender: TObject; aCode, aSizeLo, aSizeHi: Integer);
procedure doStreamPositionDone(Sender: TObject; aCode, aPosLo, aPosHi: Integer);
procedure doSeekDone(Sender: TObject; aCode: Integer);
procedure doReadDone(Sender: TObject; aCode: Integer; var aBlock: OleVariant);
public
{ Public declarations }
end;
var
fMain: TfMain;
siiFolder: Integer;
implementation
uses uAbout, uSettings, uAdd, uConnect;
{$R *.DFM}
const
SETTINGS_INI = 'bsfilecln.ini';
// *** Misc functions
//Format size number
function SizeStr(aSize: Int64): String;
var
i,j: Integer;
S: String;
begin
Result := '';
S := IntToStr(aSize);
i := Length(S);
j := 3;
while i > 0 do
begin
if j = 0 then
begin
Result := ',' + Result;
j := 3;
end;
Result := S[i] + Result;
dec(i);
dec(j);
end;
end;
function Make64(aLo, aHi: Integer): Int64;
begin
Result := aHi;
Result := Result shl 32;
Result := Result + Cardinal(aLo);
end;
function FileTimeToDateTime(FileTime: TFileTime): TDateTime;
var
ModifiedTime: TFileTime;
SystemTime: TSystemTime;
begin
Result := 0;
if (FileTime.dwLowDateTime = 0) and (FileTime.dwHighDateTime = 0) then Exit;
try
FileTimeToLocalFileTime(FileTime, ModifiedTime);
FileTimeToSystemTime(ModifiedTime, SystemTime);
Result := SystemTimeToDateTime(SystemTime);
except
Result := Now; // Something to return in case of error
end;
end;
function FileTimeToText(aFileTime: TFileTime): String;
begin
Result := '';
if (aFileTime.dwLowDateTime = 0) and (aFileTime.dwHighDateTime = 0) then Exit;
try
Result := DateTimeToStr(FileTimeToDateTime(aFileTime));
except
Result := '';
end;
end;
//Add a trailing slash
function AddSlash(aPath: String): String;
begin
Result := aPath;
if RightStr(Result, 1) = '\' then Exit;
Result := Result + '\';
end;
//Remove the trailing slash
function SlashOff(aPath: String): String;
begin
Result := aPath;
if RightStr(Result, 1) <> '\' then Exit;
Delete(Result, Length(Result), 1);
end;
//Insert a leading slash
function PreSlash(aPath: String): String;
begin
Result := aPath;
if LeftStr(Result, 1) = '\' then Exit;
Result := '\' + Result;
end;
function GetFolderCallBack(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;
var
wa, rect : TRect;
dialogPT : TPoint;
begin
//center in work area
if uMsg = BFFM_INITIALIZED then
begin
wa := Screen.WorkAreaRect;
GetWindowRect(Wnd, Rect);
dialogPT.X := ((wa.Right-wa.Left) div 2) -
((rect.Right-rect.Left) div 2);
dialogPT.Y := ((wa.Bottom-wa.Top) div 2) -
((rect.Bottom-rect.Top) div 2);
MoveWindow(Wnd,
dialogPT.X,
dialogPT.Y,
Rect.Right - Rect.Left,
Rect.Bottom - Rect.Top,
True);
SendMessage(Wnd,BFFM_SETSELECTION,1, lpData);
end;
Result := 0;
end;
//Browse for folder dialog
function GetFolder(aInitial: String): String;
var
lpItemID : PItemIDList;
BrowseInfo : TBrowseInfo;
DisplayName : array[0..MAX_PATH] of char;
TempPath : array[0..MAX_PATH] of char;
begin
Result := '';
if aInitial = '' then
StrPCopy(TempPath, GetCurrentDir)
else
StrPCopy(TempPath, aInitial);
FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
with BrowseInfo do begin
hwndOwner := Application.Handle;
pszDisplayName := @DisplayName;
lpszTitle := 'Choose a folder:';
ulFlags := BIF_RETURNONLYFSDIRS or BIF_NEWDIALOGSTYLE;
lpfn := GetFolderCallBack;
LParam := Integer(@TempPath);
end;
lpItemID := SHBrowseForFolder(BrowseInfo);
if lpItemId <> nil then
begin
SHGetPathFromIDList(lpItemID, TempPath);
Result := TempPath;
GlobalFreePtr(lpItemID);
end;
end;
// *** General
procedure TfMain.FormCreate(Sender: TObject);
var
SysIL: uint;
SFI: TSHFileInfo;
begin
FileList := TObjectList.Create;
LoadForm;
SysIL := SHGetFileInfo('', 0, SFI, SizeOf(SFI), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
if SysIL <> 0 then begin
ilFiles.Handle := SysIL;
ilFiles.ShareImages := TRUE; // DON'T FREE THE SYSTEM IMAGE LIST!!!!! BAD IDEA (tm)!
end;
SHGetFileInfo('', FILE_ATTRIBUTE_NORMAL or FILE_ATTRIBUTE_DIRECTORY, SFI, SizeOf(TSHFileInfo), SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES);
siiFolder := SFI.iIcon;
try
FileCln := TBSFileClnX.Create(Self);
FileCln.Parent := Self;
FileCln.OnConnected := doConnected;
FileCln.OnClosed := doClosed;
FileCln.OnDisconnected := doDisconnected;
FileCln.OnKeyChanged := doKeyChanged;
FileCln.OnSigninDone := doSigninDone;
FileCln.OnHaveListItem := doHaveListItem;
FileCln.OnListFolderDone := doListDone;
FileCln.OnCreateFolderDone := doCreateFolderDone;
FileCln.OnDeleteFolderDone := doDeleteFolderDone;
FileCln.OnDeleteFileDone := doDeleteFileDone;
FileCln.OnRenameFolderDone := doRenameFolderDone;
FileCln.OnRenameFileDone := doRenameFileDone;
FileCln.OnDownloadProgress := doDownloadProgress;
FileCln.OnDownloadDone := doDownloadDone;
FileCln.OnUploadProgress := doUploadProgress;
FileCln.OnUploadDone := doUploadDone;
FileCln.OnOpenStreamDone := doOpenDone;
FileCln.OnCloseStreamDone := doCloseDone;
FileCln.OnStreamSizeDone := doStreamSizeDone;
FileCln.OnStreamPositionDone := doStreamPositionDone;
FileCln.OnSeekStreamDone := doSeekDone;
FileCln.OnReadStreamDone := doReadDone;
FileCln.OnZipDone := doZipDone;
FileCln.OnZipProgress := doZipProgress;
FileCln.OnUnzipDone := doUnzipDone;
FileCln.OnUnzipProgress := doUnzipProgress;
FileCln.OnSearchDone := doSearchDone;
FileCln.OnHaveFindFile := doHaveFindFile;
FileCln.OnSearchProgress := doSearchProgress;
UpdateStatus;
except
MessageDlg('BigSpeed Socket Library control is not registered on your system!', mtError, [mbOk], 0);
Halt;
end;
end;
procedure TfMain.FormDestroy(Sender: TObject);
begin
SaveForm;
FileList.Free;
end;
procedure TfMain.LoadForm;
var
Ini: TIniFile;
begin
try
Ini := TIniFile.Create(ExtractFilePath(Application.ExeName) + SETTINGS_INI);
except
Ini := nil;
end;
if Ini = nil then Exit;
try
with Ini do
begin
Left := ReadInteger('Last', 'Left', Left);
Top := ReadInteger('Last', 'Top', Top);
end;
finally
Ini.Free;
end;
end;
procedure TfMain.SaveForm;
var
Ini: TIniFile;
begin
try
Ini := TIniFile.Create(ExtractFilePath(Application.ExeName) + SETTINGS_INI);
except
Ini := nil;
end;
if Ini = nil then Exit;
try
with Ini do
begin
WriteInteger('Last', 'Left', Left);
WriteInteger('Last', 'Top', Top);
end;
finally
Ini.Free;
end;
end;
//Descibe an error
function ErrorText(aCode: Integer): String;
begin
Result := '';
if aCode = 0 then Exit;
case aCode of
2: Result := 'Illegal operation';
100: Result := 'Wrong CRC';
101: Result := 'Broken connection';
102: Result := 'Not connected';
103: Result := 'Failed sign-in';
200: Result := 'User break (client)';
201: Result := 'Invalid handle (client)';
202: Result := 'Client is not signed in';
203: Result := 'There is no assigned event handler (client)';
204: Result := 'There is an error in the event handler (client)';
205: Result := 'Operation is already in progress (client)';
206: Result := 'Cannot get file information (client)';
207: Result := 'Cannot create folder (client)';
208: Result := 'Cannot delete folder (client)';
209: Result := 'Cannot delete file (client)';
210: Result := 'Cannot rename folder (client)';
211: Result := 'Cannot rename file (client)';
212: Result := 'Cannot open file (client)';
213: Result := 'Cannot create file (client)';
214: Result := 'Cannot read from file (client)';
215: Result := 'Cannot write to file (client)';
216: Result := 'Cannot rename temporary file (client)';
300: Result := 'Cannot start server';
301: Result := 'Access denied';
302: Result := 'User break (server)';
303: Result := 'Invalid handle (server)';
304: Result := 'User is not signed';
305: Result := 'There is no assigned event handler (server)';
306: Result := 'There is an error in the event handler (server)';
307: Result := 'Operation is already in progress (server)';
308: Result := 'Cannot get file information (server)';
309: Result := 'Cannot create folder (server)';
310: Result := 'Cannot delete folder (server)';
311: Result := 'Cannot delete file (server)';
312: Result := 'Cannot rename folder (server)';
313: Result := 'Cannot rename file (server)';
314: Result := 'Cannot open file (server)';
315: Result := 'Cannot create file (server)';
316: Result := 'Cannot read from file (server)';
317: Result := 'Cannot write to file (server)';
318: Result := 'Cannot rename temporary file (server)';
else
Result := 'Unknown error';
end;
end;
//Display an error message, if any
procedure TfMain.CheckError(aCode: Integer);
begin
if aCode = 0 then Exit;
MessageBox(Handle, PChar(ErrorText(aCode)), 'Error', MB_OK or MB_ICONERROR);
end;
//Update status text
procedure TfMain.UpdateStatus;
begin
if FileCln.Connected then
begin
//already connected
btnConnect.Enabled := False;
btnCancel.Enabled := False;
btnDisconnect.Enabled := True;
if FileCln.WrongKey then
StatusBar.Panels[0].Text := ' Wrong key'
else
StatusBar.Panels[0].Text := ' Connected';
StatusBar.Panels[1].Text := ' ' + FileCln.ServerAddress + ':' + FileCln.ServerPort;
if FileCln.Signedin then
StatusBar.Panels[2].Text := ' User: ' + GetUsername
else
StatusBar.Panels[2].Text := ' User: not signed in';
end
else
begin
StatusBar.Panels[1].Text := '';
StatusBar.Panels[2].Text := '';
if FileCln.Connecting then
begin
//now connecting
btnConnect.Enabled := False;
btnCancel.Enabled := True;
btnDisconnect.Enabled := False;
StatusBar.Panels[0].Text := ' Connecting';
end
else
begin
//not connected
btnConnect.Enabled := True;
btnCancel.Enabled := False;
btnDisconnect.Enabled := False;
StatusBar.Panels[0].Text := ' Disconnected';
end;
end;
UpdateButtons;
end;
//Update button state
procedure TfMain.UpdateButtons;
var
FiEx: String;
begin
btnIn.Enabled := False;
btnUp.Enabled := False;
btnNew.Enabled := False;
btnList.Enabled := False;
btnDownload.Enabled := False;
btnUpload.Enabled := False;
btnRename.Enabled := False;
btnDelete.Enabled := False;
btnZip.Enabled := False;
btnUnzip.Enabled := False;
btnSearch.Enabled := False;
btnOpenStream.Enabled := False;
btnAbortDownload.Enabled := NowDownload;
btnAbortUpload.Enabled := NowUpload;
btnAbortZip.Enabled := NowZip;
btnAbortUnzip.Enabled := NowUnzip;
btnStopSearch.Enabled := NowSearch;
btnSeek.Enabled := StreamName > '';
btnCloseStream.Enabled := StreamName > '';
if not lvFiles.Enabled then Exit;
btnUp.Enabled := pnlFolder.Caption > '\';
btnNew.Enabled := not NowCreateFolder;
btnList.Enabled := not NowList;
btnUpload.Enabled := not NowUpload;
btnSearch.Enabled := not NowSearch;
if lvFiles.SelCount > 0 then
begin
btnIn.Enabled := (lvFiles.Selected.ImageIndex = siiFolder) and not NowList;
if lvFiles.Selected.ImageIndex = siiFolder then
begin
//folder
btnRename.Enabled := not NowRenameFolder;
btnDelete.Enabled := not NowDeleteFolder;
end
else
begin
//file
FiEx := ExtractFileExt(lvFiles.Selected.Caption);
btnDownload.Enabled := not NowDownload;
btnRename.Enabled := not NowRenameFolder;
btnDelete.Enabled := not NowDeleteFolder;
btnZip.Enabled := FiEx <> '.zip';
btnUnzip.Enabled := FiEx = '.zip';
btnOpenStream.Enabled := not NowOpen and (StreamName = '');
end;
end;
end;
//Get readable user name
function TfMain.GetUsername: WideString;
begin
Result := FileCln.Username;
if Result > '' then Exit;
Result := 'Default';
end;
//Go to the upper folder
procedure TfMain.GoUpFolder;
var
S: String;
p: Integer;
begin
S := SlashOff(pnlFolder.Caption);
if S = '' then Exit; //nothing to do
p := Length(S);
while p > 0 do
begin
if S[p] = '\' then Break;
Dec(p);
end;
pnlFolder.Caption := PreSlash(LeftStr(S, p-1));
ListFolder;
end;
procedure TfMain.GoInFolder(aName: String);
begin
pnlFolder.Caption := AddSlash(pnlFolder.Caption) + aName;
ListFolder;
end;
//Request the folder contents
procedure TfMain.ListFolder;
begin
if NowList then Exit;
if FileCln.ListFolder(pnlFolder.Caption) then
begin
NowList := True;
FileList.Clear;
lvFiles.Items.BeginUpdate;
lvFiles.Clear;
btnList.Enabled := False;
if pnlFolder.Caption > '\' then
doHaveListItem(Self, '..', True, 0, 0, 0, 0);
end
else
CheckError(FileCln.LastError);
end;
// *** Event handlers
//Just connected
procedure TfMain.doConnected(Sender: TObject);
begin
lvFiles.Enabled := True;
pnlFolder.Caption := '\';
UpdateStatus;
FileCln.SignIn(Trim(fConnect.edUsername.Text), Trim(fConnect.edPassword.Text));
end;
//Unsuccessful call
procedure TfMain.doClosed(Sender: TObject);
begin
ShowMessage('Cannot connect to ' + fConnect.edHost.Text + ':' + fConnect.edPort.Text);
UpdateStatus;
end;
//Just disconnected
procedure TfMain.doDisconnected(Sender: TObject);
begin
lvFiles.Enabled := False;
pnlFolder.Caption := '';
lvFiles.Clear;
UpdateStatus;
end;
//Key matching is changed
procedure TfMain.doKeyChanged(Sender: TObject);
begin
UpdateStatus;
end;
//An user is signed-in
procedure TfMain.doSigninDone(Sender: TObject; aCode: Integer);
begin
UpdateStatus;
if aCode = 0 then
ListFolder //success
else
CheckError(aCode) ; //failed
end;
//Terminate the application
procedure TfMain.btnExitClick(Sender: TObject);
begin
Application.Terminate;
end;
procedure TfMain.btnAboutClick(Sender: TObject);
begin
fAbout.ShowModal;
end;
procedure TfMain.btnMyIPClick(Sender: TObject);
begin
ShowMessage(FileCln.LocalIP);
end;
procedure TfMain.lvClientsChange(Sender: TObject; Item: TListItem; Change: TItemChange);
begin
if Change <> ctState then Exit;
// btnDisconnect.Enabled := lvClients.SelCount = 1;
UpdateStatus;
end;
//Request a connection
procedure TfMain.btnConnectClick(Sender: TObject);
begin
if fConnect.ShowModal <> mrOk then Exit;
FileCln.CryptoKey := fConnect.edKey.Text;
if not FileCln.Connect(Trim(fConnect.edHost.Text), Trim(fConnect.edPort.Text)) then
ShowMessage('Error Code: ' + IntToStr(FileCln.LastError));
UpdateStatus;
end;
//Cancel a connection request
procedure TfMain.btnCancelClick(Sender: TObject);
begin
if not FileCln.Connecting then Exit;
FileCln.Disconnect;
end;
//Disconnect from the server
procedure TfMain.btnDisconnectClick(Sender: TObject);
begin
if not FileCln.Connected then Exit;
FileCln.Disconnect;
end;
//give an advantage to the folders in comparision
function PushFol(aItem: TListItem): String;
begin
Result := aItem.Caption;
if aItem.ImageIndex = siiFolder then
Result := ' ' + Result;
end;
//Compare 2 integers
function CompareIntegers(aInt1, aInt2: Int64): Integer;
begin
if aInt1 < aInt2 then
Result := -1
else
if aInt1 > aInt2 then
Result := 1
else
Result := 0;
end;
procedure TfMain.lvFilesCompare(Sender: TObject; Item1, Item2: TListItem; Data: Integer; var Compare: Integer);
var
FO1, FO2: TFileObj;
begin
FO1 := TFileObj(Item1.Data);
FO2 := TFileObj(Item2.Data);
case SortCol of
//sort by name
0: Compare := CompareText(PushFol(Item1), PushFol(Item2));
//sort by size
1: Compare := CompareIntegers(FO1.Size, FO2.Size);
//sort by time
2: Compare := CompareFiletime(FO1.ModTime, FO2.ModTime);
end;
if DescSortOrder then Compare := -Compare;
end;
procedure TfMain.lvFilesColumnClick(Sender: TObject; Column: TListColumn);
begin
if SortCol = Column.Index then
DescSortOrder := not DescSortOrder;
SortCol := Column.Index;
lvFiles.AlphaSort;
end;
procedure TfMain.lvFilesChange(Sender: TObject; Item: TListItem; Change: TItemChange);
begin
if Change <> ctState then Exit;
UpdateButtons;
end;
procedure TfMain.btnInClick(Sender: TObject);
begin
GoInFolder(lvFiles.Selected.Caption);
end;
procedure TfMain.btnUpClick(Sender: TObject);
begin
GoUpFolder;
end;
procedure TfMain.lvFilesDblClick(Sender: TObject);
begin
if lvFiles.Selected = nil then Exit;
if lvFiles.Selected.ImageIndex = siiFolder then
begin
if lvFiles.Selected.Caption = '..' then
GoUpFolder
else
GoInFolder(lvFiles.Selected.Caption);
end
else
btnDownloadClick(nil);
end;
// *** listing ***
//List the folder contents
procedure TfMain.btnListClick(Sender: TObject);
begin
ListFolder;
end;
//A list item is available
procedure TfMain.doHaveListItem(Sender: TObject; const aName: WideString; aFolder:WordBool; aSizeLo, aSizeHi, aTimeLo, aTimeHi: Integer);
var
SFI: TSHFileInfo;
FO: TFileObj;
LI: TListItem;
begin
FO := TFileObj.Create;
FO.Folder := aFolder;
FO.Size := Make64(aSizeLo, aSizeHi);
FO.ModTime.dwLowDateTime := aTimeLo;
FO.ModTime.dwHighDateTime := aTimeHi;
LI := lvFiles.Items.Add;
FO.ListItem := LI;
LI.Data := FO;
LI.Caption := aName;
if aFolder then
begin
LI.ImageIndex := siiFolder;
LI.Subitems.Add('');
end
else
begin
SHGetFileInfo(PChar(LI.Caption), FILE_ATTRIBUTE_NORMAL, SFI, SizeOf(TSHFileInfo), SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or SHGFI_TYPENAME);
LI.ImageIndex := SFI.iIcon;
LI.Subitems.Add(SizeStr(FO.Size));
end;
LI.SubItems.Add(FileTimeToText(FO.ModTime));
end;
//The whole folder contents is received
procedure TfMain.doListDone(Sender: TObject; aCode: Integer);
begin
lvFiles.Items.EndUpdate;
NowList := False;
CheckError(aCode);
UpdateButtons;
end;
// *** new folder ***
//Create a new folder
procedure TfMain.btnNewClick(Sender: TObject);
var
Nm: String;
begin
Nm := InputBox('Create folder', 'Folder name:', '');
if Nm = '' then Exit;
if FileCln.CreateFolder(AddSlash(pnlFolder.Caption) + Nm) then
NowCreateFolder := True
else
CheckError(FileCln.LastError);
UpdateButtons;
end;
//The new folder contents is created
procedure TfMain.doCreateFolderDone(Sender: TObject; aCode: Integer);
begin
NowCreateFolder := False;
CheckError(aCode);
UpdateButtons;
if aCode > 0 then Exit;
ListFolder;
end;
// *** renaming ***
//Rename the selected folder/file
procedure TfMain.btnRenameClick(Sender: TObject);
var
Nm: String;
begin
if lvFiles.Selected = nil then Exit;
if lvFiles.Selected.ImageIndex = siiFolder then
begin
//it's folder
Nm := InputBox('Rename folder', 'New name:', '');
if Nm = '' then Exit;
if FileCln.RenameFolder(AddSlash(pnlFolder.Caption) + lvFiles.Selected.Caption, AddSlash(pnlFolder.Caption) + Nm) then
NowRenameFolder := True
else
CheckError(FileCln.LastError);
end
else
begin
//it's file
Nm := InputBox('Rename file', 'New name:', '');
if Nm = '' then Exit;
if FileCln.RenameFile(AddSlash(pnlFolder.Caption) + lvFiles.Selected.Caption, AddSlash(pnlFolder.Caption) + Nm) then
NowRenameFile := True
else
CheckError(FileCln.LastError);
end;
UpdateButtons;
end;
//A folder is renamed
procedure TfMain.doRenameFolderDone(Sender: TObject; aCode: Integer);
begin
NowRenameFolder := False;
CheckError(aCode);
UpdateButtons;
if aCode > 0 then Exit;
ListFolder;
end;
//A file is renamed
procedure TfMain.doRenameFileDone(Sender: TObject; aCode: Integer);
begin
NowRenameFile := False;
CheckError(aCode);
UpdateButtons;
if aCode > 0 then Exit;
ListFolder;
end;
// *** deletion
//Delete the selected folder/file
procedure TfMain.btnDeleteClick(Sender: TObject);
begin
if lvFiles.Selected = nil then Exit;
if lvFiles.Selected.ImageIndex = siiFolder then
begin
//it's folder
if MessageDlg('Are you sure?', mtConfirmation, [mbYes, mbNo], 0) <> mrYes then Exit;
if FileCln.DeleteFolder(AddSlash(pnlFolder.Caption) + lvFiles.Selected.Caption) then
NowDeleteFolder := True
else
CheckError(FileCln.LastError);
end
else
begin
//it's file
if MessageDlg('Are you sure?', mtConfirmation, [mbOk], 0) <> mrOk then Exit;
if FileCln.DeleteFile(AddSlash(pnlFolder.Caption) + lvFiles.Selected.Caption) then
NowDeleteFile := True
else
CheckError(FileCln.LastError);
end;
UpdateButtons;
end;
//A folder is deleted
procedure TfMain.doDeleteFolderDone(Sender: TObject; aCode: Integer);
begin
NowDeleteFolder := False;
CheckError(aCode);
UpdateButtons;
if aCode > 0 then Exit;
ListFolder;
end;
//A file is deleted
procedure TfMain.doDeleteFileDone(Sender: TObject; aCode: Integer);
begin
NowDeleteFile := False;
CheckError(aCode);
UpdateButtons;
if aCode > 0 then Exit;
ListFolder;
end;
// *** downloading ***
// * user *
//Download the selected file
procedure TfMain.btnDownloadClick(Sender: TObject);
var
Dir: String;
begin
if lvFiles.Selected = nil then Exit;
if lvFiles.Selected.ImageIndex = siiFolder then Exit;
Dir := GetFolder('');
if Dir = '' then Exit;
if FileCln.Download(AddSlash(pnlFolder.Caption) + lvFiles.Selected.Caption, Dir) then
begin
NowDownload := True;
pnlDownFile.Caption := lvFiles.Selected.Caption;
pnlDownInfo.Caption := 'Handshaking...';
UpdateButtons;
end
else
CheckError(FileCln.LastError);
end;
//Abort the download operation
procedure TfMain.btnAbortDownloadClick(Sender: TObject);
begin
if not FileCln.CancelDownload then
CheckError(FileCln.LastError);
end;
// *** server ***
//download progress
procedure TfMain.doDownloadProgress(Sender: TObject; aLoCount, aHiCount, aLoSize, aHiSize: Integer);
begin
pnlDownInfo.Caption := IntToStr(Make64(aLoCount, aHiCount)) + '/' + IntToStr(Make64(aLoSize, aHiSize));
end;
//Download operation is completed
procedure TfMain.doDownloadDone(Sender: TObject; aCode: Integer);
begin
if aCode = 0 then
pnlDownInfo.Caption := 'Done.'
else
pnlDownInfo.Caption := 'Aborted: ' + ErrorText(aCode);
btnAbortDownload.Enabled := False;
NowDownload := False;
UpdateButtons;
end;
// *** uploading ***
// * user *
//Start uploading
procedure TfMain.btnUploadClick(Sender: TObject);
begin
if not dlgOpen.Execute then Exit;
if FileCln.Upload(dlgOpen.FileName, pnlFolder.Caption) then
begin
NowUpload := True;
UpldFol := pnlFolder.Caption;
pnlUpFile.Caption := dlgOpen.FileName;
pnlUpInfo.Caption := 'Handshaking...';
UpdateButtons;
end
else
CheckError(FileCln.LastError);
end;
//Abort upload
procedure TfMain.btnAbortUploadClick(Sender: TObject);
begin
if not FileCln.CancelUpload then
CheckError(FileCln.LastError);
end;
// * server *
//download progress
procedure TfMain.doUploadProgress(Sender: TObject; aLoCount, aHiCount, aLoSize, aHiSize: Integer);
begin
pnlUpInfo.Caption := IntToStr(Make64(aLoCount, aHiCount)) + '/' + IntToStr(Make64(aLoSize, aHiSize));
end;
//Upload operation is completed
procedure TfMain.doUploadDone(Sender: TObject; aCode: Integer);
begin
if aCode = 0 then
pnlUpInfo.Caption := 'Done.'
else
pnlUpInfo.Caption := 'Aborted: ' + ErrorText(aCode);
btnAbortUpload.Enabled := False;
NowUpload := False;
UpdateButtons;
if UpldFol = pnlFolder.Caption then
if aCode = 0 then
ListFolder;
end;
// *** zipping ***
// * user *
//Start zipping
procedure TfMain.btnZipClick(Sender: TObject);
var
Nm: String;
begin
Nm := InputBox('Compress to zip', 'Zip file name:', '');
if Nm = '' then Exit;
if ExtractFileExt(Nm) = '' then
Nm := Nm + '.zip';
if FileCln.Zip(AddSlash(pnlFolder.Caption) + Nm, AddSlash(pnlFolder.Caption) + lvFiles.Selected.Caption) then
begin
NowZip := True;
ZipFol := pnlFolder.Caption;
pnlZipFile.Caption := AddSlash(pnlFolder.Caption) + Nm;
pnlZipInfo.Caption := 'Handshaking...';
UpdateButtons;
end
else
CheckError(FileCln.LastError);
end;
//Abort zip operation
procedure TfMain.btnAbortZipClick(Sender: TObject);
begin
if not FileCln.CancelZip then
CheckError(FileCln.LastError);
end;
// * server *
//Zip operation is completed
procedure TfMain.doZipDone(Sender: TObject; aCode: Integer);
begin
if aCode = 0 then
pnlZipInfo.Caption := 'Done.'
else
pnlZipInfo.Caption := 'Aborted: ' + ErrorText(aCode);
NowZip := False;
UpdateButtons;
if ZipFol = pnlFolder.Caption then
if aCode = 0 then
ListFolder;
end;
//Zip progression
procedure TfMain.doZipProgress(Sender: TObject; aFileCount, aFileTotal, aLoByteCount, aHiByteCount, aLoByteTotal, aHiByteTotal: Integer);
begin
pnlZipInfo.Caption := IntToStr(Make64(aLoByteCount, aHiByteCount)) + '/' + IntToStr(Make64(aLoByteTotal, aHiByteTotal));
end;
// *** unzipping ***
// * user *
//Request an unzip operation
procedure TfMain.btnUnzipClick(Sender: TObject);
var
Nm: String;
begin
Nm := InputBox('Decompress from zip', 'Extract to folder:', '');
if FileCln.Unzip(AddSlash(pnlFolder.Caption) + lvFiles.Selected.Caption, AddSlash(pnlFolder.Caption) + Nm) then
begin
NowUnzip := True;
UnzipFol := pnlFolder.Caption;
pnlUnzipFile.Caption := AddSlash(pnlFolder.Caption) + lvFiles.Selected.Caption;
pnlUnzipInfo.Caption := 'Handshaking...';
UpdateButtons;
end
else
CheckError(FileCln.LastError);
end;
//Abort the unzip operation
procedure TfMain.btnAbortUnzipClick(Sender: TObject);
begin
if not FileCln.CancelUnzip then
CheckError(FileCln.LastError);
end;
// * from server *
//Unzip operation is completed
procedure TfMain.doUnzipDone(Sender: TObject; aCode: Integer);
begin
if aCode = 0 then
pnlUnzipInfo.Caption := 'Done.'
else
pnlUnzipInfo.Caption := 'Aborted: ' + ErrorText(aCode);
NowUnzip := False;
UpdateButtons;
if UnzipFol = pnlFolder.Caption then
if aCode = 0 then
ListFolder;
end;
//Unzip progression
procedure TfMain.doUnzipProgress(Sender: TObject; aFileCount, aFileTotal, aLoByteCount, aHiByteCount, aLoByteTotal, aHiByteTotal: Integer);
begin
pnlUnzipInfo.Caption := IntToStr(Make64(aLoByteCount, aHiByteCount)) + '/' + IntToStr(Make64(aLoByteTotal, aHiByteTotal));
end;
// *** searching ***
// * user *
//Request for a search operation
procedure TfMain.btnSearchClick(Sender: TObject);
var
Fls, Txt: String;
begin
if not ShowInpBox2('Search for', 'All or part of the file name:', 'A word or phrase in the file:', Fls, Txt) then Exit;
if FileCln.Search(pnlFolder.Caption, Fls, Txt) then
begin
NowSearch := True;
lvFind.Clear;
pnlFindInfo.Caption := 'Searching...';
UpdateButtons;
end
else
CheckError(FileCln.LastError);
end;
//Stop the search operation
procedure TfMain.btnStopSearchClick(Sender: TObject);
begin
if not FileCln.StopSearch then
CheckError(FileCln.LastError);
end;
//Search operation is completed
procedure TfMain.doSearchDone(Sender: TObject; aCode: Integer);
begin
if aCode = 0 then
pnlFindInfo.Caption := pnlFindInfo.Caption + ' - Done.'
else
pnlFindInfo.Caption := 'Aborted: ' + ErrorText(aCode);
NowSearch := False;
UpdateButtons;
end;
// * server *
//A file is found
procedure TfMain.doHaveFindFile(Sender: TObject; const aName: WideString; aSizeLo, aSizeHi, aTimeLo, aTimeHi: Integer);
var
LI: TlistItem;
SFI: TSHFileInfo;
FT: TFileTime;
begin
LI := lvFind.Items.Add;
LI.Caption := aName;
SHGetFileInfo(PChar(ExtractFileName(aName)), FILE_ATTRIBUTE_NORMAL, SFI, SizeOf(TSHFileInfo), SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or SHGFI_TYPENAME);
LI.ImageIndex := SFI.iIcon;
LI.Subitems.Add(SizeStr(Make64(aSizeLo, aSizeHi)));
FT.dwLowDateTime := aTimeLo;
FT.dwHighDateTime := aTimeHi;
LI.SubItems.Add(FileTimeToText(FT));
pnlFindInfo.Caption := IntToStr(lvFind.Items.Count) + ' files found';
end;
//Search progression
procedure TfMain.doSearchProgress(Sender: TObject; aCount: Integer);
begin
pnlFindInfo.Caption := IntToStr(aCount) + ' files searched';
end;
// *** streaming ***
// * user *
//Open a seekable stream
procedure TfMain.btnOpenStreamClick(Sender: TObject);
begin
if lvFiles.Selected = nil then Exit;
if lvFiles.Selected.ImageIndex = siiFolder then Exit;
if FileCln.OpenStream(AddSlash(pnlFolder.Caption) + lvFiles.Selected.Caption, 0) then
begin
NowOpen := True;
StreamName := lvFiles.Selected.Caption;
pnlStream.Caption := 'Opening...';
UpdateButtons;
end
else
CheckError(FileCln.LastError);
end;
//Close the stream
procedure TfMain.btnCloseStreamClick(Sender: TObject);
begin
if not FileCln.CloseStream then
CheckError(FileCln.LastError);
end;
//Seek in the stream
procedure TfMain.btnSeekClick(Sender: TObject);
var
NP: String;
begin
NP := InputBox('Seek in stream', 'Position:', '');
if NP = '' then Exit;
if not FileCln.SeekStream(StrToIntDef(NP, 0), 0, 0) then
CheckError(FileCln.LastError);
end;
// * server *
//The stream is opened
procedure TfMain.doOpenDone(Sender: TObject; aCode: Integer);
begin
NowOpen := False;
if aCode = 0 then
begin
pnlStream.Caption := StreamName;
FileCln.NeedStreamSize;
end
else
begin
StreamName := '';
pnlStream.Caption := ErrorText(aCode);
end;
UpdateButtons;
end;
//THe stream is closed
procedure TfMain.doCloseDone(Sender: TObject; aCode: Integer);
begin
NowClose := False;
StreamName := '';
pnlStream.Caption := '';
lbStream.Clear;
UpdateButtons;
end;
//Stream size is available
procedure TfMain.doStreamSizeDone(Sender: TObject; aCode, aSizeLo, aSizeHi: Integer);
begin
if aCode <> 0 then Exit;
pnlStream.Caption := StreamName + ' (' + IntToStr(Make64(aSizeLo, aSizeHi)) + ') ';
end;
//Stream position is available
procedure TfMain.doStreamPositionDone(Sender: TObject; aCode, aPosLo, aPosHi: Integer);
begin
if aCode <> 0 then Exit;
pnlStream.Caption := StreamName + '-' + IntToStr(Make64(aPosLo, aPosHi));
end;
//Seek is completed
procedure TfMain.doSeekDone(Sender: TObject; aCode: Integer);
begin
NowSeek := False;
if aCode = 0 then
begin
if not FileCln.ReadStream(64) then
CheckError(FileCln.LastError);
end
else
pnlStream.Caption := ErrorText(aCode);
end;
//Read is completed
procedure TfMain.doReadDone(Sender: TObject; aCode: Integer; var aBlock: OleVariant);
var
Len, i, col: Integer;
P: PByte;
Ln: String;
procedure AddLine;
begin
lbStream.Items.Add(Ln);
col := 0;
Ln := '';
end;
begin
NowRead := False;
FileCln.NeedStreamPosition;
if aCode = 0 then
begin
lbStream.Clear;
if not VarIsArray(aBlock) then Exit;
Len := VarArrayHighBound(aBlock, 1) - VarArrayLowBound(aBlock, 1) + 1;
P := VarArrayLock(aBlock);
if P = nil then Exit;
col := 0;
Ln := '';
for i := 1 to Len do
begin
Ln := Ln + 'H' + IntToHex(P^, 2) + ' ';
Inc(P);
Inc(col);
if col > 7 then
AddLine;
end;
AddLine;
VarArrayUnlock(aBlock);
end
else
pnlStream.Caption := ErrorText(aCode);
end;
end.
© BigSpeed Computing Inc. - Secure private networking