自动上传FTP脚本

自动上传FTP脚本
2011年05月11日
　　自动上传本地文件到FTP
　　Do
　　Dim a
　　a="C:\Documents and Settings\hexin\upload"
　　Dim fso, f, f1, fc, s
　　Set WshShell=CreateObject("Wscript.Shell")
　　strComputer="10.10.77.66" '需要上传的电脑IP
　　strUserName="name" '用户名
　　strPassword="name" '密码
　　Set fso = CreateObject("Scripting.FileSystemObject")
　　Set f = fso.GetFolder(a)
　　Set fc = f.Files
　　For Each f1 in fc
　　'如果上传成功，则删除本地目录中的文件
　　a= FTPUpload(strComputer,strUserName,strPassword,f1.Path,"\")
　　If(a=true)then
　　fso.DeleteFile(f1)
　　End If
　　Next
　　Wscript.Sleep 1000*5 '每五秒中执行一次
　　loop
　　ON ERROR RESUME NEXT
　　Function FTPUpload(sSite, sUsername, sPassword, sLocalFile, sRemotePath)
　　'上传
　　Const OpenAsDefault = -2
　　Const FailIfNotExist = 0
　　Const ForReading = 1
　　Const ForWriting = 2
　　Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
　　Set oFTPScriptShell = CreateObject("WScript.Shell")
　　sRemotePath = Trim(sRemotePath)
　　sLocalFile = Trim(sLocalFile)
　　If InStr(sRemotePath, " ") > 0 Then
　　If Left(sRemotePath, 1) """" And Right(sRemotePath, 1) """" Then
　　sRemotePath = """" & sRemotePath & """"
　　End If
　　End If
　　' If InStr(sLocalFile, " ") > 0 Then
　　' If Left(sLocalFile, 1) """" And Right(sLocalFile, 1) """" Then
　　' sLocalFile = """"& sLocalFile & """"
　　' End If
　　' End If
　　If Len(sRemotePath) = 0 Then
　　sRemotePath = "\"
　　End If
　　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 Not oFTPScriptFSO.FileExists(sLocalFile) Then
　　FTPUpload = "Error: File Not Found."
　　Exit Function
　　End If
　　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 & "put " &Chr(34)& sLocalFile &Chr(34)& vbCRLF'上传的时候添加双引号来处理路径中的非法字符
　　sFTPScript = sFTPScript & "quit" & vbCRLF & "quit" & vbCRLF & "quit" & vbCRLF
　　sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
　　sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
　　sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
　　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
　　Wscript.Sleep 1000
　　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 = True
　　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
　　Function FTPDownload(sSite, sUsername, sPassword, sLocalPath, sRemotePath, sRemoteFile)
　　Const OpenAsDefault = -2
　　Const FailIfNotExist = 0
　　Const ForReading = 1
　　Const ForWriting = 2
　　Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
　　Set oFTPScriptShell = CreateObject("WScript.Shell")
　　sRemotePath = Trim(sRemotePath)
　　sLocalPath = Trim(sLocalPath)
　　If InStr(sRemotePath, " ") > 0 Then
　　If Left(sRemotePath, 1) """" And Right(sRemotePath, 1) """" Then
　　sRemotePath = """" & sRemotePath & """"
　　End If
　　End If
　　If Len(sRemotePath) = 0 Then
　　sRemotePath = "\"
　　End If
　　If Len(sLocalPath) = 0 Then
　　sLocalpath = oFTPScriptShell.CurrentDirectory
　　End If
　　If Not oFTPScriptFSO.FolderExists(sLocalPath) Then
　　FTPDownload = "Error: Local Folder Not Found."
　　Exit Function
　　End If
　　sOriginalWorkingDirectory = oFTPScriptShell.CurrentDirectory
　　oFTPScriptShell.CurrentDirectory = sLocalPath
　　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
　　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
　　Wscript.Sleep 1000
　　Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, _
　　FailIfNotExist, OpenAsDefault)
　　sResults = fFTPResults.ReadAll
　　fFTPResults.Close
　　If InStr(sResults, "226 Transfer complete.") > 0 Then
　　FTPDownload = True
　　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
　　由于是我自己编写的，可能存在BUG，但是我没有找出来，哪位兄弟看出来了或者找出来了 吼吼啊