使用ftpputfile函数上传文件到internet ftp服务器

[白发程序猿]

我使用ftpputfile函数去上传文件到internet ftp服务器，发现总是返回false
能设置当前目录，就是传不上文件，文件才几十KB，
我能在IE上访问这个ftp服务器，并能拷贝本地文件到服务器上，
而同样的程序我能上传文件到局域网的ftp服务器
有没有高手帮我分析一下原因

Private Sub TransferToFTP()
    Dim fso As New FileSystemObject
    Dim strFolder As String
    Dim strFile As String
    Dim lngINet As Long
    Dim lngINetConn As Long
    Dim blnRC As Boolean
    
    Dim strFTPAddr As String
    Dim strFTPFolder As String
    Dim strFTPUserName As String
    Dim strFTPPassWord As String
    Dim strLocalFolder As String
    
    On Error GoTo ErrMsg
    
    strFTPAddr = GetIniStr("FTP", "addr")
    strFTPFolder = GetIniStr("FTP", "folder")
    strFTPUserName = GetIniStr("FTP", "username")
    strFTPUserName = Decrypt(strFTPUserName, G_CryptPwd)
    strFTPPassWord = GetIniStr("FTP", "password")
    strFTPPassWord = Decrypt(strFTPPassWord, G_CryptPwd)
    strLocalFolder = GetIniStr("FTP", "local")
    strFolder = App.Path & "\data\" & Format(Date, "yyyymmdd") & "\" & strLocalFolder
    'strFolder = App.Path & "\data\20081209\zip\"
    lngINet = InternetOpen("FTP Control", 1, vbNullString, vbNullString, 0)
    If lngINet = 0 Then
        MsgBox "Occur error when transfer file to FTP,Reason:Can not Open Internet Session!"
        Exit Sub
    End If
    lngINetConn = InternetConnect(lngINet, strFTPAddr, 0, strFTPUserName, strFTPPassWord, 1, 0, 0)
    If lngINetConn = 0 Then
        MsgBox "Occur error when transfer file to FTP,Reason:Can not Connect FTP Server!"
        Exit Sub
    End If
    blnRC = FtpSetCurrentDirectory(lngINetConn, strFTPFolder)
    If blnRC = False Then
        MsgBox "Occur error when transfer file to FTP,Reason:Can not Change directory of FTP Server!"
        Exit Sub
    End If
    If fso.FolderExists(strFolder) Then
        strFile = Dir(strFolder, vbDirectory)
        While Len(strFile) > 0
            If strFile <> "." And strFile <> ".." Then
                blnRC = FtpPutFile(lngINetConn, strFolder & strFile, strFile, &H2, 0)
                If blnRC = False Then
                    MsgBox "Occur error when transfer file to FTP,Reason:Not Transfer file(" & strFile & ") to FTP Server!"
                    Exit Sub
                End If
            End If
            strFile = Dir
        Wend
    End If
    InternetCloseHandle lngINetConn
    InternetCloseHandle lngINet
    Exit Sub
ErrMsg:
    MsgBox "Occur error when transfer file to FTP, Reason:" & Err.Description
End Sub

[白发程序猿]

Win32 API 函数的声明代码

Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer

[lyserver]

strFile = Dir(strFolder, vbDirectory)这一句有问题，你上传的可不是文件名称。

[白发程序猿]

谁说的，都Debug过了

[ScottYj]

太难了,加人气

[白发程序猿]

针对lyserver说的，我又测试一下，而且我加了GetLastError，我得到的那msgbox的信息如下：
Occur error when transfer file to FTP,Reason:(0) Not Transfer file(20090612S01bom.txt) to FTP Server!

[白发程序猿]

这样就可以判定strfile是文件名了吧

[白发程序猿]

但GetLastError怎么会得到0呢？

[lyserver]

我写了一个功能比较完整的类，你自己看吧（贴出源码，又得有人说俺贱了）：

Option Explicit

'* ******************************************************* *
'*    模块名称：FTP.cls
'*    模块功能：使用wininet API进行FTP操作
'*    作者：lyserver
'*    联系方式：http://blog.csdn.net/lyserver
'* ******************************************************* *
Private Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime(1) As Long
        ftLastAccessTime(1) As Long
        ftLastWriteTime(1) As Long
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * 260
        cAlternate As String * 14
