VBA 通過ftp 上傳文件
CodeOption Explicit
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Const SYNCHRONIZE = &H100000
Private Const INFINITE = -1&
Public Function FTP(ByVal IP As String, ByVal ID As String, ByVal PW As String, _
ByVal filePath As String, ByVal fileName As String, ByVal saveAsName As String) As String
On Error GoTo errMsg
On Error Resume Next
Kill "c:\tempEPOfile"
On Error GoTo errMsg
FileCopy fileName, "c:\tempEPOfile"
On Error Resume Next
Kill ActiveWorkbook.Path & "\FTPtempFile"
On Error GoTo errMsg
Open "FTPtempFile" For Append As #1
Print #1, "open " & IP
Print #1, ID
Print #1, PW
Print #1, "cd " & filePath
Print #1, "put c:\tempEPOfile " & saveAsName
Print #1, "quit"
Close #1
Dim lProcID As Long
Dim hProc As Long
' Start the App
lProcID = Shell("ftp -s:FTPtempFile", vbHide)
DoEvents
' Wait for the App
hProc = OpenProcess(SYNCHRONIZE, 0, lProcID)
If hProc0 Then
WaitForSingleObject hProc, INFINITE
CloseHandle hProc
End If
Shell "ftp -s:FTPtempFile"
On Error Resume Next
Kill "c:\tempEPOfile"
Kill ActiveWorkbook.Path & "\FTPtempFile"
On Error GoTo errMsg
Dim objEightBall As clsws_Service
Set objEightBall = New clsws_Service
objEightBall.wsm_insertLog "Leadtime", saveAsName, "1", Environ("username")
FTP = "File upload complete." & vbCrLf & "The transfer operation will be completed in 3 minues." & vbCrLf & _
"If you didn't got mail after 5 minutes please content us."
Exit Function
errMsg:
FTP = Err.Description
End Function
页:
[1]