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; // Лимит клиента на дисковое пространство на серваке, МБ FFact: Integer; // Занято клиентом на сервере, МБ 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 // файл с объемом выделенного места для пользователя на серваке begin tmppath := GetDefaultTempPath+'\' + 'USER.CFG'; if GetFileFromFtp(GFtpConnectStr, 'USER.CFG', tmppath) then //получить с сервера и прочитать размер доступного места 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 //получить с сервера и прочитать размер доступного места 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 //проверка на наличие файла на сервере 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 // если такое имя на серваке есть - запросить у пользователя действие begin // или перезаписать или записать с другим именем 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); //если перезаписать, то удалить копию 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 := 'Загрузить файл' + #13#10 + ' на сервер'; btnLoad.Caption := 'Загрузить файл' + #13#10 + ' с сервера'; btnDelete.Caption := 'Удалить файл' + #13#10 + ' на сервере'; } {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.