Option Explicit
' Deklarationen für die wait-Funktion
Private Declare Function WaitForSingleObject Lib _
  "kernel32" ( _
  ByVal hHandle As Long, _
  ByVal dwMilliseconds As Long) As Long
 
 
' Alle benötigten API-Deklarationen
Private Declare Function InternetOpen Lib "wininet.dll" _
 Alias "InternetOpenA" ( _
 ByVal sAgent As String, _
 ByVal nAccessType As Long, _
 ByVal sProxyName As String, _
 ByVal sProxyBypass As String, _
 ByVal nFlags As Long) As Long
 
Private Declare Function InternetCloseHandle _
 Lib "wininet.dll" ( _
 ByVal hInet As Long) As Integer
 
Private Declare Function InternetConnect _
 Lib "wininet.dll" Alias "InternetConnectA" ( _
 ByVal hInternetSession As Long, _
 ByVal sServerName As String, _
 ByVal nServerPort As Integer, _
 ByVal sUsername As String, _
 ByVal sPassword As String, _
 ByVal nService As Long, _
 ByVal nFlags As Long, _
 ByVal nContext As Long) As Long
 
Private Declare Function FtpPutFile _
 Lib "wininet.dll" Alias "FtpPutFileA" ( _
 ByVal hFtpSession As Long, _
 ByVal lpszLocalFile As String, _
 ByVal lpszRemoteFile As String, _
 ByVal dwFlags As Long, _
 ByVal dwContext As Long) As Boolean
 
' Kostanten
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_INVALID_PORT_NUMBER = 0
Private Const INTERNET_SERVICE_FTP = 1
 
' Übertragungsmodus
Public Enum eTransferType
  FTP_TRANSFER_TYPE_BINARY = &H2
  FTP_TRANSFER_TYPE_ASCII = &H1
End Enum
 
' Handles
Private hOpen As Long
Private hConnection As Long
 
 
Dim sRemoteHost As String
Dim sUsername As String
Dim sPassword As String
Dim sLocalFile As String
Dim sRemoteFile As String
Dim nTransferMode As eTransferType
Dim bResult As Boolean
 
' Verbindung zum Server herstellen
Public Function Connect(ByVal sRemoteHost As String, _
  Optional ByVal sUsername As String = "Username", _
  Optional ByVal sPassword As String = "Passwort") As Boolean
 
  ' Ist noch eine Verbindung vorhanden?
  ' Wenn ja, muss diese zunächst beendet werden!
  If hOpen <> 0 Or hConnection <> 0 Then
    Disconnect
  End If
 
  ' Neue Verbindung starten
  hOpen = InternetOpen("FTP", _
    INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, _
    vbNullString, 0)
 
  If hOpen Then
    hConnection = InternetConnect(hOpen, _
      sRemoteHost, INTERNET_INVALID_PORT_NUMBER, _
      sUsername, sPassword, INTERNET_SERVICE_FTP, 0, 0)
  End If
 
  Connect = (hConnection <> 0)
End Function
' Datei auf den Server hochladen
Public Function FileUpload( _
  ByVal sLocalFilename As String, _
  ByVal sRemoteFilename As String, _
  Optional ByVal nTransferType As eTransferType = _
  FTP_TRANSFER_TYPE_BINARY) As Boolean
 
  FileUpload = FtpPutFile(hConnection, _
    sLocalFilename, sRemoteFilename, nTransferType, 0)
End Function
' Verbindung zum Server beenden
Public Sub Disconnect()
  If hConnection <> 0 Then
    InternetCloseHandle hConnection
    hConnection = 0
  End If
 
  If hOpen <> 0 Then
    InternetCloseHandle hOpen
    hOpen = 0
  End If
End Sub
 
Private Sub ftp()
' Anmeldung am Server
sRemoteHost = Text2.Text
If Connect(sRemoteHost) Then
  ' Lokaler Dateiname
  sLocalFile = "c:\test\" & File1.List(0)
 
  ' Ziel-Datei auf dem Server
  ' Achtung! Verzeichnis muss bereits existsieren!!!
  sRemoteFile = "/test/" & Format(Now, "yyyymmdd hhnn") & ".jpg"
 
  ' Ascii-Übertragung
  nTransferMode = FTP_TRANSFER_TYPE_ASCII
 
  ' Upload durchführen
  bResult = FileUpload(sLocalFile, sRemoteFile, nTransferMode)
  If bResult Then
  ' Verbindung trennen
  Disconnect
  Else
 
  ' Wiederholen
  Call ftp
  End If
 
 
End If
Text1.Text = Now
' Datei auf Datenträger löschen
Kill "c:\test\" & File1.List(0)
 
' Wieder schauen ob eine neue Datei vorhanden ist
Call kucken
End Sub
 
 
Public Function Wait(ByVal mSek As Long)
   WaitForSingleObject -1, mSek
End Function
' Programm beenden
Private Sub Command2_Click()
  UnloadForms
  End
End Sub
' Alle geladenen Forms beenden
Private Sub UnloadForms()
  Dim F As Form
  For Each F In Forms
    Unload F
    Set F = Nothing
  Next F
End Sub
 
' Programm starten
Private Sub Command1_Click()
  Call kucken
End Sub
' Schauen ob eine Datei vorhanden ist
Private Sub kucken()
  Do While Dir("c:\test\*.jpg", vbNormal) = ""
  DoEvents
    ' 1 Sekunde Warten
    Wait 1000
  Loop
 
  File1.Path = "C:\test"
 
 
  ' Unterprogramm ftp aufrufen
  Call ftp
End Sub