On Sat, 10 Dec 2005 18:15:07 -0600, Lauren Wilson <no****@none.com> wrote:
Does anyone know if it is possible to capture FTP responses to various
FTP commands when managing an FTP session from a VBA procedure?
For example, if we try to login to an FTP server and the login info is
incorrect, FTP replies with a message to that effect. I need to
capture those kinds of responses and advise the user of an Access app
what is happening.
Thanks for all responses.
I have used this with good effect over the years.
Post the following code into a new CLASS module.
'
'''''''''''''''''''''''''''''''
' FTPClient '
'''''''''''''''''''''''''''''''
' Author Stuart McCall '
'
10*********@compuserve.com '
'
sm*****@smsb.demon.co.uk '
'
http://www.smsb.demon.co.uk '
'''''''''''''''''''''''''''''''
' July 1998 '
'''''''''''''''''''''''''''''''
'
'''''''''''''''''''''''''''''''
'Member Variables
'''''''''''''''''''''''''''''''
Private m_ProxyName As String
Private m_RemoteDir As String
Private m_RemoteFile As String
Private m_NewFileName As String
Private m_LocalFile As String
Private m_ServerName As String
Private m_UserName As String
Private m_Password As String
Private m_TransferType As Long
Private m_FileSpec As String
'
'''''''''''''''''''''''''''''''
'Collections
'''''''''''''''''''''''''''''''
Public FileNames As New Collection
'
'''''''''''''''''''''''''''''''
'Private Variables
'''''''''''''''''''''''''''''''
Private m_hFTP As Long 'Handle to the FTP session
Private m_hCon As Long 'Handle to the server connection
'
'''''''''''''''''''''''''''''''
'Private Constants
'''''''''''''''''''''''''''''''
Private Const mc_AGENTNAME = "FTP Class"
'
'''''''''''''''''''''''''''''''
'Error values (See the RaiseError routine)
'''''''''''''''''''''''''''''''
Private Const errOpenFTP As String = "1;Call to InternetOpen failed."
Private Const errOpenCon As String = "2;Call to InternetConnect failed."
Private Const errGetFile As String = "3;Call to FtpGetFile failed."
Private Const errPutFile As String = "4;Call to FtpPutFile failed."
Private Const errDelFile As String = "5;Call to FtpDeleteFile failed."
Private Const errRenFile As String = "6;Call to FtpRenameFile failed."
Private Const errGetDir As String = "7;Call to FtpGetCurrentDirectory failed."
Private Const errSetDir As String = "8;Call to FtpSetCurrentDirectory failed."
Private Const errCreateDir As String = "9;Call to FtpCreateDirectory failed."
Private Const errFindFirst As String = "10;Call to FtpFindFirstFile failed."
Private Const errFindNext As String = "11;Call to InternetFindNextFile failed."
Private Const errDelDir As String = "12;Call to FtpRemoveDirectory failed."
Private Const errNotOpen As String = "13;FTP session not open. Call OpenFTP first."
Private Const errNotConnected As String = "14;Not connected to a server. Call OpenServer first."
Private Const errNoServer As String = "15;No Server Name specified."
Private Const errNoLocalFile As String = "16;No Local File specified."
Private Const errNoRemoteFile As String = "17;No Remote File specified."
'
'''''''''''''''''''''''''''''''
'API Declarations
'''''''''''''''''''''''''''''''
Private Const MAX_PATH = &H104
'
Private Const INTERNET_INVALID_PORT_NUMBER = &H0
Private Const INTERNET_SERVICE_FTP = &H1
Private Const INTERNET_OPEN_TYPE_DIRECT = &H1
Private Const INTERNET_OPEN_TYPE_PROXY = &H3
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_PASSIVE = &H8000000
'
Private Const FTP_TRANSFER_TYPE_ASCII = &H0
Private Const FTP_TRANSFER_TYPE_BINARY = &H1
'
Private Const NO_ERROR = &H0
Private Const ERROR_NO_MORE_FILES = &H12
Private Const ERROR_INTERNET_EXTENDED_ERROR = &H2EE3
'
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
'
Private Declare Function FtpCreateDirectory Lib "wininet.dll" _
Alias "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpDeleteFile Lib "wininet.dll" _
Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName 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 FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) 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 Boolean
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" _
(ByVal hFtpSession As Long, ByVal lpszExistFile As String, ByVal lpszNewFile As String) As Boolean
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
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 InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" _
(ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" _
(lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Boolean
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
'''''''''''''''''''''''''''''''
'Properties
'''''''''''''''''''''''''''''''
Public Property Get ProxyName() As String
ProxyName = m_ProxyName
End Property
Public Property Let ProxyName(NewData As String)
m_ProxyName = NewData
End Property
Public Property Get RemoteDir() As String
RemoteDir = m_RemoteDir
End Property
Public Property Let RemoteDir(NewData As String)
m_RemoteDir = NewData
End Property
Public Property Get RemoteFile() As String
RemoteFile = m_RemoteFile
End Property
Public Property Let RemoteFile(NewData As String)
m_RemoteFile = NewData
End Property
Public Property Get LocalFile() As String
LocalFile = m_LocalFile
End Property
Public Property Let LocalFile(NewData As String)
m_LocalFile = NewData
End Property
Public Property Let NewFileName(NewData As String)
m_NewFileName = NewData
End Property
Public Property Get ServerName() As String
ServerName = m_ServerName
End Property
Public Property Let ServerName(NewData As String)
m_ServerName = NewData
End Property
Public Property Get UserName() As String
UserName = m_UserName
End Property
Public Property Let UserName(NewData As String)
m_UserName = NewData
End Property
Public Property Get Password() As String
Password = m_Password
End Property
Public Property Let Password(NewData As String)
m_Password = NewData
End Property
Public Property Get TransferType() As String
TransferType = IIf(m_TransferType = FTP_TRANSFER_TYPE_BINARY, "BINARY", "ASCII")
End Property
Public Property Let TransferType(NewData As String)
m_TransferType = IIf(UCase(Left(NewData, 3)) = "BIN", FTP_TRANSFER_TYPE_BINARY, FTP_TRANSFER_TYPE_ASCII)
End Property
Public Property Get FileSpec() As String
FileSpec = m_FileSpec
End Property
Public Property Let FileSpec(NewData As String)
m_FileSpec = NewData
End Property
'''''''''''''''''''''''''''''''
'Methods
'''''''''''''''''''''''''''''''
Public Sub OpenFTP(Optional pProxyName)
'Initiate FTP session
'Handle optional parameters
If Not IsMissing(pProxyName) Then m_ProxyName = pProxyName
'
If Len(m_ProxyName) Then
m_hFTP = InternetOpen(mc_AGENTNAME, INTERNET_OPEN_TYPE_PROXY, _
m_ProxyName, vbNullString, 0)
Else
m_hFTP = InternetOpen(mc_AGENTNAME, INTERNET_OPEN_TYPE_DIRECT, _
vbNullString, vbNullString, 0)
End If
If m_hFTP = 0 Then RaiseError errOpenFTP
End Sub
Public Sub CloseFTP()
'Terminate FTP session
If m_hCon Then Me.CloseServer
If m_hFTP Then InternetCloseHandle m_hFTP
m_hCon = 0
m_hFTP = 0
End Sub
Public Sub OpenServer(Optional pServerName, Optional pUserName, Optional pPassword)
'Establish connection to server
'If FTP session not initiated
If m_hFTP = 0 Then RaiseError errNotOpen
'
'Handle optional parameters
If Not IsMissing(pServerName) Then m_ServerName = pServerName
If Not IsMissing(pUserName) Then m_UserName = pUserName
If Not IsMissing(pPassword) Then m_Password = pPassword
'
'Handle empty properties
If Len(m_ServerName) = 0 Then RaiseError errNoServer
'
'The following are translated to:
' UserName: Anonymous
' Password: default email address
'by the API, if nulls passed
If Len(m_UserName) = 0 Then m_UserName = vbNullString
If Len(m_Password) = 0 Then m_Password = vbNullString
'
m_hCon = InternetConnect(m_hFTP, m_ServerName, INTERNET_INVALID_PORT_NUMBER, _
m_UserName, m_Password, INTERNET_SERVICE_FTP, _
INTERNET_FLAG_PASSIVE, 0)
'If m_hCon = 0 Then RaiseError errOpenCon
If m_hCon = 0 Then
booIsConnected = False
Exit Sub
Else
booIsConnected = True
End If
End Sub
Public Sub CloseServer()
'Terminate connection to server
If m_hCon Then InternetCloseHandle m_hCon
m_hCon = 0
End Sub
Public Sub GetFile(Optional pRemoteDir, Optional pRemoteFile, _
Optional pLocalFile, Optional pTransferType)
'Retrieve a file from server
'pTransferType accepts "ASCII" or "BINARY"
'Bail out if server connection not established
If m_hCon = 0 Then RaiseError errNotConnected
'
'Handle optional parameters
If Not IsMissing(pRemoteDir) Then m_RemoteDir = pRemoteDir
If Not IsMissing(pRemoteFile) Then m_RemoteFile = pRemoteFile
If Not IsMissing(pLocalFile) Then m_LocalFile = pLocalFile
If Not IsMissing(pTransferType) Then Me.TransferType = pTransferType
'
'Handle empty properties
If Len(m_RemoteDir) = 0 Then m_RemoteDir = "."
If Len(m_RemoteFile) = 0 Then RaiseError errNoRemoteFile
If Len(m_LocalFile) = 0 Then RaiseError errNoLocalFile
If Len(m_TransferType) = 0 Then Me.TransferType = "BINARY"
'
'Change directory on server
Me.SetDir m_RemoteDir
'
If FtpGetFile(m_hCon, m_RemoteFile, m_LocalFile, False, _
INTERNET_FLAG_RELOAD, m_TransferType, 0) = False Then
'RaiseError errGetFile
booDownloadSucceeded = False
Else
booDownloadSucceeded = True
End If
End Sub
Public Sub PutFile(Optional pRemoteDir, Optional pRemoteFile, _
Optional pLocalFile, Optional pTransferType)
'Transmit a file to server
'pTransferType accepts "ASCII" or "BINARY"
'Bail out if server connection not established
If m_hCon = 0 Then RaiseError errNotConnected
'
'Handle optional parameters
If Not IsMissing(pRemoteDir) Then m_RemoteDir = pRemoteDir
If Not IsMissing(pRemoteFile) Then m_RemoteFile = pRemoteFile
If Not IsMissing(pLocalFile) Then m_LocalFile = pLocalFile
If Not IsMissing(pTransferType) Then Me.TransferType = pTransferType
'
'Handle empty properties
If Len(m_RemoteDir) = 0 Then m_RemoteDir = "."
If Len(m_RemoteFile) = 0 Then RaiseError errNoRemoteFile
If Len(m_LocalFile) = 0 Then RaiseError errNoLocalFile
If Len(m_TransferType) = 0 Then Me.TransferType = "BINARY"
'
'Change directory on server
Me.SetDir m_RemoteDir
'
If FtpPutFile(m_hCon, m_LocalFile, m_RemoteFile, m_TransferType, 0) = False Then
'RaiseError errPutFile
booUploadSucceeded = False
Else
booUploadSucceeded = True
End If
End Sub
Public Sub DelFile(Optional pRemoteDir, Optional pRemoteFile)
'Delete a file on server
'Bail out if server connection not established
If m_hCon = 0 Then RaiseError errNotConnected
'
'Handle optional parameters
If Not IsMissing(pRemoteDir) Then m_RemoteDir = pRemoteDir
If Not IsMissing(pRemoteFile) Then m_RemoteFile = pRemoteFile
'
'Handle empty properties
If Len(m_RemoteDir) = 0 Then m_RemoteDir = "."
If Len(m_RemoteFile) = 0 Then RaiseError errNoRemoteFile
'
'Change directory on server
Me.SetDir m_RemoteDir
'
If FtpDeleteFile(m_hCon, m_RemoteFile) = False Then
'RaiseError errDelFile
booDownloadSucceeded = False
End If
End Sub
Public Sub RenFile(Optional pOldName, Optional pNewName)
'Rename a file on server
'Bail out if server connection not established
If m_hCon = 0 Then RaiseError errNotConnected
'
'Handle optional parameters
If Not IsMissing(pOldName) Then m_RemoteFile = pOldName
If Not IsMissing(pNewName) Then m_NewFileName = pNewName
'
'Handle empty properties
If Len(m_RemoteFile) = 0 Then RaiseError errNoRemoteFile
If Len(m_NewFileName) = 0 Then m_NewFileName = m_RemoteFile
'
'Change directory on server
Me.SetDir m_RemoteDir
'
If FtpRenameFile(m_hCon, m_RemoteFile, m_NewFileName) = False Then
RaiseError errRenFile
End If
End Sub
Public Function GetDir() As String
'Determine current directory on server
Dim Buffer As String
Dim BufLen As Long
'
'Bail out if server connection not established
If m_hCon = 0 Then RaiseError errNotConnected
'
BufLen = MAX_PATH
Buffer = String(BufLen, 0)
If FtpGetCurrentDirectory(m_hCon, Buffer, BufLen) = False Then
RaiseError errGetDir
End If
GetDir = Left(Buffer, BufLen)
End Function
Public Sub SetDir(Optional pRemoteDir)
'Change current directory on server
'Bail out if server connection not established
If m_hCon = 0 Then RaiseError errNotConnected
'
'Handle optional parameters
If Not IsMissing(pRemoteDir) Then m_RemoteDir = pRemoteDir
'
'Handle empty properties
If Len(m_RemoteDir) = 0 Then m_RemoteDir = "."
'
If FtpSetCurrentDirectory(m_hCon, m_RemoteDir) = False Then
RaiseError errSetDir
End If
End Sub
Public Sub CreateDir(Optional pRemoteDir)
'Create directory on server
'Bail out if server connection not established
If m_hCon = 0 Then RaiseError errNotConnected
'
'Handle optional parameters
If Not IsMissing(pRemoteDir) Then m_RemoteDir = pRemoteDir
'
'Handle empty properties
If Len(m_RemoteDir) = 0 Then m_RemoteDir = "."
'
If FtpCreateDirectory(m_hCon, m_RemoteDir) = False Then
RaiseError errCreateDir
End If
End Sub
Public Sub DelDir(Optional pRemoteDir)
'Delete directory on server
'Bail out if server connection not established
If m_hCon = 0 Then RaiseError errNotConnected
'
'Handle optional parameters
If Not IsMissing(pRemoteDir) Then m_RemoteDir = pRemoteDir
'
'Handle empty properties
If Len(m_RemoteDir) = 0 Then m_RemoteDir = "."
'
If FtpRemoveDirectory(m_hCon, m_RemoteDir) = False Then
RaiseError errDelDir
End If
End Sub
Public Sub GetFileNames(Optional pRemoteDir, Optional pFileSpec)
'Fill the FileNames collection with list
'of files matching pFileSpec from server's
'current directory
Dim hFind As Long
Dim LastErr As Long
Dim fData As WIN32_FIND_DATA
'
'Bail out if server connection not established
If m_hCon = 0 Then RaiseError errNotConnected
'
'Handle optional parameters
If Not IsMissing(pRemoteDir) Then m_RemoteDir = pRemoteDir
If Not IsMissing(pFileSpec) Then m_FileSpec = pFileSpec
'
'Handle empty properties
If Len(m_RemoteDir) = 0 Then m_RemoteDir = "."
If Len(m_FileSpec) = 0 Then m_FileSpec = "*.*"
'
'Change directory on server
Me.SetDir m_RemoteDir
'
'Find first file matching FileSpec
fData.cFileName = String(MAX_PATH, 0)
'Obtain search handle if successful
hFind = FtpFindFirstFile(m_hCon, m_FileSpec, fData, 0, 0)
LastErr = Err.LastDllError
If hFind = 0 Then
'Bail out if reported error isn't end-of-file-list
If LastErr <> ERROR_NO_MORE_FILES Then
RaiseError errFindFirst
End If
'Must be no more files
Exit Sub
End If
'
'Reset variable for next call
LastErr = NO_ERROR
'
'Add filename to the collection
FileNames.Add Left(fData.cFileName, _
InStr(1, fData.cFileName, vbNullChar, vbBinaryCompare) - 1)
Do
'Find next file matching FileSpec
fData.cFileName = String(MAX_PATH, 0)
If InternetFindNextFile(hFind, fData) = False Then
LastErr = Err.LastDllError
If LastErr = ERROR_NO_MORE_FILES Then
'Bail out if no more files
Exit Do
Else
'Must be a 'real' error
InternetCloseHandle hFind
RaiseError errFindNext
End If
Else
'Add filename to the collection
FileNames.Add Left(fData.cFileName, _
InStr(1, fData.cFileName, vbNullChar, vbBinaryCompare) - 1)
End If
Loop
'
'Release the search handle
InternetCloseHandle hFind
End Sub
Public Sub ClearFileNames()
'Clear contents of FileNames collection
Dim itm As Long
'
With FileNames
For itm = 1 To .Count
.Remove 1
Next
End With
End Sub
Private Sub Class_Initialize()
'Set property defaults
m_RemoteDir = "."
m_RemoteFile = vbNullString
m_LocalFile = vbNullString
m_NewFileName = vbNullString
m_UserName = vbNullString
m_Password = vbNullString
m_ProxyName = vbNullString
m_ServerName = vbNullString
m_TransferType = FTP_TRANSFER_TYPE_BINARY
End Sub
Private Sub Class_Terminate()
Me.ClearFileNames
End Sub
'''''''''''''''''''''''''''''''
'Utility Routines
'''''''''''''''''''''''''''''''
Private Sub RaiseError(ByVal ErrValue As String)
'Extracts the value to be added to the vbObjectError
'constant from the 1st section of ErrValue, and
'the error description from the 2nd section
'(Sections delimited with ';')
'Appends the last internet response string
Dim ptr As Integer
Dim InetErr As Long
'
'If we have a session handle, destroy the session
If m_hCon <> 0 Or m_hFTP <> 0 Then Me.CloseFTP
'
ptr = InStr(1, ErrValue, ";")
InetErr = Err.LastDllError
'Err.Raise vbObjectError + Val(Left$(ErrValue, ptr - 1)), _
"FTP Class", _
Mid$(ErrValue, ptr + 1) & ". (OS error code = " & InetErr & ")" & _
vbCrLf & "Internet Response: " & LastResponse(InetErr)
End Sub
Private Function LastResponse(ByVal ErrNum As Long) As String
'Obtains the last response string issued by server
Dim Buffer As String
Dim BufLen As Long
'
If ErrNum = ERROR_INTERNET_EXTENDED_ERROR Then
ErrNum = 0
InternetGetLastResponseInfo ErrNum, vbNullString, BufLen
Buffer = String(BufLen + 1, 0)
InternetGetLastResponseInfo ErrNum, Buffer, BufLen
LastResponse = Left(Buffer, BufLen)
End If
End Function
Wayne Gillespie
Gosford NSW Australia
