admin/expertcad
1
0
Fork 0
mirror of http://gitlab.expertsoft.com.ua/git/expertcad synced 2026-01-11 18:25:40 +02:00
Code Issues Packages Projects Releases Wiki Activity
expertcad/SRC/Main/U_Reserv.pas
Anatoly d7204c6898 First_commit
2025-05-13 16:51:40 +03:00

900 lines
24 KiB
ObjectPascal
Raw Permalink Blame History

unit U_Reserv;
interface
uses
Windows, U_LNG, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons,
IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
IdExplicitTLSClientServerBase, IdFTP, idUri, idFTPCommon,idFTPLIST, IdAllFTPListParsers,
IdFTPListParseBase,IdFTPListParseAS400, IdFTPListParsePcTcp, IdFTPListTypes,
Wininet, siComp, siLngLnk, Grids, DBGrids, RzDBGrid, DB, SQLMemMain,
cxGraphics, cxControls, cxLookAndFeels, cxLookAndFeelPainters, cxStyles,
cxCustomData, cxFilter, cxData, cxDataStorage, cxEdit, cxNavigator, cxDBData,
cxGridCustomTableView, cxGridTableView, cxGridDBTableView, cxGridLevel,
cxClasses, cxGridCustomView, cxGrid, ExtCtrls, RzPanel, ActnList,
PlatformDefaultStyleActnCtrls, ActnMan, ToolWin, ActnCtrls, ComCtrls, acDBGrid,
Menus, kbmMemTable, kbmMemSQL, DBTables;
type
TF_Reserv = class(TForm)
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
lbAllowedSpace: TLabel;
lbUsedSpace: TLabel;
siLangLinked1: TsiLangLinked;
DataSource1: TDataSource;
FileTable: TSQLMemTable;
FileTableFileSize: TStringField;
FileTableFileDate: TStringField;
ToolBar1: TToolBar;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
ToolButton3: TToolButton;
ToolButton4: TToolButton;
ToolButton5: TToolButton;
ActionList1: TActionList;
aRefresh: TAction;
aUpload: TAction;
aLoad: TAction;
aDelFileFrom: TAction;
aExit: TAction;
PopupMenu1: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
aDelete1: TMenuItem;
FileTable1: TkbmMemTable;
aToPM: TAction;
aFromPM: TAction;
ToolButton6: TToolButton;
ToolButton7: TToolButton;
FileTableFileName: TStringField;
Query1: TQuery;
FileTable1FileName: TStringField;
FileTable1FileSize: TStringField;
FileTable1FileData: TStringField;
MemSQL1: TkbmMemSQL;
cxGrid1DBTableView1: TcxGridDBTableView;
cxGrid1Level1: TcxGridLevel;
cxGrid1: TcxGrid;
cxGrid1DBTableView1FileName: TcxGridDBColumn;
cxGrid1DBTableView1FileSize: TcxGridDBColumn;
cxGrid1DBTableView1FileDate: TcxGridDBColumn;
//procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
//procedure btnSaveClick(Sender: TObject);
//procedure btnLoadClick(Sender: TObject);
//procedure btnDeleteClick(Sender: TObject);
procedure aRefreshExecute(Sender: TObject);
procedure aUploadExecute(Sender: TObject);
procedure aExitExecute(Sender: TObject);
procedure aLoadExecute(Sender: TObject);
procedure aDelFileFromExecute(Sender: TObject);
procedure aToPMExecute(Sender: TObject);
procedure aFromPMExecute(Sender: TObject);
//procedure RzDBGrid1TitleClick(Column: TColumn);
private
{ Private declarations }
public
{ Public declarations }
function SendFileToFtp(aFtpStr, aFileName: string): boolean;
function GetFileFromFtp(aFtpStr, aFileNameShort, aFileName: string; aGetConfig: Boolean = false): boolean;
function GetFileListFromFtp(aFtpStr: string): TStringList;
function DeleteFileFromFtp(aFtpStr, aFileName: string): boolean;
Procedure RefreshFileList;
//Procedure SetButtons(aSave, aLoad, aDelete: Boolean);
Procedure SelectItem;
Function HexToStr(const HexStr: string): string;
function SaveCurrProjToTemFile: boolean;
//function GetTempDir: string;
end;
var
F_reserv: TF_Reserv;
Selected_Item: integer;
FClientLimit: integer; // <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><>
FFact: Integer; // <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><>
FileDateList: TStringList;
FileSizeList: TStringList;
MyHeaderStyle: TcxStyle;
//FConnStr: string;
implementation
uses USCS_Main, U_Common, U_BaseCommon, U_BaseConstants, U_ProtectionCommon, U_Main, U_SCSComponent;
{$R *.dfm}
(*
function GetTempDir: string;
var
buff: pchar;
s: string;
begin
if length(TempDir) > 0 then
begin
if DirectoryExists(TempDir) then
Result := TempDir
else
begin
TempDir := '';
Result := GetTempDir;
end;
end
else
begin
// Tolik 24/06/* 2019 --
s := GetEnvironmentVariable('tmp');
if ((s = '') or (not DirectoryExists(s))) then
s := GetEnvironmentVariable('temp');
if ((s = '') or (not DirectoryExists(s))) then
s := exedir;
(*
// Tolik 21/06/2019 --
getmem(buff, 256*2);
//
s := '';
if (GetEnvironmentVariable('tmp',buff, 254) >0)
and (DirectoryExists(buff)) then
begin
s := buff;
end
else
if (GetEnvironmentVariable('temp',buff, 254) >0)
and (DirectoryExists(buff)) then
begin
s := buff;
end
else
s := exedir;
freemem(buff);
*)
(* try
if not DirectoryExists(s + OurTempDir) then
MkDir(s + OurTempDir);
TempDir := s + OurTempDir;
result := TempDir;
except
ShowMessage(cTmpDirErr);
{$if Defined(ES_GRAPH_SC)}
Application.Terminate;
{$else}
ExitProcess(1);
{$ifend}
end;
end;
end;
*)
function TF_Reserv.SaveCurrProjToTemFile: boolean;
var TempProj: TSCSProject;
CurrProjNode: TTreeNode;
begin
CurrProjNode := F_ProjMan.GSCSBase.CurrProject.TreeViewNode;
Result := false;
end;
function TF_Reserv.HexToStr(const HexStr: string): string;
var
i: Integer;
begin
Result := '';
i := 1;
while i <= Length(HexStr) do
begin
Result := Result + Chr(StrToInt('$' + Copy(HexStr, i, 2)) XOR 57);
Inc(i, 2);
end;
end;
Procedure TF_Reserv.SelectItem;
var i: integer;
begin
{if F_Reserv.ListBox1.Count > 0 then
begin
for i := 0 to F_Reserv.ListBox1.Count - 1 do
begin
if F_Reserv.ListBox1.Selected[i] = true then
F_Reserv.ListBox1.Selected[i] := False;
end;
if Selected_Item > (F_Reserv.ListBox1.Count - 1) then
Selected_Item := (F_Reserv.ListBox1.Count - 1);
F_Reserv.ListBox1.Selected[Selected_Item] := true;
end
else
Selected_Item := 0;
}
end;
(*
Procedure TF_Reserv.SetButtons(aSave, aLoad, aDelete: Boolean);
begin
{
F_Reserv.btnSave.Enabled := aSave;
F_Reserv.btnLoad.Enabled := aLoad;
F_Reserv.btnDelete.Enabled := aDelete;
}
end;
*)
procedure TF_Reserv.aUploadExecute(Sender: TObject);
var OpenDlg: TOpenDialog;
FileNameShort, Filename: string;
i: integer;
begin
OpenDlg := TOpenDialog.Create(nil);
OpenDlg.Filter := ' (*.scs)|*.SCS';
if OpenDlg.Execute then
begin
FileName := OpenDlg.FileName;
if SendFileToFtp(HexToStr(GFtpConnectStr), FileName) then
RefreshFileList;
end;
OpenDlg.Free;
end;
procedure TF_Reserv.aDelFileFromExecute(Sender: TObject);
begin
if DeleteFileFromFtp(HexToStr(GFtpConnectStr), f_Reserv.filetable.fieldvalues['filename']) then
begin
RefreshFileList;
end;
end;
procedure TF_Reserv.aExitExecute(Sender: TObject);
begin
F_Reserv.Close;
end;
procedure TF_Reserv.aFromPMExecute(Sender: TObject);
var tdir: string;
canProceed, formHide: Boolean;
fName: String;
begin
if CheckIsOpenProject(false) then
begin
tdir := '';
tdir := GetTempDir;
if tdir <> '' then
begin
FName := tdir + '\'+ F_ProjMan.GSCSBase.CurrProject.Name + '.scs';
if FileExists(FName) then
DeleteFile(FName);
if F_ProjMan.GSCSBase.CurrProject.SaveToStreamOrFile(nil, FName) then
begin
if SendFileToFtp(HexToStr(GFtpConnectStr), FName) then
RefreshFileList;
end;
if FileExists(FName) then
DeleteFile(FName);
end;
end
else
ShowMessage('');
end;
procedure TF_Reserv.aLoadExecute(Sender: TObject);
var SaveDlg: TSaveDialog;
FileName: string;
i: integer;
begin
FileName := '';
FileName := FileTable.fieldvalues['FileName'];
if fileName <> '' then
begin
SaveDlg := TSaveDialog.Create(nil);
SaveDlg.Filter := ' (*.scs)|*.SCS';
SaveDlg.FileName := fileName;
if SaveDlg.Execute then
begin
FileName := SaveDlg.FileName;
GetFileFromFtp(HexToStr(GFtpConnectStr), extractfilename(FileName), SaveDlg.FileName);
end;
SaveDlg.Free;
end;
end;
procedure TF_Reserv.aRefreshExecute(Sender: TObject);
begin
RefreshFileList;
end;
procedure TF_Reserv.aToPMExecute(Sender: TObject);
var tdir: string;
canProceed, formHide: Boolean;
begin
tdir := '';
tdir := GetTempDir;
if tdir <> '' then
begin
CanProceed := False;
formHide := False;
if CheckIsOpenProject(false) then
begin
if MessageBox(F_Reserv.Handle, PChar(cFtpmes7), PChar(cWarningSlowCap), MB_YESNO) = IDYes then
begin
F_Reserv.Hide;
formHide := True;
CanProceed := CloseCurrProject(true) <> IDCancel;
end;
end
else
CanProceed := True;
if CanProceed then
begin
GetFileFromFtp(HexToStr(GFtpConnectStr), FileTable.FieldValues['FileName'], tdir + '\'+ FileTable.FieldValues['FileName']);
if FileExists(tdir + '\'+ FileTable.FieldValues['FileName']) then
begin
F_ProjMan.LoadProjectFromFile(tdir + '\'+ FileTable.FieldValues['FileName']);
DeleteFile(tdir + '\'+ FileTable.FieldValues['FileName']);
F_Reserv.Close;
end;
end
else
begin
if formHide then
F_Reserv.ShowModal;
end;
end;
end;
Procedure TF_Reserv.RefreshFileList;
var FileList: TStringList;
i: integer;
vSave, vLoad, vDelete: Boolean;
s, tmppath, filename: String;
f: TextFile;
UserLimit: integer;
begin
vSave := False;
vLoad := False;
vDelete := False;
//FConnStr := HexToStr(GFtpConnectStr);
//F_Reserv.ListBox1.Clear;
f_Reserv.FileTable.Close;
f_Reserv.FileTable.Open;
tmppath := GetDefaultTempPath;//+'\' + 'USER.CFG';
{ FileList := F_Reserv.GetFileListFromFtp(GFtpConnectStr);
if FileList <> nil then
begin
F_Reserv.ListBox1.Clear;
for i := 0 to fileList.Count - 1 do // Client Config
begin
if UPPERCASE(FileList[i]) = 'USER.CFG' then // <20><><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
begin
tmppath := GetDefaultTempPath+'\' + 'USER.CFG';
if GetFileFromFtp(GFtpConnectStr, 'USER.CFG', tmppath) then //<2F><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
begin
end;
end;
//F_Reserv.ListBox1.AddItem(filelist[i], nil);
end;
if F_Reserv.ListBox1.Items.Count > 0 then
SelectItem;
fileList.Free;
end;
}
FileName := tmppath + 'USER.CFG';
if fileExists(FileName) then
DeleteFile(FileNAme);
if GetFileFromFtp(HexToStr(GFtpConnectStr), 'USER.CFG', tmppath + 'USER.CFG', true) then //<2F><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
begin
AssignFile(f,FileName);
Reset(f);
Readln(f,s);
CloseFile(f);
UserLimit := strtoint(s);
lballowedspace.Caption := s;
//vSave := true;
//vLoad := true;
//vDelete := true;
////
FileList := F_Reserv.GetFileListFromFtp(HexToStr(GFtpConnectStr));
if FileList <> nil then
begin
//FileTable.ReadOnly := False;
// F_Reserv.FileTable.EmptyTable;
While F_Reserv.FileTable.RecordCount > 0 do
begin
F_Reserv.FileTable.Delete;
end;
//F_Reserv.ListBox1.Clear;
for i := 0 to fileList.Count - 1 do // Client Config
begin
//F_Reserv.ListBox1.AddItem(filelist[i], nil);
F_Reserv.FileTable.Append;
F_Reserv.FileTable.FieldByName('FileName').AsString := FileList[i];
F_Reserv.FileTable.FieldByName('FileDate').AsString := FileDateList[i];
F_Reserv.FileTable.FieldByName('FileSize').AsString := FileSizeList[i];
end;
//FileTable.ReadOnly := True;
//if F_Reserv.ListBox1.Items.Count = 0 then
F_Reserv.aDelFileFrom.Enabled := True;
F_Reserv.aLoad.Enabled := True;
F_Reserv.aToPM.Enabled := True;
if F_Reserv.FileTable.RecordCount = 0 then
begin
F_Reserv.aDelFileFrom.Enabled := False;
F_Reserv.aLoad.Enabled := False;
F_Reserv.aToPM.Enabled := False;
end
else
begin
F_Reserv.FileTable.First;
F_Reserv.cxGrid1DBTableView1.Controller.FocusedRowIndex := 0;
end;
//F_Reserv.FileTable.First;
//SelectItem;
fileList.Free;
if UserLimit <= strtoint(lbUsedSpace.Caption) then
begin
F_Reserv.aUpload.Enabled := False;
F_Reserv.aFromPM.Enabled := False;
end
else
begin
F_Reserv.aUpload.Enabled := True;
//F_Reserv.aFromPM.Enabled := True;
if CheckIsOpenProject(false) then
F_Reserv.aFromPM.Enabled := True
else
F_Reserv.aFromPM.Enabled := False;
end;
end
else
begin
F_Reserv.aDelFileFrom.Enabled := False;
F_Reserv.aLoad.Enabled := False;
F_Reserv.aToPM.Enabled := False;
F_Reserv.aUpload.Enabled := False;
F_Reserv.aFromPM.Enabled := False;
Showmessage('cFtpmes12');
end;
end
else
begin
F_Reserv.aDelFileFrom.Enabled := False;
F_Reserv.aLoad.Enabled := False;
F_Reserv.aToPM.Enabled := False;
F_Reserv.aUpload.Enabled := False;
F_Reserv.aFromPM.Enabled := False;
Showmessage('cFtpmes12');
end;
//SetButtons(vSave, vLoad, vDelete);
end;
{
procedure TF_Reserv.RzDBGrid1TitleClick(Column: TColumn);
var FldName: string;
begin
FldName := Column.FieldName;
FileTable.IndexName := 'Filename';
end;
}
function TF_Reserv.SendFileToFtp(aFtpStr, aFileName: string): boolean;
var NameShort, NewName: String;
Ftp_serv: TIdFtp;
Uri: TIdURI;
bm: TBookmark;
FileNameExists: Boolean;
i: integer;
begin
Result := False;
if FileExists(aFileName) then
begin
Uri := TIdUri.Create(aFtpStr);
Ftp_serv:= TIdFtp.create;
ftp_serv.Host := uri.host;
ftp_serv.Username := uri.username;
ftp_serv.Password := uri.password;
ftp_serv.Port := 21;
ftp_serv.Passive := true;
ftp_serv.TransferType := ftBinary;
try
ftp_serv.Connect;
except
on E: Exception do
begin
//showmessage('Can not to connect!!!');
ftp_serv.Free;
URi.Free;
AddExceptionToLog(cFtpmes1, true);
exit;
end;
end;
if ftp_serv.Connected then
begin
NameShort := ExtractFileName(aFileName);
if F_Reserv.FileTable.RecordCount > 0 then //<2F><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
begin
FileNameExists := false;
bm := F_Reserv.FileTable.Bookmark;
F_Reserv.FileTable.DisableControls;
F_Reserv.FileTable.First;
while not F_Reserv.FileTable.Eof do
begin
if NameShort = F_Reserv.FileTable.FieldValues['FileName'] then
begin
FileNameExists := true;
break;
end;
F_Reserv.FileTable.Next;
end;
F_Reserv.FileTable.Bookmark := bm;
F_Reserv.FileTable.EnableControls;
end;
if FileNameExists then // <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> - <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
begin // <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if MessageBox(F_Reserv.Handle, PChar(cFtpmes8), PChar(cWarningSlowCap), MB_YESNO) <> IDYes then
begin
NameShort := Trim(InputBox(cFtpmes9, cFtpmes10, ''));
if length(NameShort) > 0 then
begin
NewName := '';
for i := 1 to Length(NameShort) do
begin
if NameShort[i] = '.' then
break
else
NewName := NewName + NameShort[i];
end;
if NewName <> '' then
NameShort := NewName + '.scs'
else
begin
ShowMessage(cFtpmes11);
ftp_serv.Disconnect;
ftp_serv.Free;
URi.Free;
exit;
end;
end;
end
else
DeleteFileFromFtp(aFtpStr, aFileName); //<2F><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
end;
try
ftp_serv.Put(aFileName, NameShort);
Result := True;
except
on E: exception do
begin
Result := False;
AddExceptionToLog(cFtpmes2, true);
//showMessage('Can not to send a file!');
end;
end;
end;
ftp_serv.Disconnect;
ftp_serv.Free;
URi.Free;
end;
end;
function TF_Reserv.GetFileFromFtp(aFtpStr, aFileNameShort, aFileName: string; aGetConfig: Boolean = false): boolean;
var
Ftp_serv: TIdFtp;
Uri: TIdURI;
begin
Result := false;
Uri := TIdUri.Create(aFtpStr);
Ftp_serv:= TIdFtp.create;
ftp_serv.Host := uri.host;
ftp_serv.Username := uri.username;
ftp_serv.Password := uri.password;
ftp_serv.Port := 21;
ftp_serv.Passive := true;
ftp_serv.TransferType := ftBinary;
try
ftp_serv.Connect;
except
on E: Exception do
begin
//showmessage('Can not to connect!!!');
Result := false;
ftp_serv.Free;
URi.Free;
AddExceptionToLog(cFtpmes1, true);
exit;
end;
end;
if ftp_serv.Connected then
begin
if aGetConfig then
begin
try
ftp_serv.ChangeDir('cfg');
ftp_serv.get(aFileNameShort, aFileName);
Result := True;
except
on E: exception do
begin
//showMessage('Can not to get file from ftp!');
AddExceptionToLog(cFtpmes6, true);
Result := False;
end;
end;
end
else
begin
try
ftp_serv.ChangeDir('/');
ftp_serv.get(aFileNameShort, aFileName);
Result := True;
except
on E: exception do
begin
//showMessage('Can not to get file from ftp!');
AddExceptionToLog(cFtpmes3, true);
Result := False;
end;
end;
end;
end;
ftp_serv.Disconnect;
ftp_serv.Free;
URi.Free;
end;
function TF_Reserv.GetFileListFromFtp(aFtpStr: string): TStringList;
var
Ftp_serv: TIdFtp;
Uri: TIdURI;
Size, FileSize: Double;
i, rsize: integer;
begin
Result := TstringList.Create;
rsize := 0;
Uri := TIdUri.Create(aFtpStr);
Ftp_serv:= TIdFtp.create;
ftp_serv.Host := uri.host;
ftp_serv.Username := uri.username;
ftp_serv.Password := uri.password;
ftp_serv.Port := 21;
ftp_serv.Passive := true;
try
ftp_serv.Connect;
except
on E: Exception do
begin
//showmessage('Can not to connect!!!');
ftp_serv.Free;
URi.Free;
FreeAndNil(Result);
AddExceptionToLog(cFtpmes1, true);
exit;
end;
end;
if ftp_serv.Connected then
begin
try
//ftp_serv.List(Result,'*.*',false);
ftp_serv.ChangeDirUp;
ftp_serv.List(Result,'*.scs', false);
Size := 0;
for i := 0 to ftp_serv.DirectoryListing.Count - 1 do
begin
FileSize := ftp_serv.Size(ftp_serv.DirectoryListing[i].FileName);
Size := Size + FileSize;
FileDateList.Add(DateTostr(ftp_serv.FileDate(ftp_serv.DirectoryListing[i].FileName)));
FileSizeList.Add(FloatToStr(RoundX(FileSize/1048576, 3)));
end;
rsize := round(size/1048576);
lbUsedSpace.Caption := inttostr(rsize);
if rsize >= strtoint(lballowedspace.Caption) then
lbUsedSpace.Font.Color := clRed
else
lbUsedSpace.Font.Color := clBlue;
//ftp_serv.List(Result,'', false);
except
on E: exception do
begin
//showmessage('Can not get filelist from FTP!');
FreeAndNil(Result);
AddExceptionToLog(cFtpmes5, true);
end;
end;
end;
ftp_serv.Disconnect;
ftp_serv.Free;
URi.Free;
end;
function TF_Reserv.DeleteFileFromFtp(aFtpStr, aFileName: string): boolean;
var
Ftp_serv: TIdFtp;
Uri: TIdURI;
begin
Result := False;
Uri := TIdUri.Create(aFtpStr);
Ftp_serv:= TIdFtp.create;
ftp_serv.Host := uri.host;
ftp_serv.Username := uri.username;
ftp_serv.Password := uri.password;
ftp_serv.Port := 21;
ftp_serv.Passive := true;
try
ftp_serv.Connect;
except
on E: Exception do
begin
//showmessage('Can not to connect!!!');
ftp_serv.Free;
URi.Free;
AddExceptionToLog(cFtpmes1, true);
exit;
end;
end;
if ftp_serv.Connected then
begin
try
ftp_serv.Delete(aFileName);
Result := True;
except
on E: exception do
begin
Result := False;
//showMessage('Can not to send a file!');
AddExceptionToLog(cFtpmes4, true);
end;
end;
end;
ftp_serv.Disconnect;
ftp_serv.Free;
URi.Free;
end;
(*
procedure TF_Reserv.btnDeleteClick(Sender: TObject);
var i: integer;
begin
i := f_Reserv.RzDBGrid1.SelectedIndex;
i := 0;
{
if ListBox1.Count > 0 then
begin
for i := 0 to ListBox1.Count - 1 do
begin
if ListBox1.Selected[i] = true then
begin
Selected_Item := i;
if DeleteFileFromFtp(HexToStr(GFtpConnectStr), ListBox1.Items[i]) then
begin
RefreshFileList;
end;
break;
end;
end;
end;
}
end;
*)
(*
procedure TF_Reserv.btnLoadClick(Sender: TObject);
var SaveDlg: TSaveDialog;
FileName: string;
i: integer;
begin
FileName := '';
{
for i := 0 to ListBox1.Count - 1 do
begin
if ListBox1.Selected[i] = true then
begin
FileName := ListBox1.Items[i];
break;
end;
end;
}
if fileName <> '' then
begin
SaveDlg := TSaveDialog.Create(nil);
SaveDlg.Filter := ' (*.scs)|*.SCS';
SaveDlg.FileName := fileName;
if SaveDlg.Execute then
begin
FileName := SaveDlg.FileName;
GetFileFromFtp(HexToStr(GFtpConnectStr), extractfilename(FileName), SaveDlg.FileName);
end;
SaveDlg.Free;
end;
end;
*)
(*
procedure TF_Reserv.btnSaveClick(Sender: TObject);
var OpenDlg: TOpenDialog;
FileNameShort, Filename: string;
i: integer;
begin
{
for i := 0 to ListBox1.Count - 1 do
begin
if ListBox1.Selected[i] = true then
begin
Selected_Item := i;
break;
end;
end;
}
OpenDlg := TOpenDialog.Create(nil);
OpenDlg.Filter := ' (*.scs)|*.SCS';
if OpenDlg.Execute then
begin
FileName := OpenDlg.FileName;
//FileNameShort := ExtractFileName(OpenDlg.FileName);
if SendFileToFtp(HexToStr(GFtpConnectStr), FileName) then
RefreshFileList;
end;
OpenDlg.Free;
end;
*)
{procedure TF_Reserv.Button1Click(Sender: TObject);
begin
F_Reserv.Close;
end;
}
procedure TF_Reserv.FormCreate(Sender: TObject);
begin
FileDateList := TStringList.Create;
FileSizeList := TStringList.Create;
{
btnSave.Caption := '<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>' + #13#10 + ' <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>';
btnLoad.Caption := '<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>' + #13#10 + ' <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>';
btnDelete.Caption := '<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>' + #13#10 + ' <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>';
}
{btnSave.Caption := cFtpbtnSaveCaption;
btnLoad.Caption := cFtpbtnLoadCaption;
btnDelete.Caption := cFtpbtnDeleteCaption;}
Selected_Item := 0;
FClientLimit := 0;
FFact := 0;
lballowedspace.Font.Color := clBlue;
lbUsedSpace.Font.Color := clBlue;
MyHeaderStyle := TcxStyle.Create(nil);
MyHeaderStyle.Font.Style := [fsBold];
cxGrid1DBTableView1.Styles.Header := MyHeaderStyle;
end;
procedure TF_Reserv.FormShow(Sender: TObject);
var FileList: TStringList;
i: integer;
begin
FileDateList.Clear;
FileSizeList.Clear;
RefreshFileList;
//SelectItem;
end;
end.
Reference in New Issue View Git Blame Copy Permalink