type
TUploadCallback =
procedure(lpszLocal, lpszRemote:
string; dwBytesTotal, dwBytesDone: DWORD; Elapsed: Single);
procedure MyUploadCallback(lpszLocal, lpszRemote:
string; dwBytesTotal, dwBytesDone: DWORD; Elapsed: Single);
begin
with frmMain
do
begin
Label1.Caption := '
Filename: ' + lpszLocal;
Label2.Caption := '
Remotename: ' + lpszRemote;
Label3.Caption := '
Done: ' + Format('
%2.n KB/%2.n KB', [dwBytesDone / 1024, dwBytesTotal / 1024]);
Label4.Caption := '
Percent: ' + IntToStr(Integer(Round((dwBytesDone * 100) / dwBytesTotal)));
ProgressBar1.Max := 100;
ProgressBar1.Position := Integer(Round((dwBytesDone * 100) / dwBytesTotal));
Label5.Caption := '
Elapsed: ' + Format('
%2.n sec', [Elapsed]);
if (Elapsed > 0)
then
Label6.Caption := '
Speed: ' + Format('
%2.n KB/sec', [dwBytesDone / Elapsed]);
end;
end;
function UploadFolder(lpszServer, lpszUsername, lpszPassword, lpszLocalDirectory, lpszRemoteDirectory:
String; lpUploadCallback: TUploadCallback =
nil; UploadSubFolders: Boolean = True; wPort: Word = 21): Boolean;
const
sErrorDirectoryUpload = '
Das Verzeichnis "%s" konnte nicht auf den Server geladen werden!';
sErrorDirectoryCreate = '
Das Verzeichnis "%s" konnte nicht auf dem Server erstellt werden!';
sErrorDirectorySet = '
Es konnte nicht in das Verzeichnis "%s" gewechselt werden!';
sErrorFileCreate = '
Datei "%s%s" konnte nicht erstellt werden!';
sErrorFileNotFound = '
Datei "%s" konnte nicht gefunden werden!';
sErrorWriting = '
Es trat ein Fehler während des schreibens in die Datei auf!';
const
PACKET_SIZE = 1024 * 2;
var
hOpen, hConnect: HINTERNET;
function UploadFile(lpszLocal, lpszRemote:
String): Boolean;
var
hFile: HINTERNET;
hLocalFile: THandle;
dwFileSize: DWORD;
lpNumberOfBytesRead, lpNumberOfBytesWritten, lpBytesDone, lpStartTicker, lpTicker: DWORD;
lpBuffer:
array[0..PACKET_SIZE]
of Byte;
begin
// wir sind schon im aktuellem Verzeichnis, deswegen kein FtpSetCurrentDirectory..
Result := False;
// ok, jetzt mal lokal überprüfen ob alles da ist und die dateigröße auslesen
hLocalFile := CreateFile(PChar(lpszLocal), GENERIC_READ, FILE_SHARE_READ,
nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if (hLocalFile <> INVALID_HANDLE_VALUE)
or (hLocalFile <> 0)
then
begin
dwFileSize := Windows.GetFileSize(hLocalFile,
nil);
hFile := FtpOpenFile(hConnect, PChar(lpszRemote), GENERIC_WRITE, INTERNET_FLAG_TRANSFER_BINARY, 0);
if (hFile <>
nil)
then
begin
SetFilePointer(hLocalFile, 0,
nil, FILE_BEGIN);
InternetSetFilePointer(hFile, 0,
nil, FILE_BEGIN, 0);
ZeroMemory(@lpBuffer, SizeOf(lpBuffer));
lpBytesDone := 0;
lpNumberOfBytesWritten := 0;
lpStartTicker := GetTickCount;
// Download start
repeat
Application.ProcessMessages;
lpNumberOfBytesRead := 0;
Sleep(1);
lpTicker := GetTickCount;
ReadFile(hLocalFile, lpBuffer, PACKET_SIZE, lpNumberOfBytesRead,
nil);
InternetWriteFile(hFile, @lpBuffer, lpNumberOfBytesRead, lpNumberOfBytesWritten);
if (lpNumberOfBytesWritten = lpNumberOfBytesRead)
then
begin
Result := True;
Inc(lpBytesDone, lpNumberOfBytesWritten);
if Assigned(lpUploadCallback)
then
lpUploadCallback(lpszLocal, lpszRemote, dwFileSize, lpBytesDone, (lpTicker - lpStartTicker) / 1000);
end else
begin
Result := False;
MessageBox(HWND_DESKTOP, PChar(sErrorWriting), '
Error', MB_ICONERROR);
Break;
end;
until (lpBytesDone >= dwFileSize);
InternetCloseHandle(hFile);
end;
// datei handle schließen ..
CloseHandle(hLocalFile);
end else
begin
// datei konnte nicht gefunden werden
MessageBox(HWND_DESKTOP, PChar(Format(sErrorFileNotFound, [lpszLocal])), '
Error', MB_ICONERROR);
end;
end;
function UploadDirectory(lpszPath, lpszRemote:
String): Boolean;
var
lpFindFileData: TWIN32FindData;
hFindFile: THandle;
szLastDirectory:
String;
begin
Result := False;
lpszPath := IncludeTrailingPathDelimiter(lpszPath);
// wir brauchen hier den Namen vom letzten Verzeichnis, also den den wir gerade durchsuchen, um dann FtpSetCurrentDIrectory
// aufzurufen.
lpszRemote := ExcludeTrailingPathDelimiter(lpszRemote);
if LastDelimiter('
\', lpszRemote) > 0
then
szLastDirectory := Copy(lpszRemote, LastDelimiter('
\', lpszRemote) +1, Length(lpszRemote))
else
if LastDelimiter('
/', lpszRemote) > 0
then
szLastDirectory := Copy(lpszRemote, LastDelimiter('
/', lpszRemote) +1, Length(lpszRemote))
else
szLastDirectory := lpszRemote;
lpszRemote := IncludeTrailingPathDelimiter(lpszRemote);
if (szLastDirectory <> '
')
then
begin
if not FtpCreateDirectory(hConnect, PChar(szLastDirectory))
then
begin
// Verzeichnis konnte nicht erstellt werden, versuche noch in das Verzeichnis zu wechseln
if not FtpSetCurrentDirectory(hConnect, PChar(szLastDirectory))
then
begin
MessageBox(HWND_DESKTOP, PChar(Format(sErrorDirectoryCreate, [szLastDirectory])), '
Error', MB_ICONERROR);
Exit;
end;
end else
begin
// Verzeichnis setzen, in dem wir Arbeiten
if not FtpSetCurrentDirectory(hConnect, PChar(szLastDirectory))
then
begin
MessageBox(HWND_DESKTOP, PChar(Format(sErrorDirectorySet, [szLastDirectory])), '
Error', MB_ICONERROR);
Exit;
end;
end;
end;
// Prüfen ob das Verzeichnis auf dem lokalen PC existiert.
if DirectoryExists(lpszPath)
then
begin
hFindFile := FindFirstFile(PChar(lpszPath + '
*.*'), lpFindFileData);
if (hFindFile <> INVALID_HANDLE_VALUE)
then
begin
repeat
if ((
String(lpFindFileData.cFileName) = '
.')
or (
String(lpFindFileData.cFileName) = '
..'))
then
continue;
// Dateien vom Verzeichnis uploaden ...
if (lpFindFileData.dwFileAttributes
and FILE_ATTRIBUTE_DIRECTORY = 0)
then
begin
if not UploadFile(Format('
%s%s', [lpszPath, lpFindFileData.cFileName]), Format('
%s', [lpFindFileData.cFileName]))
then
begin
// Datei konnte nicht erstellt werden!
MessageBox(HWND_DESKTOP, PChar(Format(sErrorFileCreate, [lpszRemote, lpFindFileData.cFileName])), '
Error', MB_ICONERROR);
Windows.FindClose(hFindFile);
Exit;
end;
end else
// Ein Verzeichnis wurde gefunden also in das Verzeichnis wechseln und dort die Dateien suchen und die dann uploaden ..
begin
if UploadSubFolders
then
begin
if not UploadDirectory(Format('
%s%s', [lpszPath, lpFindFileData.cFileName]),
Format('
%s%s', [lpszRemote, lpFindFileData.cFileName]))
then
begin
MessageBox(HWND_DESKTOP, PChar(Format(sErrorDirectoryUpload, [lpszPath])), '
Error', MB_ICONERROR);
Exit;
end;
end;
end;
until not (FindNextFile(hFindFile, lpFindFileData));
Windows.FindClose(hFindFile);
if (szLastDirectory <> '
')
then
begin
// cd ..
if not FtpSetCurrentDirectory(hConnect, '
..')
then
begin
MessageBox(HWND_DESKTOP, PChar(Format(sErrorDirectorySet, ['
..'])), '
Error', MB_ICONERROR);
Exit;
end;
end;
Result := True;
end;
end;
end;
begin
Result := False;
hOpen := InternetOpen('
MyAgent', INTERNET_OPEN_TYPE_DIRECT,
nil,
nil, 0);
if (hOpen <>
nil)
then
begin
hConnect := InternetConnect(hOpen, PChar(lpszServer), wPort, PChar(lpszUsername), PChar(lpszPassword),
INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, 0);
if (hConnect <>
nil)
then
begin
Result := UploadDirectory(lpszLocalDirectory, lpszRemoteDirectory);
InternetCloseHandle(hConnect);
InternetCloseHandle(hOpen);
end;
end;
end;