title image


Smiley Re: Dateiübertragung via FTP über VBA
Hi Martin!Wenn du ein OCX-Control wie z.B. das MSINET.ocx von M$ nutzt ist es leichter. Möchtest du dieses nicht nutzen kannst du auch die Wininet.dll aufrufen...Füge das in ein neues Modul ein: (für Microsoft Access)Option Compare DatabaseOption ExplicitPrivate 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 BooleanPrivate Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As BooleanPrivate Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As LongPrivate 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 lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As LongPrivate Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As BooleanPrivate Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As IntegerPrivate Const ERR_CONNECT_ERROR As String = "Cannot Connect to the specified Server using User and Password Parameters"Private Const ERR_NO_FTP_CONNECTION As String = "Not Connected to FTP Site"Private Const ERR_FTP_UPLOAD As String = "Couldn't send File to Server"Private Const ERR_FATAL_ERROR As String = "Cannot get Connection to WinInet.dll !"Private Const SESSION As String = "FTP Module"Private INET_HANDLE As LongPrivate FTP_CONNECTION As LongPrivate FTP_SERVER As StringPrivate FTP_USER As StringPrivate FTP_PASSWORD As StringPrivate FTP_Directory As StringPublic Sub Disconnect()If FTP_CONNECTION 0 Then InternetCloseHandle FTP_CONNECTION FTP_CONNECTION = 0Else 'No FTP Connection! Beep MsgBox "Error: " & ERR_NO_FTP_CONNECTION, vbCritical, "Error" Exit SubEnd IfFTP_SERVER = ""FTP_USER = ""FTP_PASSWORD = ""FTP_Directory = ""If INET_HANDLE 0 Then InternetCloseHandle INET_HANDLEEnd IfFTP_CONNECTION = 0INET_HANDLE = 0End SubPublic Function Connect(strHost As String, strUser As String, strPassword As String) As BooleanOn Error GoTo ErrorHandlerDim strError As StringINET_HANDLE = InternetOpen(SESSION, 1, vbNullString, vbNullString, 0)If INET_HANDLE = 0 Then FTP_CONNECTION = 0 Beep MsgBox "Error: " & ERR_FATAL_ERROR, vbCritical, "Error" Exit FunctionEnd IfIf FTP_CONNECTION 0 Then Beep MsgBox "Error: You are already connected to FTP Server " & FTP_SERVER, vbCritical, "Error" Exit FunctionEnd IfFTP_SERVER = strHostFTP_USER = strUserFTP_PASSWORD = strPassword'Connect Now!If Len(FTP_SERVER) = 0 Then Beep MsgBox "Error: No Host Address Specified!", vbCritical, "Error" Exit FunctionEnd IfFTP_CONNECTION = InternetConnect(INET_HANDLE, FTP_SERVER, 0, FTP_USER, FTP_PASSWORD, 1, 0, 0)'Check for connection errorsIf FTP_CONNECTION = 0 Then strError = ERR_CONNECT_ERROR strError = strError & vbCrLf & GetErrorMessage(Err.LastDllError) Beep MsgBox "Error: " & strError, vbCritical, "Error" Exit FunctionEnd IfConnect = TrueExit FunctionErrorHandler: Beep MsgBox "Error: " & Err.Description, vbCritical, "Error" Exit FunctionEnd FunctionPublic Function PutFile(ByVal strLocalFileAndPath As String, ByVal strRemoteFileAndPath As String) As BooleanOn Error GoTo ErrorHandlerDim bRet As BooleanDim strRemoteFile As StringDim strRemoteDirectory As StringDim strLocalFile As StringDim strTemp As StringDim lngPos As LongDim strError As StringIf FTP_CONNECTION = 0 Then Beep MsgBox "Error: " & ERR_NO_FTP_CONNECTION, vbCritical, "Error" Exit FunctionEnd IfbRet = FtpPutFile(FTP_CONNECTION, strLocalFileAndPath, strRemoteFileAndPath, &H1, 0)If bRet = False Then strError = ERR_FTP_UPLOAD strError = strError & vbCrLf & GetErrorMessage(Err.LastDllError) PutFile = False Beep MsgBox "Error: " & strError, vbCritical, "Error" Exit FunctionEnd If PutFile = TrueExit FunctionErrorHandler: Beep MsgBox "Error: " & Err.Description, vbCritical, "Error" Exit FunctionEnd FunctionPrivate Function GetErrorMessage(ByVal lngErrorNummer As Long) As String 'For internal use only!Dim lngError As LongDim lngLen As LongDim strBuffer As StringIf lngErrorNummer = 12003 Then 'Get Message Size and Number InternetGetLastResponseInfo lngError, vbNullString, lngLen strBuffer = String$(lngLen + 1, vbNullChar) 'Get Message InternetGetLastResponseInfo lngError, strBuffer, lngLen GetErrorMessage = vbCrLf & strBufferEnd IfEnd FunctionMfG Fabian

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: