unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs,
StdCtrls, ComCtrls, ExtCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
bUpload: TButton;
lb0: TLabel;
lb100: TLabel;
lbProgressCap: TLabel;
lbProgress: TLabel;
pb: TProgressBar;
procedure bUploadClick(Sender: TObject);
private
FTotSize: Int64;
procedure DoOnReadStream(Sender: TObject; APos: Int64);
function UploadFile(const AURL, AFieldName, ASrcFileName, ADstFileName: String;
out AError: String): Boolean;
function FormatSize(Size: Int64): String;
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
uses fphttpclient, openssl, opensslsockets;
{ TDownloadStream }
type
TOnReadStream = procedure(Sender: TObject; APos: Int64) of object;
TUploadStream = class(TStream)
private
FOnReadStream: TOnReadStream;
FStream: TStream;
public
constructor Create(AStream: TStream);
destructor Destroy; override;
function Read(var Buffer; Count: LongInt): LongInt; override;
function Write(const Buffer; Count: LongInt): LongInt; override;
function Seek(Offset: LongInt; Origin: Word): LongInt; override;
procedure DoProgress;
published
property OnReadStream: TOnReadStream read FOnReadStream write FOnReadStream;
end;
constructor TUploadStream.Create(AStream: TStream);
begin
inherited Create;
FStream:= AStream;
FStream.Position:= 0;
end;
destructor TUploadStream.Destroy;
begin
FStream.Free;
inherited Destroy;
end;
function TUploadStream.Read(var Buffer; Count: LongInt): LongInt;
begin
Result:= FStream.Read(Buffer, Count);
DoProgress;
end;
function TUploadStream.Write(const Buffer; Count: LongInt): LongInt;
begin
Result:= FStream.Write(Buffer, Count);
end;
function TUploadStream.Seek(Offset: LongInt; Origin: Word): LongInt;
begin
Result:= FStream.Seek(Offset, Origin);
end;
procedure TUploadStream.DoProgress;
begin
if Assigned(FOnReadStream) then
FOnReadStream(Self, Self.Position);
end;
function TForm1.UploadFile(const AURL, AFieldName, ASrcFileName, ADstFileName: String;
out AError: String): Boolean;
var
SS: TStringStream;
HTTPClient: TFPHTTPClient;
US: TUploadStream;
begin
Result:= False;
SS:= TStringStream.Create('');
try
HTTPClient:= TFPHTTPClient.Create(nil);
try
HTTPClient.AllowRedirect:= True;
US:= TUploadStream.Create(TFileStream.Create(ASrcFileName, fmOpenRead or fmShareDenyWrite));
try
FTotSize:= US.Size;
US.FOnReadStream:= @DoOnReadStream;
try
HTTPClient.StreamFormPost(AURL, AFieldName, ADstFileName, US, SS);
except
on E: Exception do
AError:= E.Message;
end;
finally
US.Free
end;
Result:= SS.DataString = 'zipok';
if (not Result) and (Trim(SS.DataString) <> '') then
AError:= SS.DataString;
finally
HTTPClient.Free;
HTTPClient:= nil;
end;
finally
SS.Free;
end;
end;
function TForm1.FormatSize(Size: Int64): String;
const
KB = 1024;
MB = 1024 * KB;
GB = 1024 * MB;
begin
if Size < KB then
Result:= FormatFloat('#,##0 Bytes', Size)
else if Size < MB then
Result:= FormatFloat('#,##0.0 KB', Size / KB)
else if Size < GB then
Result:= FormatFloat('#,##0.0 MB', Size / MB)
else
Result:= FormatFloat('#,##0.0 GB', Size / GB);
end;
procedure TForm1.DoOnReadStream(Sender: TObject; APos: Int64);
var
Value: Integer;
begin
if FTotSize = 0 then
Exit;
lbProgress.Caption:= FormatSize(APos) + '/' + FormatSize(FTotSize);
Value:= Round(100*APos/FTotSize);
//workaround for pb animation bug(vista+) --> pb.Postion:= Value;
if Value < pb.Max then
begin
pb.Position:= Value + 1;
pb.Position:= pb.Position - 1;
end
else
begin
pb.Max:= pb.Max + 1;
pb.Position:= pb.Max;
pb.Position:= pb.Position - 1;
pb.Max:= pb.Max - 1;
end;
//end workaround
Application.ProcessMessages;
Sleep(10);
end;
procedure TForm1.bUploadClick(Sender: TObject);
var
ErrMsg: String;
begin
if UploadFile('https://xxxxxx.xxx/upload.php', 'bin', 'file.ext', 'file.ext', ErrMsg) then
ShowMessage('Successfully uploaded!')
else
ShowMessage('Cannot upload file: ' + sLineBreak + ErrMsg);
end;
end.
Recent
