使用cuteftp实现SFTP上传

好多年前写的一个小玩意,通过cuteftppro上传更新后的文件,

Function cuteftp_Upload(Dir,Filename,ToDir)
Dim MySite
Dim strFileList
Dim strFileName
Dim i, j
Dim objFSO, objFolder, objFile

Set MySite = CreateObject("CuteFTPPro.TEConnection")

MySite.Option("ThrowError") = false

MySite.Host = "FTP服务器IP"
MySite.Protocol = "SFTP" '链接模式
MySite.Port = ftp端口
MySite.Retries = 30
MySite.Delay = 30
MySite.MaxConnections = 1
MySite.TransferType = "AUTO"
MySite.DataChannel = "DEFAULT"
MySite.AutoRename = "OFF"
MySite.FileOverWriteMethod = "OVERWRITE"

MySite.Login = "账号名"
MySite.Password = "密码"
MySite.SocksInfo = ""
MySite.ProxyInfo = ""

If CBool(MySite.Connect) Then
MySite.RemoteFilterInclude = ""
MySite.RemoteFilterExclude = ""
MySite.RemoteSiteFilter = ""

MySite.RemoteFolder = ToDir
MySite.LocalFolder = Dir
If CBool(MySite.RemoteExists(MySite.RemoteFolder)) Then
If CBool(MySite.LocalExists(MySite.LocalFolder)) Then
MySite.Upload Filename
cuteftp_Upload = "OK"
Set objFolder = nothing
Set objFSO = nothing
Else
cuteftp_Upload = "错误! 本地上载目录不存在"
MsgBox "错误! 本地上载目录不存在"
End If
Else
cuteftp_Upload = "错误! 远程上载目录不存在"
MsgBox "错误! 远程上载目录不存在"
End If
Else
cuteftp_Upload = "错误! " & MySite.ErrorDescription
MsgBox "错误! " & MySite.ErrorDescription
End If
MySite.Disconnect
End Function

主程序:

'运行程序初始配置
cuteftpfile = "cuteftp.vbs"
configfile = "配置文件.confing"
IfinD_src = "xxx.exe"
EMFunc_src = "yyy.xla"
log_file = "update.log"
'On Error Resume Next '忽略所有错误
'关闭EXCEL进程

Set fs_log = CreateObject("Scripting.FileSystemObject")
If fs_log.fileExists(log_file) = False Then
Set flog = fs_log.CreateTextFile(log_file, False)
Else
Set flog = fs_log.opentextfile(log_file, 8)
End If
Set fso1 = CreateObject("Scripting.FileSystemObject")
If fso1.fileExists(cuteftpfile) = False Then
msgbox "cuteftpfile文件不存在,请重新配置"
wscript.quit
End If
If fso1.fileExists(configfile) = False Then
msgbox "configfile文件不存在,请重新配置"
wscript.quit
End If
If fso1.fileExists(IfinD_src) = False Then
msgbox "xxx路径配置错误,请重新配置"
wscript.quit
End If
If fso1.fileExists(EMFunc_src) = False Then
msgbox "yyy.xla路径配置错误,请重新配置"
wscript.quit
End If

opentext = fso1.opentextfile("cuteftp.vbs", 1).readall
ExecuteGlobal opentext
Set fso1 = Nothing

msgbox "请确定excel都已关闭!,点击确定后将强制关闭所有EXCEL进程!"
strComputer ="."
Set objWMIService = GetObject("winmgmts://" & strComputer & "/root/cimv2")
Set colProcess = objWMIService.ExecQuery("Select * from Win32_PerfFormattedData_PerfProc_Process",,48)
For Each objItem in colProcess
If objItem.Name = "EXCEL" then
'msgbox "准备关闭"
CreateObject("WScript.Shell").Run "taskkill /f /im EXCEL.EXE", 0
end If
Next
Wscript.Sleep 3000

Dim WshShell
set WshShell = CreateObject("WScript.Shell")
Dim oExcel
Set oExcel= CreateObject("Excel.Application")
oExcel.DisplayAlerts = FALSE
oExcel.visible = TRUE
sPath = createobject("Scripting.FileSystemObject").GetFolder(".").Path
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.OpenTextFile(configfile,1, False)

DO While file.AtEndOfStream <> True
conf_line = cstr(file.ReadLine)
'msgbox str
If len(conf_line) > 3 Then
arr = Split(conf_line,",")
If arr(0) = "txt_file_up" Then
cuteftp_Upload sPath,arr(1),arr(2)
flog.WriteLine cstr(date) & " " & cstr(time) & "|" & cstr(arr(1)) & ",成功上传至" & arr(2)
Wscript.Sleep 30000
Else
file_path = arr(0)& "/" &arr(1)
rowcount_before = 0
rowcount_after = 0
If Right(file_path,4) = "xlsx" Then
'IfinD_check(IfinD_src)
oExcel.Workbooks.Open file_path,3,false
rowcount_before = oExcel.ActiveSheet.UsedRange.Rows.Count
'msgbox rowcount_before
Wscript.Sleep 3000
WshShell.run(EMFunc_src),1,false
Wscript.Sleep 10000
oExcel.ActiveWorkBook.Save
Wscript.Sleep 3000
rowcount_after = oExcel.ActiveSheet.UsedRange.Rows.Count
'msgbox rowcount_after
oExcel.WorkBooks.Close
Wscript.Sleep 3000
'msgbox rowcount_after-rowcount_before
addcount = rowcount_after - rowcount_before
'If addcount > 0 then
cuteftp_Upload arr(0),arr(1),arr(2)
flog.WriteLine cstr(date) & " " & cstr(time) & "|" & file_path & ",成功上传至" & arr(2) &",新增" & cstr(addcount) & "行数据," & "总行数为" & cstr(rowcount_before)
'Else
' flog.WriteLine cstr(date) & " " & cstr(time) & "|" & file_path & ",未更新,总行数为" & cstr(rowcount_before) & ",无新数据更新."
'End If
End If
End IF
End If
loop
flog.WriteLine cstr(date) & " " & cstr(time) & "|" & "完成" & configfile & "配置文件中对应Excel更新."
set flog = Nothing
Set fso = Nothing
oExcel.Quit
Wscript.Sleep 1000
msgbox "完成" & configfile & "配置文件中对应Excel更新."

Function IfinD_check(IfinD_src)
strComputer ="."
Set objWMIService = GetObject("winmgmts://" & strComputer & "/root/cimv2")
Set colProcess = objWMIService.ExecQuery("Select * from Win32_PerfFormattedData_PerfProc_Process",,48)

DIM isIfinD
isIfinD = 0
For Each objItem in colProcess
If objItem.Name = "xxx" then
isIfinD = 1
end If
Next

If isIfinD <>1 then
WshShell.run(xxx),1,false
Wscript.Sleep 5000
WshShell.SendKeys "{ENTER}"
Wscript.Sleep 5000
End If
End Function