' # VBarchiv.dll im Windows/system32/  Verzeichnis -
'
' ## Inhalt des Formulars - Name
' # Formular - Form1.frm.
'
' # Form1.frm.TextBox as Text1
' # Form1.frm.PicturesBox as picProgress
' # Form1.frm.cmdButton as Upload_FTP
' # Form1.frm.cmdButton as Command1
' #############################################################################
' ########
 
' Routinen, um die Dateigröße von lokalen Dateien
' zu ermitteln
Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, _
  lpReOpenBuff As Any, ByVal wStyle As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As _
Long
Private Declare Function GetFileSizeA Lib "kernel32.dll" Alias "GetFileSize" ( _
ByVal hFile As Long, lpFileSizeHigh As Long) As Long
 
Private Const OFS_MAXPATHNAME = 128
 
Private Type OFSTRUCT
  cBytes As Byte
  fFixedDisk As Byte
  nErrCode As Integer
  Reserved1 As Integer
  Reserved2 As Integer
  szPathName As String * OFS_MAXPATHNAME
End Type
' Lesen einer bestimmten Zeile einer Textdatei
' sFilename:  vollständiger Dateiname
' LineToRead: Zeile, deren Inhalt zurückgegeben werden soll
' =========================================================
Public Function txt_ReadLine(ByVal sFilename As String, _
  ByVal LineToRead As Long) As String
 
  Dim F As Integer
  Dim sLine As String
  Dim lRow As Long
 
  lRow = 0
  ' Existiert die Datei ?
  If Dir$(sFilename) <> "" Then
 
    ' Datei zum Lesen öffnen
    F = FreeFile
    Open sFilename For Input As #F
 
    ' Solange einlesen, bis entweder Dateiende
    ' oder gewünschte Zeilennummer erreicht
    While Not EOF(F) And lRow < LineToRead
      lRow = lRow + 1
      Line Input #F, sLine
    Wend
    Close #F
  End If
 
  ' Dateiende wurde frühzeitig erreicht,
  ' oder Datei war nicht vorhanden
  If lRow < LineToRead Then _
    sLine = ""
 
  txt_ReadLine = sLine
End Function
 
Public Function FileExists(ByVal sFile As String) As Boolean
 
  'Der Parameter sFile enthält den zu prüfenden Dateinamen
 
  Dim Size As Long
  On Local Error Resume Next
  Size = FileLen(sFile)
  FileExists = (Err = 0)
  On Local Error GoTo 0
End Function
' Fortschritsanzeige
Private Sub ShowProgress(picProgress As PictureBox, _
  ByVal Value As Long, _
  ByVal Min As Long, _
  ByVal Max As Long, _
  Optional ByVal bShowProzent As Boolean = True)
 
  Dim pWidth As Long
  Dim intProz As Integer
  Dim strProz As String
 
  ' Farben
  Const progBackColor = &HC00000
  Const progForeColor = vbBlack
  Const progForeColorHighlight = vbWhite
 
  ' Plausibilitätsprüfungen
  If Value < Min Then Value = Min
  If Value > Max Then Value = Max
 
  ' Prozentwert ausrechnen
  If Max > 0 Then
    intProz = Int(Value / Max * 100 + 0.5)
  Else
    intProz = 100
  End If
 
  With picProgress
    ' Prüfen, ob AutoReadraw=True
    If .AutoRedraw = False Then .AutoRedraw = True
 
    ' Inhalt löschen
    picProgress.Cls
 
    If Value > 0 Then
 
      ' Balkenbreite
      pWidth = .ScaleWidth / 100 * intProz
 
      ' Balken anzeigen
      picProgress.Line (0, 0)-(pWidth, .ScaleHeight), _
        progBackColor, BF
 
      ' Prozentanzeige
      If bShowProzent Then
        strProz = CStr(intProz) & " %"
        .CurrentX = (.ScaleWidth - .TextWidth(strProz)) / 2
        .CurrentY = (.ScaleHeight - .TextHeight(strProz)) / 2
 
        ' Vordergrundfarbe
        If pWidth >= .CurrentX Then
          .ForeColor = progForeColorHighlight
        Else
          .ForeColor = progForeColor
        End If
 
        picProgress.Print strProz
      End If
    End If
  End With
