VBA 通過ftp 上傳文件

qingkuangs

Code
Option 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 hProc  0 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