function HttpPutFile(url, fn: string; hintProgress: ThintProgress): Boolean;
var
buf: array[0..32768 - 1] of char;
bufsize: dword;
lf: file;
FUrl, fsrvr: string;
nServerPort: word;
fsize, totsize: int64;
NetHandle: hinternet;
hconnect: hinternet;
hintfile: hinternet;
lpdword: Dword;
bufferin: INTERNET_BUFFERS;
// ErrCode: Integer;
wsize: int64;
NowP, i: integer;
function ExtractServer(url: string): string;
begin
if Pos('://', UpperCase(url)) > 0 then
Delete(url, 1, Pos('://', url) + 2);
if Pos('@', UpperCase(url)) > 0 then
Delete(url, 1, Pos('@', url) + 1);
if Pos('/', url) > 0 then
url := Copy(url, 1, Pos('/', url) - 1);
Result := url;
end;
function RemoveServer(url: string): string;
begin
if Pos('://', UpperCase(url)) > 0 then
Delete(url, 1, Pos('://', url) + 2);
if Pos('@', UpperCase(url)) > 0 then
Delete(url, 1, Pos('@', url) + 1);
if Pos('/', url) > 0 then
Delete(url, 1, Pos('/', url) - 1);
Result := url;
end;
begin
Result := False;
if DirectoryExists(ExtractFilePath(url)) then
begin
if FileExists(fn) then
Result := CopyFile(pchar(fn), pchar(url), false);
exit;
end;
// url := url + fn;
FUrl := url;
if not FileExists(fn) then
Exit;
fsrvr := ExtractServer(url);
nServerPort := INTERNET_DEFAULT_HTTP_PORT;
i := pos(':', fsrvr);
if i > 0 then
begin
nServerPort := StrToInt(trim(copy(fsrvr, i + 1, maxint)));
fsrvr := trim(copy(fsrvr, 1, i - 1));
end;
url := RemoveServer(url);
NetHandle := InternetOpen('HttpSendRequestEx', INTERNET_OPEN_TYPE_PRECONFIG {or INTERNET_FLAG_ASYNC}, nil, nil, 0);
if assigned(NetHandle) then
begin
hconnect := InternetConnect(NetHandle, PChar(fsrvr), nServerPort, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
hintfile := HttpOpenRequest(HConnect, 'PUT', PChar(url + #0), nil, nil, nil, INTERNET_FLAG_NO_CACHE_WRITE, 0);
if hintfile = nil then
begin
Exit;
end;
if hintfile <> nil then
begin
AssignFile(lf, fn);
Reset(lf, 1);
TotSize := FileSize(lf);
bufsize := 32768;
FSize := 0;
FillChar(bufferin, SizeOf(bufferin), 0);
bufferin.dwStructSize := SizeOf(INTERNET_BUFFERS);
bufferin.dwBufferTotal := TotSize;
wsize := 0;
if HttpSendRequestEx(hintfile, @bufferin, nil, HSR_INITIATE, 0) then
begin
while (bufsize = 32768) do
begin
BlockRead(lf, buf, 32768, bufsize);
if not InternetWriteFile(hintfile, @buf, bufsize, lpdword) then
begin
CloseFile(lf);
InternetCloseHandle(hintfile);
InternetCloseHandle(hconnect);
InternetCloseHandle(NetHandle);
hintProgress('', 0);
exit;
end;
wsize := wsize + lpdword;
FSize := FSize + bufsize;
if lpdword > 0 then
begin
NowP := Round(100 * FSize / totsize);
if NowP <> i then
begin
hintProgress('正在上传文件:', NowP);
i := NowP;
Application.ProcessMessages;
end;
end;
end;
HttpEndRequest(hintfile, nil, 0, 0);
end;
CloseFile(lf);
InternetCloseHandle(hintfile);
InternetCloseHandle(hconnect);
Result := FSize = TotSize;
end;
InternetCloseHandle(NetHandle);
// hintProgress('', 0);
end;
end;