End Sub
'########## Ab hier Teil 2 anhängen !!! ##########

Gruss
Bobbel

' Dateigröße einer lokalen Datei ermitteln
Private Function GetLocalFileSize(ByVal Filename As String) As Long
  Dim RetVal As Long, hFile As Long, SizeLng As Long, OF As OFSTRUCT
 
  ' Datei öffnen
  hFile = OpenFile(Filename, OF, 0&)
  If hFile = -1 Then
    ' Datei existiert nicht!
    GetLocalFileSize = -1
    Exit Function
  End If
 
  ' Göße bestimmen und Datei schließen
  GetLocalFileSize = GetFileSizeA(hFile, SizeLng)
  CloseHandle hFile
End Function
 
 
 
Private Sub Command1_Click()
Unload Me
End Sub
 
Private Sub Upload_FTP_Click()
Dim txtHost As String
Dim txtUser As String
Dim txtKennwort As String
Dim txtPort As String
Dim txtServerpfad As String
Dim txtLocalFile As String
Dim txtServerFile As String
Dim txtWebPfad As String
Dim zaehler As Long
 
Dim antUpload As Long
Dim pSocket As Long
 
 
'#### 1. wird später im PGM bedient !!!
' Bitte hier die entsprechenden Angaben selber ausfüllen !
 
'txtHost = "www.mein-Server.de"  'Anstatt IP den DNS-Namen!
txtHost = "xxx.xxx.xxx.xxx"
txtUser = "xxxxxxxxxx"
txtKennwort = "xxxxxxxxx"
txtPort = "21"
txtServerpfad = "" 'falls erfordelich, ansonsten leer lassen !
ServerLog = ""
 
