Ordner oder Datei ohne indys per ftp uploaden mit fortschrit

[smallsmoker]

Hallo DP,
hier habe eine funktion von ErazerZ gefunden die ich um die funktionalität erweitert habe auch eine datei hochzuladen (was ja eigentlich schon integriert war).

Delphi-Quellcode:

type
  TUploadCallback = procedure(lpszLocal, lpszRemote: string; dwBytesTotal, dwBytesDone: DWORD; Elapsed: Single);

procedure MyUploadCallback(lpszLocal, lpszRemote: string; dwBytesTotal, dwBytesDone: DWORD; Elapsed: Single);
begin
  with Form4 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 UploadFileorFolder(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;  // Upload 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);
    try
      if (hConnect <> nil) then
        if fileexists(lpszLocalDirectory) then
          begin
            FtpCreateDirectory(hConnect,pchar(lpszRemoteDirectory));
            if FtpSetCurrentDirectory(hConnect,pchar(lpszRemoteDirectory)) then
              Result := UploadFile(lpszLocalDirectory,extractfilename(lpszLocalDirectory))
            else
              MessageBox(HWND_DESKTOP, PChar(Format(sErrorDirectorySet, [lpszRemoteDirectory])), 'Error', MB_ICONERROR);
          end
        else
          Result := UploadDirectory(lpszLocalDirectory, lpszRemoteDirectory);
    finally
      InternetCloseHandle(hConnect);
      InternetCloseHandle(hOpen);
    end;
  end;
end;

Beispielaufruf für ordner upload:

Delphi-Quellcode:

if UploadFileorFolder('meinname.meinhost.de', 'meinusername', 'meinpasswort',  'C:\Testordner\', 'remoteordner', @MyUploadCallback) then
  ShowMessage('Der Upload war erfolgreich !');

Beispielaufruf für Datei upload:

Delphi-Quellcode:

if UploadFileorFolder('meinname.meinhost.de', 'meinusername', 'meinpasswort',  'C:\Testordner\meinedatei.txt', '', @MyUploadCallback) then
  ShowMessage('Der Upload war erfolgreich !');

wenn lpszRemoteDirectory = "" ist dann wird in den root ordner geuploaded

mfg smallsmoker

[StoRmtec]

Hallo
Danke sowas habe ich schon lämger gesucht.
Kann man da auch noch dazu machen das er den Ordner auch wieder downloaded ????????
Wäre echt cool

Danke
StoRmtec