Przesyłanie plików przez gniazda

2002-08-13 12:00
SEDTS
0

Witam
Przeglądając forum natrafiłem na kilka postów w których ktoś chciał źródła programu do przesyłania plików.
Oto one (program jest wersji oryginalnej także żeby przesyłał wszystkie rodzajepliów trzeba go przerobić:-)
Podane źródła to klient i serwer( jakby ktoś nie wiedział )

unit ClientForm;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ScktComp, ExtCtrls;

type
TCliStatus = (csIdle, csList, csBitmap, csText, csError);

TForm1 = class(TForm)
ClientSocket1: TClientSocket;
cbActivate: TCheckBox;
EditServer: TEdit;
Label4: TLabel;
btnExec: TButton;
EditServerFile: TEdit;
Label2: TLabel;
ListFiles: TListBox;
Label1: TLabel;
EditDir: TEdit;
btnGetDir: TButton;
LabelDir: TLabel;
Bevel1: TBevel;
btnBitmap: TButton;
btnText: TButton;
procedure ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure cbActivateClick(Sender: TObject);
procedure btnExecClick(Sender: TObject);
procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
procedure btnGetDirClick(Sender: TObject);
procedure ListFilesClick(Sender: TObject);
procedure btnBitmapClick(Sender: TObject);
procedure btnTextClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
CliStatus: TCliStatus;
Buffer: array [0..9999] of Char;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

uses
CliBmp, CliText;

procedure TForm1.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Caption := 'Connected';
end;

procedure TForm1.ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Caption := 'Disconnected';
end;

procedure TForm1.cbActivateClick(Sender: TObject);
begin
if not ClientSocket1.Active then
ClientSocket1.Address := EditServer.Text;
ClientSocket1.Active := cbActivate.Checked;
end;

procedure TForm1.btnExecClick(Sender: TObject);
begin
ClientSocket1.Socket.SendText ('EXEC!' + EditServerFile.Text);
end;

procedure TForm1.ClientSocket1Read(Sender: TObject;
Socket: TCustomWinSocket);
var
strIn: string;
Stream: TMemoryStream;
nReceived: Integer;
begin
case CliStatus of

  • look for data to receive
    csIdle:
    begin
    Socket.ReceiveBuf (Buffer, 5);
    strIn := Copy (Buffer, 1, 5);
    if strIn = 'TEXT!' then
    CliStatus := csText
    else if strIn = 'BITM!' then
    CliStatus := csBitmap
    else if strIn = 'LIST!' then
    CliStatus := csList
    else if strIn = 'ERROR' then
    CliStatus := csError;
    end;
  • show the messages (might actually not be an error)
    csError:
    begin
    ShowMessage (Socket.ReceiveText);
    cliStatus := csIdle;
    end;
  • get a directory listing
    csList:
    begin
    ListFiles.Items.Text := Socket.ReceiveText;
    cliStatus := csIdle;
    end;
  • read a text file
    csText:
    begin
    with TFormText.Create (Application) do
    begin
    Memo1.Text := Socket.ReceiveText;
    Show;
    end;
    cliStatus := csIdle;
    end;
  • read a bitmap file
    csBitmap:
    with TFormBmp.Create (Application) do
    begin
    Stream := TMemoryStream.Create;
    Screen.Cursor := crHourglass;
    try
    while True do
    begin
    nReceived := Socket.ReceiveBuf (Buffer, sizeof (Buffer));
    if nReceived &lt= 0 then
    Break
    else
    Stream.Write (Buffer, nReceived);
    • delay (200 milliseconds)
      Sleep (200);
      end;
      • reset and load the temporary file
        Stream.Position := 0;
        Image1.Picture.Bitmap.LoadFromStream (Stream);
        finally
        Stream.Free;
        Screen.Cursor := crDefault;
        end;
        Show;
        cliStatus := csIdle;
        end;
        end; * case
        end;

procedure TForm1.btnGetDirClick(Sender: TObject);
begin
ClientSocket1.Socket.SendText ('LIST!' + EditDir.Text);
LabelDir.Caption := EditDir.Text;
end;

procedure TForm1.ListFilesClick(Sender: TObject);
begin
EditServerFile.Text := LabelDir.Caption + '\' +
ListFiles.Items [ListFiles.ItemIndex];
end;

procedure TForm1.btnBitmapClick(Sender: TObject);
begin
ClientSocket1.Socket.SendText ('BITM!' + EditServerFile.Text);
end;