'#### 1. Ende ##########################
 
 
    AddStatus "        Verbindung wird aufgebaut, ...."
    AddStatus "        Connect zum Server: " & txtHost
 
    pSocket = ftpConnect(txtHost, txtUser, txtKennwort)
 
    If pSocket > 0 Then
      AddStatus ftpGetLastStatusCode & " " & ftpGetLastStatusMsg
 
      antUpload = ftpChangeDir(pSocket, txtServerpfad)
 
      If antUpload > 0 Then 'Verzeichniswechsel
       AddStatus "       cd ... " & txtServerpfad
       AddStatus ftpGetLastStatusCode & " " & ftpGetLastStatusMsg
       Else
       AddStatus ftpGetLastStatusCode & " " & ftpTranslateErrorCode( _
         ftpGetLastStatusCode) & "  ->  '" & txtServerpfad & "'"
       AddStatus "## Trenne die Verbindung ! ##"
       ftpQuit (pSocket)
       AddStatus "## Verbindung wurde getrennt ! ##"
       AddStatus ftpGetLastStatusCode & " " & ftpGetLastStatusMsg
       Exit Sub
      End If
 
 
 
 
        If FileExists(App.Path & "\export\" & "WebSeiten.txt") = True Then
           AddStatus "      Indexdatei wird vorbereitet, ..."
         Else
           AddStatus "      ErrorCode 9071 -> Index nicht vorhanden !"
           AddStatus "## Trenne die Verbindung ! ##"
           ftpQuit (pSocket)
           AddStatus "## Verbindung wurde getrennt ! ##"
           AddStatus ftpGetLastStatusCode & " , " & ftpGetLastStatusMsg
           Exit Sub
        End If
 
      ' Prüfen ob Datei im ASCII oder Binary mode übertragen werden muss !!!
      ftpSetBinary (pSocket) 'zum testen alles Binary !!!!
      AddStatus ftpGetLastStatusCode & " , " & ftpGetLastStatusMsg
 
'#############################################################################
 AddStatus "########### Neue Schleife !!! ##########"  'nur zum testen !
 
       'Einträge ermittel für die Schleife 14.03.2012
        Dim H As Integer
        Dim ii As Integer  'Zähler für Split-Funktion
        Dim s_Line As String
        Dim nCount As Long
        Dim s_File As String
        Dim test_local As String
        Dim test_server As String
        Dim Ext As String
        Dim s_line_2 As String
        Dim sPfad() As String  'isoliereter Pfad
 
                 s_File = (App.Path & "\export\" & "WebSeiten.txt")
                 ' Datei sequentiell öffnen und zeilenweise auslesen
                 H = FreeFile
                 Open s_File For Input As #H
                 While Not EOF(H)
                   Line Input #H, s_Line
                   nCount = nCount + 1
                 Wend
                 Close #H
                ' MsgBox nCount 'test !
                '    MsgBox zaehler & "   " & nCount
 
             'Schleife vorbereiten -> 1. Zeile in der Datei überspringen
              zaehler = 2
              Do Until zaehler > nCount
'########### Ab hier Teil 3 anhängen !!! #####################

Gruss
Bobbel

              s_Line = txt_ReadLine(s_File, zaehler) 'Liest Zeilenweise die 
              ' Datei s_File aus und übergibt Zeile an s_Line
              'Eintrage mit Schleife verbinden
 
               ' HTML-Extension
               Ext = Mid$(s_Line, InStrRev(s_Line, "."))
               If Ext = ".html" Then
                  s_line_2 = "\export" & s_Line
               Else
                 s_line_2 = s_Line
               End If
              '###### Pfade isolieren ##########
               Ext = ""
               txtServerFile = ""
               txtWebPfad = ""
               sPfad = Split(s_Line, "\")
               For ii = 0 To UBound(sPfad)
                If sPfad(ii) > "" Then
                 If InStrRev(sPfad(ii), ".") > 0 Then
                    txtServerFile = sPfad(ii)
                    Else
                    txtWebPfad = sPfad(ii)
                    End If
                End If
               Next ii
              '###### Ende Pfade isolieren #####
 
              localFile = GetLocalFileSize(App.Path & s_line_2)
 
              test_local = (App.Path & s_line_2)
              test_server = (Replace(txtServerpfad & Replace(s_Line, "\", "/"), _
                "//", "/"))
 
 
           'antUpload = 1  ' Nur zum testen only !!!!!
 
           ' Verzeichnis wechseln auf Server
             If txtWebPfad > "" Then
                antUpload = ftpChangeDir(pSocket, txtWebPfad)
                  If antUpload > 0 Then 'Verzeichniswechsel
                    AddStatus ftpGetLastStatusCode & " " & ftpGetLastStatusMsg _
                      'Status udn weiter
                   Else
                    AddStatus ftpGetLastStatusCode & " " & _
                      ftpTranslateErrorCode(ftpGetLastStatusCode) & "  -> " & _
                      "'" & txtServerpfad & "'"
                    antUpload = ftpMakeDir(pSocket, txtWebPfad) 'fehlendes 
                    ' verzeichnis anlegen
                     If antUpload > 0 Then
                       antUpload = ftpChangeDir(pSocket, txtWebPfad) ' in das 
                       ' anglegte Verzeichnis wechseln
                       If antUpload > 0 Then
                        ' wenn o.k. dann weiter
                        Else
                         AddStatus ftpGetLastStatusCode & " " & _
                           ftpTranslateErrorCode(ftpGetLastStatusCode) & " " & _
                           "->  '" & txtServerpfad & "'"
                         MsgBox "Es ist ein Serverfehler aufgetreten !"
                         AddStatus "## Trenne die Verbindung ! ##"
                         ftpQuit (pSocket)
                         AddStatus "## Verbindung wurde getrennt ! ##"
                         AddStatus ftpGetLastStatusCode & " , " & _
                           ftpGetLastStatusMsg
                         Exit Sub
                       End If
                      Else
                       AddStatus ftpGetLastStatusCode & " " & _
                         ftpTranslateErrorCode(ftpGetLastStatusCode) & "  ->" & _
                         " '" & txtServerpfad & "'"
                       MsgBox "Konnte das Verzeichnis " & txtWebPfad & " nicht" & _
                       "anlegen !"
                       AddStatus "## Trenne die Verbindung ! ##"
                       ftpQuit (pSocket)
                       AddStatus "## Verbindung wurde getrennt ! ##"
                       AddStatus ftpGetLastStatusCode & " , " & _
                         ftpGetLastStatusMsg
                       Exit Sub
                     End If
                   End If
                   ' kein Verzeichniswechsel nötig !
                 End If
 
               ShowProgress picProgress, zaehler, 0, nCount   ' Progress updaten
 
               txtLocalFile = App.Path & s_line_2
               antUpload = ftpPutFile(pSocket, txtHost, 0, txtServerFile, _
                 txtLocalFile)

Gruss
Bobbel

               ' ### ServerVerzwichnis wieder auf Root-verzeichnis setzen !
               If txtWebPfad > "" Then
                antUpload = ftpChangeDir(pSocket, "..") ' Verzeichnis wieder 
                ' auf Root-Verzeichnis setzen !
                 If antUpload > 0 Then
                  ' wenn o.k. dann weiter
                  Else
                   AddStatus ftpGetLastStatusCode & " " & ftpTranslateErrorCode( _
                     ftpGetLastStatusCode) & "  ->  '" & txtServerpfad & "'"
                   MsgBox "Error-Code 4598 -> Es ist ein Serverfehler" & _
                   "aufgetreten !"
                   AddStatus "## Trenne die Verbindung ! ##"
                   ftpQuit (pSocket)
                   AddStatus "## Verbindung wurde getrennt ! ##"
                   AddStatus ftpGetLastStatusCode & " , " & ftpGetLastStatusMsg
                   Exit Sub
                 End If
                 ' wieder auf Root-Verzeichnis !
                End If
           ' ### ENDE Root-Verzeichnis !
 
        If antUpload > 0 Then
          AddStatus "Übertrage: " & (App.Path & s_line_2)   ' Nur zum testen !!!
          AddStatus "STOR " & localFile & " kByte  " & (Replace(txtServerpfad & _
            Replace(s_Line, "\", "/"), "//", "/"))   ' Nur zum testen !!!
         Else
          AddStatus ftpGetLastStatusCode & " " & ftpTranslateErrorCode( _
            ftpGetLastStatusCode) & "  ->  '" & localFile & "'"
          AddStatus "## Datei wurde nicht übertragen !!! ##"
          AddStatus "## Trenne die Verbindung ! ##"
          ftpQuit (pSocket)
          AddStatus "## Verbindung wurde getrennt ! ##"
          AddStatus ftpGetLastStatusCode & " " & ftpGetLastStatusMsg
          Exit Sub
        End If
 
    zaehler = zaehler + 1  ' Zähler um 1 erhöhen
    Loop
 
        '### Test mehrere dateien auf einmal senden ###
        '### Ende Datei Schleife FTP-Upload
'##############################################################################
 
AddStatus "####### ENDE Neue Schleife !!! ########"
 
    Else
      AddStatus ftpGetLastStatusCode & " " & ftpTranslateErrorCode( _
        ftpGetLastStatusCode)
      AddStatus "      Login nicht möglich, ..."
      AddStatus "      Überprüfen Sie die Zugangsdaten !"
      AddStatus "## Trenne die Verbindung !##"
      ftpQuit (pSocket)
      AddStatus "## Verbindung wurde getrennt ! ##"
      AddStatus ftpGetLastStatusCode & " " & ftpGetLastStatusMsg
      Exit Sub
    End If
 
    ftpQuit (pSocket)
    AddStatus "## Verbindung zum Server: " & txtServer & " geschlossen ! ##"
    AddStatus ftpGetLastStatusCode & " " & ftpGetLastStatusMsg
 
End Sub
 
Private Sub AddStatus(ByVal sText As String)
 
  ' Status-Feld aktualisieren
  If Right$(sText, 2) <> vbCrLf Then _
    sText = sText & vbCrLf
  ServerLog.Text = ServerLog.Text & sText
  ServerLog.SelStart = Len(ServerLog.Text)
 
End Sub
'############## Ende des Scripts Form1.frm #################

Gruss
Bobbel

...
                   ' kein Verzeichniswechsel nötig !
                 End If
 
               ShowProgress picProgress, zaehler, 0, nCount   ' Progress updaten
               picProgress.Refresh                            ' Mit dieser 
               ' Zeile wird der Laufbalken sichtbar !
               txtLocalFile = App.Path & s_line_2
               antUpload = ftpPutFile(pSocket, txtHost, 0, txtServerFile, _
                 txtLocalFile)
...

Gruss
Bobbel