End Type
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String) As Boolean
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Boolean
Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Long
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" (ByVal hFtpSession As Long, ByVal lpszExisting As String, ByVal lpszNew As String) As Boolean
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (lpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Const INTERNET_FLAG_ASYNC = &H10000000
Private Const INTERNET_FLAG_EXISTING_CONNECT = &H20000000
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_SERVICE_FTP = 1
Private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_CONNECTION_MODEM = &H1
Private Const INTERNET_CONNECTION_LAN = &H2
Private Const INTERNET_CONNECTION_PROXY = &H4
Private Const FTP_TRANSFER_TYPE_ASCII = 1
Private Const FTP_TRANSFER_TYPE_BINARY = 2
Private Const ERROR_NO_MORE_FILES = 18&
Private Const ERROR_INTERNET_EXTENDED_ERROR = 12003
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20

Public Event EnumFileProc(ByVal FileName As String, FileAttr As VbFileAttribute)

Dim m_hInternet As Long, m_hConnect As Long

Private Sub Class_Initialize()
    m_hInternet = InternetOpen("FTP Appliction", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, INTERNET_FLAG_NO_CACHE_WRITE)
End Sub

Private Sub Class_Terminate()
    If m_hConnect <> 0 Then InternetCloseHandle m_hConnect
    InternetCloseHandle m_hInternet
End Sub

Public Function Login(Server As String, Optional Port As Integer = 21, Optional UserName As String = "anonymous", Optional Password = "") As Boolean
    If m_hInternet = 0 Then Exit Function
    If m_hConnect <> 0 Then Logout
    m_hConnect = InternetConnect(m_hInternet, Server, Port, UserName, Password, INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE Or INTERNET_FLAG_EXISTING_CONNECT, 0)
    Login = (m_hConnect <> 0)
End Function

Public Function Logout() As Boolean
    If m_hConnect <> 0 Then
        InternetCloseHandle m_hConnect
        m_hConnect = 0
        Logout = True
    End If
End Function

Public Function GetDirectory() As String
    Dim strPath As String, nLen As Long
    
    If m_hConnect = 0 Then Exit Function
    nLen = 260
    strPath = String(nLen, vbNullChar)
    FtpGetCurrentDirectory m_hConnect, strPath, nLen
    GetDirectory = Left(strPath, InStr(strPath, vbNullChar) - 1)
End Function

Public Function SetDirectory(ByVal FtpPath As String) As Boolean
    If m_hConnect = 0 Then Exit Function
    FtpSetCurrentDirectory m_hConnect, FtpPath
    SetDirectory = (GetLastError <> ERROR_INTERNET_EXTENDED_ERROR)
End Function

Public Function CreateDirectory(ByVal FtpPath As String) As Boolean
    FtpCreateDirectory m_hConnect, FtpPath
    CreateDirectory = (GetLastError <> ERROR_INTERNET_EXTENDED_ERROR)
End Function

Public Function DeleteDirectory(ByVal FtpPath As String) As Boolean
    FtpRemoveDirectory m_hConnect, FtpPath
    DeleteDirectory = (GetLastError <> ERROR_INTERNET_EXTENDED_ERROR)
End Function

Public Function EnumFile() As String()
    Static s() As String
    Dim strFile As String
    Dim wfd As WIN32_FIND_DATA
    Dim hFind As Long, i As Long
    
    Erase s
    hFind = FtpFindFirstFile(m_hConnect, ".", wfd, INTERNET_FLAG_RELOAD, 0)
    Do While GetLastError() <> ERROR_NO_MORE_FILES
        ReDim Preserve s(i)
        s(i) = Left(wfd.cFileName, InStr(wfd.cFileName, Chr(0)) - 1)
        If (wfd.dwFileAttributes Or FILE_ATTRIBUTE_DIRECTORY) = wfd.dwFileAttributes Then
            RaiseEvent EnumFileProc(s(i), vbDirectory)
        Else
            RaiseEvent EnumFileProc(s(i), vbArchive)
        End If
        If InternetFindNextFile(hFind, wfd) = 0 Then Exit Do
        i = i + 1
    Loop
    EnumFile = s
End Function

Public Function Rename(ByVal FtpOldName As String, ByVal FtpNewName As String) As Boolean
    FtpRenameFile m_hConnect, FtpOldName, FtpNewName
    Rename = (GetLastError <> ERROR_INTERNET_EXTENDED_ERROR)
End Function

Public Function DeleteFile(ByVal FtpFile As String) As Boolean
    FtpDeleteFile m_hConnect, FtpFile
    DeleteFile = (GetLastError <> ERROR_INTERNET_EXTENDED_ERROR)
End Function

Public Function UpFile(ByVal LocalFile As String, Optional ByVal FtpFile As String) As Boolean
    If m_hConnect = 0 Then Exit Function
    If Len(Dir(LocalFile)) = 0 Or Left(Dir(LocalFile), 1) = "." Then Exit Function
    If Len(FtpFile) = 0 Then
        If InStr(LocalFile, "\") = 0 Then
            FtpFile = LocalFile
        Else
            FtpFile = StrReverse(LocalFile)
            FtpFile = StrReverse(Left(FtpFile, InStr(FtpFile, "\") - 1))
        End If
    End If
    FtpPutFile m_hConnect, LocalFile, FtpFile, 1, 0
    UpFile = (GetLastError <> ERROR_INTERNET_EXTENDED_ERROR)
End Function

Public Function DownFile(ByVal FtpFile As String, Optional ByVal LocalFile As String) As Boolean
    If m_hConnect = 0 Then Exit Function
    If Len(LocalFile) = 0 Then
        If InStr(FtpFile, "\") = 0 Then
            LocalFile = FtpFile
        Else
            LocalFile = StrReverse(FtpFile)
            LocalFile = StrReverse(Left(LocalFile, InStr(LocalFile, "\") - 1))
        End If
    End If
    FtpGetFile m_hConnect, FtpFile, LocalFile, False, FILE_ATTRIBUTE_ARCHIVE, FTP_TRANSFER_TYPE_BINARY, 0
    DownFile = (GetLastError <> ERROR_INTERNET_EXTENDED_ERROR)
End Function