Dziękuję za sugestię po zakończeniu tego projektu zabiorę się za aktualizację...
Bardzo chętnie bym zaktualizował teraz ale mam wielkiego stracha ,że mój bieżący projekty szlag trafi przez OS X na którym instalacja Lazarusa zajęła mi duuuużo czasu.
Wracając do kodu , to poniżej są Project1, unit1 - sekcje z uses i deklaracją procedur , wątkow,
a najniżej wątek tczas.execute; który odpowiada za łączenie się z FTP. Działa w Windows bez zastrzeżeń.
wywołane procedury synchro...wykonują coś na formie albo na dyskach sprawdzając spójność i poprawność danych. Nie wkleję ich bo zaśmiecą.
program project1;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,cmem,
{$ENDIF}{$ENDIF}
{cthreads,cmem,} // <-- to trzeba uwolnic dla aplikacji w osx i linux
Interfaces, // this includes the LCL widgetset
Forms, Unit1, laz_synapse, Unit2
{ you can add units after this };
{$R *.res}
begin
Application.Title:='Memo';
RequireDerivedFormResource:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.CreateForm(Tmessage, message);
Application.Run;
end.
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
{cthreads,cmem,} //<-- to trzeba uwonic dla aplikacji w osx i linux
Classes, SysUtils, FileUtil, UTF8Process, Forms, Controls, Graphics, Dialogs,
StdCtrls, ExtCtrls, Buttons, Menus,LconvEncoding,ftpsend, Types,blcksock,SynaMisc;
type
tzapis = class(TThread)
private
{ Private declarations }
procedure zapisneton;
procedure zapisznowego;
procedure zapiszedycje;
procedure ustaw;
procedure zapisznaftp;
procedure serwer;
procedure usun;
procedure spojnosczapis;
procedure uscopy;
protected procedure execute; override;
end;
type
tczas = class(TThread)
private
{ Private declarations }
procedure start;
procedure neton;
procedure porownanie;
procedure zaleglosci;
procedure spojnosc;
procedure newserwer;
procedure kopia;
protected procedure execute; override;
end;
type
tsynchro = class(TThread)
private
{ Private declarations }
procedure obrazek;
protected procedure execute; override;
end;
{ TForm1 }
type
TForm1 = class(TForm)
BitBtn1: TBitBtn;
ComboBox1: TComboBox;
ComboBox2: TComboBox;
ComboBox3: TComboBox;
ComboBox4: TComboBox;
Edit1: TEdit;
Edit10: TEdit;
Edit11: TEdit;
Edit12: TEdit;
Edit13: TEdit;
Edit14: TEdit;
Edit15: TEdit;
Edit16: TEdit;
Edit17: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Edit4: TEdit;
Edit5: TEdit;
Edit6: TEdit;
Edit7: TEdit;
Edit8: TEdit;
Edit9: TEdit;
Image1: TImage;
Image2: TImage;
Image3: TImage;
Image4: TImage;
Image5: TImage;
Image6: TImage;
Image7: TImage;
Label1: TLabel;
Label2: TLabel;
ListBox1: TListBox;
ListBox2: TListBox;
ListBox3: TListBox;
ListBox4: TListBox;
MenuItem1: TMenuItem;
MenuItem2: TMenuItem;
MenuItem3: TMenuItem;
MenuItem4: TMenuItem;
MenuItem5: TMenuItem;
MenuItem6: TMenuItem;
PopupMenu1: TPopupMenu;
ProcessUTF8_1: TProcessUTF8;
procedure BitBtn1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure ComboBox1Click(Sender: TObject);
procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer;
ARect: TRect; State: TOwnerDrawState);
procedure ComboBox1MouseLeave(Sender: TObject);
procedure ComboBox1Select(Sender: TObject);
procedure ComboBox2DrawItem(Control: TWinControl; Index: Integer;
ARect: TRect; State: TOwnerDrawState);
procedure ComboBox2MouseLeave(Sender: TObject);
procedure ComboBox2Select(Sender: TObject);
procedure ComboBox3DrawItem(Control: TWinControl; Index: Integer;
ARect: TRect; State: TOwnerDrawState);
procedure ComboBox4DrawItem(Control: TWinControl; Index: Integer;
ARect: TRect; State: TOwnerDrawState);
procedure ComboBox4Select(Sender: TObject);
procedure Edit10Click(Sender: TObject);
procedure Edit1Change(Sender: TObject);
procedure Edit1Click(Sender: TObject);
procedure Edit2Click(Sender: TObject);
procedure Edit6Click(Sender: TObject);
procedure Edit6Enter(Sender: TObject);
procedure FormClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FormPaint(Sender: TObject);
procedure Image2Click(Sender: TObject);
procedure Image3Click(Sender: TObject);
procedure Image3MouseEnter(Sender: TObject);
procedure Image3MouseLeave(Sender: TObject);
procedure design;
procedure design2;
procedure Image7Click(Sender: TObject);
procedure Image7DblClick(Sender: TObject);
procedure Image7MouseEnter(Sender: TObject);
procedure Image7MouseLeave(Sender: TObject);
procedure ListBox3Click(Sender: TObject);
procedure MenuItem1Click(Sender: TObject);
procedure MenuItem2Click(Sender: TObject);
procedure MenuItem3Click(Sender: TObject);
procedure MenuItem5Click(Sender: TObject);
procedure MenuItem6Click(Sender: TObject);
procedure OnStatus(sender: TObject; Reason: THookSocketReason;
const Value: string) ;
private
{ Private declarations }
public
{ public declarations }
end;
teraz procedury wątku łączace się z internetem:
procedure Tczas.neton; // sprawdzanie lączenia i spójnosci danych... utworzenie pierwszych katalogów itp
label 1,2,3,4,5;
begin
if rozlaczpo=false then if ftp1.login then GOTO 4 else goto 2; // rozlaczpo gdy true znaczy ze jest zalogowany już
4:
if ftp1.CreateDir('memo')=true then begin;
ftp1.CreateDir('memo/users');
status:=form1.ListBox1.Items.Strings[53+3];
if ftp1.FileSize('memo/users/index.dat')=-1 then begin;
ftp1.DirectFile := true;
totalbytes:=checkfilesize(path+'users/index.dat'); CurrentBytes := 0;
ftp1.DirectFileName := path+'users/index.dat';
ftp1.StoreFile('memo/users/index.dat', false);
end;
if ftp1.FileSize('memo/users/us.dat')=-1 then begin;
ftp1.DirectFile := true;
totalbytes:=checkfilesize(path+'users/us.dat');
CurrentBytes := 0;
ftp1.DirectFileName := path+'users/us.dat';
ftp1.StoreFile('memo/users/us.dat', false);
end;
end;
status:=form1.ListBox1.Items.Strings[54+3];
synchronize(@kopia);
ftp1.DirectFile := true;
ftp1.DirectFileName := path+'users/us.dat';
totalbytes:=ftp1.FileSize('memo/users/us.dat');
if (ftp1.FileSize('memo/users/uscopy.dat')<>-1) and (ftp1.FileSize('memo/users/us.dat')=-1) then ftp1.renamefile('memo/users/uscopy.dat','memo/users/us.dat');
CurrentBytes := 0;
status:=form1.ListBox1.Items.Strings[45+3];
if (ftp1.retrievefile('memo/users/us.dat',false)=false) and (ftp1.retrievefile('memo/users/uscopy.dat',false)=false) then
begin
if fileexists(path+'users/us.dat') then deletefile(path+'users/us.dat');
odczyt:=false; // nie udalo sie pobrac pliku bez problemu
renamefile(path+'users/uscopy.dat',path+'users/us.dat'); //przywraca kopie
end else
begin
odczyt:=true;
deletefile(path+'users/uscopy.dat'); // jesli sie udalo odczytac bez bledu to usuwa kopie zapasową
end;
if (odczyt=true) and (fileexists(path+'users/uszmiany.txt')) then begin
status:=form1.ListBox1.Items.Strings[55+3];
synchronize(@zaleglosci);
ftp1.DirectFile := true;
ftp1.DirectFileName := path+'users/uscopy2.dat';
totalbytes:=checkfilesize(path+'users/uscopy2.dat');
CurrentBytes := 0;
if ftp1.StoreFile('memo/users/uscopy.dat', false)= true then zapis:=true else zapis:=false;
if zapis=true then // jesli udalo sie wyslac zaleglosci na ftp
begin
ftp1.DeleteFile('memo/users/us.dat');
ftp1.renameFile('memo/users/uscopy.dat','memo/users/us.dat');
deletefile(path+'users/uszmiany.txt');
deletefile(path+'users/us.dat');
renamefile(path+'users/uscopy2.dat',path+'users/us.dat');
end;
end;
net:=true;
goto 3;
2:
net:=false;
3:
end;
procedure tczas.execute; // laczy z netem i sprawdza net, zapisuje zalegle informacje jesli sa..
label 1;
var x:integer;
begin
while watek=true do begin end; // zabezpieczenie zeby nie uruchmic watku kilka razy przypadkiem
watek:=true;
if rozlaczpo=false then ftp1:= tftpsend.Create;
ftp1.TargetHost := form1.edit15.text;
ftp1.Username :=form1.edit16.text;
ftp1.Password := form1.Edit17.text;
ftp1.TargetPort := '21';
ftp1.dSock.OnStatus:[email protected];
synchronize(@newserwer);
status:=form1.ListBox1.Items.Strings[44+3];
neton;
status:=form1.ListBox1.Items.Strings[46+3];
synchronize(@spojnosc); // jesli blad w strukturze danych to przywraca kopie
status:=form1.ListBox1.Items.Strings[57+3];
synchronize(@start); // ustawia zaktualizowane dane na formie
rozlaczpo:=false;
if net=true then ftp1.Logout;
watek:=false;
ftp1.Free;
end;