' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const OpenAsDefault = -2
Private Const FailIfNotExist = 0
Private Const ForReading = 1
Private Const ForWriting = 2
Sub PutFTPFile(ByRef FilesToLoad() As String)
Dim strReturn As String
Dim lngIndex As Long, strMsg As String
'------------- Einstellungen START -----------------------
Const cstrFTPServer = "ftp.deinserver.com" 'ftp-Server
Const cstrUser = "username" 'Benutzername
Const cstrPassword = "passwort" 'Passwort
'------------- Einstellungen ENDE ---------------------------
For lngIndex = 0 To UBound(FilesToLoad)
strReturn = FTPUpload(cstrFTPServer, cstrUser, cstrPassword, _
Split(FilesToLoad(lngIndex), ";")(0), Split(FilesToLoad(lngIndex), ";")(1))
strMsg = strMsg & Format(lngIndex + 1, "00") & vbTab & FilesToLoad(lngIndex) & _
vbTab & strReturn & vbLf
Next
MsgBox strMsg
End Sub
Private Function FTPUpload(sSite, sUsername, sPassword, sLocalFile, _
sRemotePath) As String
Dim oFTPScriptFSO As Object, oFTPScriptShell As Object
Dim sFTPScript As String, sFTPTemp As String, sFTPTempFile As String
Dim sFTPResults As String, sResults As String
Dim fFTPScript As Variant, fFTPResults As Variant
Dim varPath As Variant, lngI As Long
'This script is provided under the Creative Commons license located
'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
'be used for commercial purposes with out the expressed written consent
'of NateRice.com
Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
Set oFTPScriptShell = CreateObject("WScript.Shell")
sRemotePath = Trim(sRemotePath)
sLocalFile = Trim(sLocalFile)
'----------Path Checks---------
'Here we willcheck the path, if it contains
'spaces then we need to add quotes to ensure
'it parses correctly.
'added by j.ehrensberger 2017/12/18
sRemotePath = Replace(sRemotePath, "/", "\")
If InStr(1, sRemotePath, "\") > 0 And Len(sRemotePath) > 1 Then
varPath = Split(sRemotePath, "\")
For lngI = 0 To UBound(varPath)
If InStr(varPath(lngI), " ") > 0 Then
If Left(varPath(lngI), 1) <> """" And Right(varPath(lngI), 1) <> """" Then
varPath(lngI) = """" & varPath(lngI) & """"
End If
End If
sRemotePath = "cd " & varPath(lngI) & vbCrLf
Next
Else 'end add
If InStr(sRemotePath, " ") > 0 Then
If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
sRemotePath = """" & sRemotePath & """"
End If
End If
'Check to ensure that a remote path was
'passed. If it's blank then pass a "\"
If Len(sRemotePath) = 0 Then
'Please note that no premptive checking of the
'remote path is done. If it does not exist for some
'reason. Unexpected results may occur.
sRemotePath = "\"
End If
sRemotePath = "cd " & sRemotePath & vbCrLf
End If
'Check the local path and file to ensure
'that either the a file that exists was
'passed or a wildcard was passed.
If InStr(sLocalFile, "*") Then
If InStr(sLocalFile, " ") Then
FTPUpload = "Error: Wildcard uploads do not work if the path contains a " _
& "space." & vbCrLf
FTPUpload = FTPUpload & _
"This is a limitation of the Microsoft FTP client."
Exit Function
End If
ElseIf Len(sLocalFile) = 0 Or Dir(sLocalFile) = "" Then
'nothing to upload
FTPUpload = "Error: File Not Found."
Exit Function
End If
If InStr(sLocalFile, " ") > 0 Then
If Left(sLocalFile, 1) <> """" And Right(sLocalFile, 1) <> """" Then
sLocalFile = """" & sLocalFile & """"
End If
End If
'--------END Path Checks---------
'build input file for ftp command
sFTPScript = sFTPScript & "USER " & sUsername & vbCrLf
sFTPScript = sFTPScript & sPassword & vbCrLf
sFTPScript = sFTPScript & sRemotePath
sFTPScript = sFTPScript & "binary" & vbCrLf
sFTPScript = sFTPScript & "prompt n" & vbCrLf
sFTPScript = sFTPScript & "put " & sLocalFile & vbCrLf
sFTPScript = sFTPScript & "quit" & vbCrLf & "quit" & vbCrLf & "quit" & vbCrLf
sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
'Write the input file for the ftp command
'to a temporary file.
Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
fFTPScript.WriteLine (sFTPScript)
fFTPScript.Close
Set fFTPScript = Nothing
oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & sSite & _
" > " & sFTPResults, 0, True
Sleep 1000
'Check results of transfer.
Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, _
FailIfNotExist, OpenAsDefault)
sResults = fFTPResults.ReadAll
fFTPResults.Close
oFTPScriptFSO.DeleteFile (sFTPTempFile)
oFTPScriptFSO.DeleteFile (sFTPResults)
If InStr(sResults, "226 Transfer complete") > 0 Then
FTPUpload = "Done"
ElseIf InStr(sResults, "File not found") > 0 Then
FTPUpload = "Error: File Not Found"
ElseIf InStr(sResults, "cannot log in") > 0 Then
FTPUpload = "Error: Login Failed."
Else
FTPUpload = "Error: Unknown."
End If
Set oFTPScriptFSO = Nothing
Set oFTPScriptShell = Nothing
End Function
Private Function FTPDownload(sSite, sUsername, sPassword, sLocalPath, _
sRemotePath, sRemoteFile) As String
Dim oFTPScriptFSO As Object, oFTPScriptShell As Object
Dim sFTPScript As String, sFTPTemp As String, sFTPTempFile As String
Dim sFTPResults As String, sResults As String
Dim sOriginalWorkingDirectory As String
Dim fFTPScript As Variant, fFTPResults As Variant
'This script is provided under the Creative Commons license located
'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
'be used for commercial purposes with out the expressed written consent
'of NateRice.com
Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
Set oFTPScriptShell = CreateObject("WScript.Shell")
sRemotePath = Trim(sRemotePath)
sLocalPath = Trim(sLocalPath)
'----------Path Checks---------
'Here we will check the remote path, if it contains
'spaces then we need to add quotes to ensure
'it parses correctly.
If InStr(sRemotePath, " ") > 0 Then
If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
sRemotePath = """" & sRemotePath & """"
End If
End If
'Check to ensure that a remote path was
'passed. If it's blank then pass a "\"
If Len(sRemotePath) = 0 Then
'Please note that no premptive checking of the
'remote path is done. If it does not exist for some
'reason. Unexpected results may occur.
sRemotePath = "\"
End If
'If the local path was blank. Pass the current
'working direcory.
If Len(sLocalPath) = 0 Then
sLocalPath = oFTPScriptShell.CurrentDirectory
End If
If Not oFTPScriptFSO.FolderExists(sLocalPath) Then
'destination not found
FTPDownload = "Error: Local Folder Not Found."
Exit Function
End If
sOriginalWorkingDirectory = oFTPScriptShell.CurrentDirectory
oFTPScriptShell.CurrentDirectory = sLocalPath
'--------END Path Checks---------
'build input file for ftp command
sFTPScript = sFTPScript & "USER " & sUsername & vbCrLf
sFTPScript = sFTPScript & sPassword & vbCrLf
sFTPScript = sFTPScript & "cd " & sRemotePath & vbCrLf
sFTPScript = sFTPScript & "binary" & vbCrLf
sFTPScript = sFTPScript & "prompt n" & vbCrLf
sFTPScript = sFTPScript & "mget " & sRemoteFile & vbCrLf
sFTPScript = sFTPScript & "quit" & vbCrLf & "quit" & vbCrLf & "quit" & vbCrLf
sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
'Write the input file for the ftp command
'to a temporary file.
Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
fFTPScript.WriteLine (sFTPScript)
fFTPScript.Close
Set fFTPScript = Nothing
oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & sSite & _
" > " & sFTPResults, 0, True
Sleep 1000
'Check results of transfer.
Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, _
FailIfNotExist, OpenAsDefault)
sResults = fFTPResults.ReadAll
fFTPResults.Close
'oFTPScriptFSO.DeleteFile(sFTPTempFile)
'oFTPScriptFSO.DeleteFile (sFTPResults)
If InStr(sResults, "226 Transfer complete.") > 0 Then
FTPDownload = "Done"
ElseIf InStr(sResults, "File not found") > 0 Then
FTPDownload = "Error: File Not Found"
ElseIf InStr(sResults, "cannot log in.") > 0 Then
FTPDownload = "Error: Login Failed."
Else
FTPDownload = "Error: Unknown."
End If
Set oFTPScriptFSO = Nothing
Set oFTPScriptShell = Nothing
End Function