procedure TForm1.btnTextClick(Sender: TObject);
begin
ClientSocket1.Socket.SendText ('TEXT!' + EditServerFile.Text);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
CliStatus := csIdle;
end;

end.

////////////////////////////////////////////////////////////// Teraz serwer

unit ServerForm;

interface

{$WARN UNIT_PLATFORM OFF}

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ScktComp, StdCtrls, FileCtrl;

const
wm_RefreshClients = wm_User;

type
TForm1 = class(TForm)
ServerSocket1: TServerSocket;
lbClients: TListBox;
Label1: TLabel;
Label2: TLabel;
lbLog: TListBox;
FileListBox1: TFileListBox;
procedure ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
public
procedure RefreshClients (var Msg: TMessage);
message wm_RefreshClient
s;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
lbLog.Items.Add ('Connected: ' +
Socket.RemoteHost + ' (' +
Socket.RemoteAddress + ')' );
end;

procedure TForm1.ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
lbLog.Items.Add ('Disconnected: ' +
Socket.RemoteHost + ' (' +
Socket.RemoteAddress + ')' );
end;

procedure TForm1.RefreshClients;
begin
end;

procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
strCommand, strFile, strFeedback: string;
begin

  • read from the client
    strCommand := Socket.ReceiveText;
    lbLog.Items.Add ('Client: ' + Socket.RemoteAddress + ': ' +
    strCommand);

  • extract the file name (all commands have 5 characters)
    strFile := Copy (strCommand, 6, Length (strCommand) - 5);

  • execute program
    if Pos ('EXEC!', strCommand) = 1 then
    begin
    if FileExists (strFile) and (
    WinExec (pChar (strFile), sw_ShowNormal) &gt 31) then
    strFeedback := 'ERROR' + strFile + ' activated'
    else
    strFeedback := 'ERROR' + strFile + ' not found';
    Socket.SendText (strFeedback);
    end

  • send back a text file
    else if Pos ('TEXT!', strCommand) = 1 then
    begin
    if FileExists (strFile) then
    begin
    strFeedback := 'TEXT!';
    Socket.SendText (strFeedback);
    Socket.SendStream (TFileStream.Create (
    strFile, fmOpenRead or fmShareDenyWrite));
    end
    else
    begin
    strFeedback := 'ERROR' + strFile + ' not found';
    Socket.SendText (strFeedback);
    end;
    end

  • send back a bitmap file
    else if Pos ('BITM!', strCommand) = 1 then
    begin
    if FileExists (strFile) then
    begin
    strFeedback := 'BITM!';
    Socket.SendText (strFeedback);
    Socket.SendStream (TFileStream.Create (
    strFile, fmOpenRead or fmShareDenyWrite));
    end
    else
    begin
    strFeedback := 'ERROR' + strFile + ' not found';
    Socket.SendText (strFeedback);
    end;
    end

  • send back a directory listing
    else if Pos ('LIST!', strCommand) = 1 then
    begin
    if DirectoryExists (strFile) then
    begin
    strFeedback := 'LIST!';
    Socket.SendText (strFeedback);
    FileListBox1.Directory := strFile;
    Socket.SendText (FileListBox1.Items.Text);
    end
    else
    begin
    strFeedback := 'ERROR' + strFile + ' not found';
    Socket.SendText (strFeedback);
    end;
    end
    else
    begin
    strFeedback := 'ERROR' + 'Undefined command: ' + strCommand;
    Socket.SendText (strFeedback);
    end;

    // log result
    lbLog.Items.Add (strFeedback);
    end;

end.

--Cbmqenjvnz :-)
jmlfgxvpu xgóeml bqfmlsehwš jvnqbzbć....
FRQGF

Pozostało 580 znaków

2002-08-13 12:15
mwolinski
0

cos takiego napisal jusz pan Adam! :[[
LaMeRs WoRlD

--------BLOK REKLAMOWY------
kanał : #4programmers.net
server: warszawa.ircnet.pl
------BLOK REKLAMOWY------

Pozostało 580 znaków

2002-08-13 12:21
SEDTS
0

No rzeczywiście coś takiego jest w dziale kody źródłowe - nie zauważyłem :P
Ale może się komuś to właśnie przyda..........--Cbmqenjvnz :-)
jmlfgxvpu xgóeml bqfmlsehwš jvnqbzbć....
FRQGF

Pozostało 580 znaków

2002-08-14 14:54
Lofix
0

Może sie i przyda, dzięki za chęci --DELPHI RULEZ

Pozostało 580 znaków

Liczba odpowiedzi na stronę

1 użytkowników online, w tym zalogowanych: 0, gości: 1, botów: 0