By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
432,548 Members | 1,735 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 432,548 IT Pros & Developers. It's quick & easy.

Capturing FTP responses in VBA?

P: n/a
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.
Dec 11 '05 #1
Share this Question
Share on Google+
17 Replies


P: n/a
I imagine someone has an FTP client that works as a COM object to do what you
are suggesting.

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.


Dec 11 '05 #2

P: n/a
On Sat, 10 Dec 2005 17:15:35 -0800, Steve Jorgensen
<no****@nospam.nospam> wrote:
I imagine someone has an FTP client that works as a COM object to do what you
are suggesting.
That would be cool. Does anyone know where I can find such an object?


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.

Dec 11 '05 #3

P: n/a
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
Dec 11 '05 #4

P: n/a

WOW! Wayne, you are a prince! Thanks very much. You just helped me
make a crash and burn deadline.

Your place in heaven is now secure. :-)

On Sun, 11 Dec 2005 06:44:08 GMT, Wayne Gillespie
<be*****@NOhotmailSPAM.com.au> wrote:
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

Dec 11 '05 #5

P: n/a

Hi Wayne,

This code won't compile. It croaks on: booUploadSucceeded = False
with "variable not defined". There are other examples of the same
thing in other procs. Any clues?

Thanks,
-- LW

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


On Sun, 11 Dec 2005 06:44:08 GMT, Wayne Gillespie
<be*****@NOhotmailSPAM.com.au> wrote:
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

Dec 11 '05 #6

P: n/a
Wayne Gillespie <be*****@NOhotmailSPAM.com.au> wrote in
news:lh********************************@4ax.com:
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 '
'''''''''''''''''''''''''''''''


You haven't used it in the exact form in which you posted it, as it
won't compile with OPTION EXPLICIT, since it's lacking a declaration
for booIsConnected. It's not clear to me what purpose the variable
serves, except to replace the Raise Error (apparently for
compatibility in VBA, though I believe Raise Error is supported from
A2K on, no?). And it's not clear where it should be used, either as
a public class member, a public property, or as a return value for
the subroutine in which the variable is used (either converting it
to a function or passing a ByRef parameter).

--
David W. Fenton http://www.bway.net/~dfenton
dfenton at bway dot net http://www.bway.net/~dfassoc
Dec 11 '05 #7

P: n/a
On Sun, 11 Dec 2005 14:43:50 -0600, Lauren Wilson <no****@none.com> wrote:
Hi Wayne,

This code won't compile. It croaks on: booUploadSucceeded = False
with "variable not defined". There are other examples of the same
thing in other procs. Any clues?

Thanks,
-- LW


These are public variables I have probably added to pass the result of an action to other parts of the app.
Either rem out the offending lines if you don't need this functionality, or declare the variables in a separate standard
module.
Wayne Gillespie
Gosford NSW Australia
Dec 11 '05 #8

P: n/a
On Sun, 11 Dec 2005 21:18:30 GMT, Wayne Gillespie
<be*****@NOhotmailSPAM.com.au> wrote:
On Sun, 11 Dec 2005 14:43:50 -0600, Lauren Wilson <no****@none.com> wrote:
Hi Wayne,

This code won't compile. It croaks on: booUploadSucceeded = False
with "variable not defined". There are other examples of the same
thing in other procs. Any clues?

Thanks,
-- LW
These are public variables I have probably added to pass the result of an action to other parts of the app.
Either rem out the offending lines if you don't need this functionality, or declare the variables in a separate standard
module.


Thanks Wayne. I wasn't sure to make them public global or private.

Wayne Gillespie
Gosford NSW Australia

Dec 11 '05 #9

P: n/a
On Sun, 11 Dec 2005 14:59:33 -0600, "David W. Fenton"
<dX********@bway.net.invalid> wrote:
Wayne Gillespie <be*****@NOhotmailSPAM.com.au> wrote in
news:lh********************************@4ax.com :
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 '
'''''''''''''''''''''''''''''''


You haven't used it in the exact form in which you posted it, as it
won't compile with OPTION EXPLICIT, since it's lacking a declaration
for booIsConnected. It's not clear to me what purpose the variable
serves, except to replace the Raise Error (apparently for
compatibility in VBA, though I believe Raise Error is supported from
A2K on, no?). And it's not clear where it should be used, either as
a public class member, a public property, or as a return value for
the subroutine in which the variable is used (either converting it
to a function or passing a ByRef parameter).


Indeed. I had the same questions. However, I don't want to detract
from Wayne's kindness.
Dec 11 '05 #10

P: n/a
On Sun, 11 Dec 2005 15:47:46 -0600, Lauren Wilson <no****@none.com> wrote:
On Sun, 11 Dec 2005 21:18:30 GMT, Wayne Gillespie
<be*****@NOhotmailSPAM.com.au> wrote:
On Sun, 11 Dec 2005 14:43:50 -0600, Lauren Wilson <no****@none.com> wrote:
Hi Wayne,

This code won't compile. It croaks on: booUploadSucceeded = False
with "variable not defined". There are other examples of the same
thing in other procs. Any clues?

Thanks,
-- LW


These are public variables I have probably added to pass the result of an action to other parts of the app.
Either rem out the offending lines if you don't need this functionality, or declare the variables in a separate standard
module.


Thanks Wayne. I wasn't sure to make them public global or private.


Actually looking at it further, I use the 3 variables booUploadSucceeded, booDownloadSucceeded and booIsConnected to do
what you requested in your original post. ie notify the user of errors.

Function fUploadDataFile() As Boolean
Dim strSQL As String
Dim Bfdb As Database
Dim rst As DAO.Recordset
Dim strServer As String
Dim strRemoteFolder As String
Dim strLocalFolder As String
Dim strUserName As String
Dim strPassword As String
Dim strFileName As String
Dim strUploadCompany As String
Dim msgtxt As String

On Error GoTo HandleIt
DoCmd.Hourglass True
fUploadDataFile = False

DoCmd.OpenForm "frmWaitUpload"
DoCmd.SelectObject acForm, "frmWaitUpload"
DoEvents

'get ftp paramaters
Set Bfdb = CurrentDb()
strSQL = "SELECT * FROM atblFtpParamaters;"
Set rst = Bfdb.OpenRecordset(strSQL, dbOpenSnapshot)
With rst
If .RecordCount <> 0 Then
.MoveFirst
strServer = !ServerName
strRemoteFolder = !RemoteDir
strLocalFolder = !LocalDir
strUserName = !UserName
strPassword = !Password
strFileName = !UploadFilename
strUploadCompany = !UploadCompany
End If
.Close
End With

With New FTPClient
.ServerName = strServer
.UserName = strUserName
.Password = strPassword
.RemoteDir = strRemoteFolder
.TransferType = "BINARY"

.OpenFTP
.OpenServer
If Not (booIsConnected) Then '<<<<<<<<<<<<<<<<<<<<<<<<
Beep
msgtxt = "You are not connected to the internet." & vbCrLf
msgtxt = msgtxt & "Connect to the internet and then try the upload again."
MsgBox msgtxt, vbInformation + vbOKOnly
DoEvents
GoTo OutHere
Else 'put file on server
.PutFile .RemoteDir, strFileName, strLocalFolder & strFileName, "BINARY"
fUploadDataFile = booUploadSucceeded '<<<<<<<<<<<<<<<<<<<<<
End If
.CloseServer
.CloseFTP
End With
DoEvents

OutHere:
DoCmd.Close acForm, "frmWaitUpload"
If Not (FTPClient Is Nothing) Then Set FTPClient = Nothing
If Not (rst Is Nothing) Then Set rst = Nothing
If Not (Bfdb Is Nothing) Then Set Bfdb = Nothing
DoCmd.Hourglass False
On Error GoTo 0
Exit Function

HandleIt:
Select Case Err.Number
Case 0, 91
Resume Next
Case Else
MsgBox Err & " " & Err.Description
fUploadDataFile = False
Resume OutHere
End Select

End Function

Wayne Gillespie
Gosford NSW Australia
Dec 11 '05 #11

P: n/a

Wayne,

You have been so kind, I hate to be a pest but I wonder if you have a
form that uses this class module? I'm on such a short deadline, it
would really help me make sense of how to use all these functions,
methods and properties much more quickly if I could see an Access form
that already has this class code implemented behind controls for
retrieving files and sending files back to the server. Then I could
just modify it or use it as a guide to integrate it into our app.

Thanks.


On Sun, 11 Dec 2005 22:03:47 GMT, Wayne Gillespie
<be*****@NOhotmailSPAM.com.au> wrote:
On Sun, 11 Dec 2005 15:47:46 -0600, Lauren Wilson <no****@none.com> wrote:
On Sun, 11 Dec 2005 21:18:30 GMT, Wayne Gillespie
<be*****@NOhotmailSPAM.com.au> wrote:
On Sun, 11 Dec 2005 14:43:50 -0600, Lauren Wilson <no****@none.com> wrote:

Hi Wayne,

This code won't compile. It croaks on: booUploadSucceeded = False
with "variable not defined". There are other examples of the same
thing in other procs. Any clues?

Thanks,
-- LW

These are public variables I have probably added to pass the result of an action to other parts of the app.
Either rem out the offending lines if you don't need this functionality, or declare the variables in a separate standard
module.


Thanks Wayne. I wasn't sure to make them public global or private.


Actually looking at it further, I use the 3 variables booUploadSucceeded, booDownloadSucceeded and booIsConnected to do
what you requested in your original post. ie notify the user of errors.

Function fUploadDataFile() As Boolean
Dim strSQL As String
Dim Bfdb As Database
Dim rst As DAO.Recordset
Dim strServer As String
Dim strRemoteFolder As String
Dim strLocalFolder As String
Dim strUserName As String
Dim strPassword As String
Dim strFileName As String
Dim strUploadCompany As String
Dim msgtxt As String

On Error GoTo HandleIt
DoCmd.Hourglass True
fUploadDataFile = False

DoCmd.OpenForm "frmWaitUpload"
DoCmd.SelectObject acForm, "frmWaitUpload"
DoEvents

'get ftp paramaters
Set Bfdb = CurrentDb()
strSQL = "SELECT * FROM atblFtpParamaters;"
Set rst = Bfdb.OpenRecordset(strSQL, dbOpenSnapshot)
With rst
If .RecordCount <> 0 Then
.MoveFirst
strServer = !ServerName
strRemoteFolder = !RemoteDir
strLocalFolder = !LocalDir
strUserName = !UserName
strPassword = !Password
strFileName = !UploadFilename
strUploadCompany = !UploadCompany
End If
.Close
End With

With New FTPClient
.ServerName = strServer
.UserName = strUserName
.Password = strPassword
.RemoteDir = strRemoteFolder
.TransferType = "BINARY"

.OpenFTP
.OpenServer
If Not (booIsConnected) Then '<<<<<<<<<<<<<<<<<<<<<<<<
Beep
msgtxt = "You are not connected to the internet." & vbCrLf
msgtxt = msgtxt & "Connect to the internet and then try the upload again."
MsgBox msgtxt, vbInformation + vbOKOnly
DoEvents
GoTo OutHere
Else 'put file on server
.PutFile .RemoteDir, strFileName, strLocalFolder & strFileName, "BINARY"
fUploadDataFile = booUploadSucceeded '<<<<<<<<<<<<<<<<<<<<<
End If
.CloseServer
.CloseFTP
End With
DoEvents

OutHere:
DoCmd.Close acForm, "frmWaitUpload"
If Not (FTPClient Is Nothing) Then Set FTPClient = Nothing
If Not (rst Is Nothing) Then Set rst = Nothing
If Not (Bfdb Is Nothing) Then Set Bfdb = Nothing
DoCmd.Hourglass False
On Error GoTo 0
Exit Function

HandleIt:
Select Case Err.Number
Case 0, 91
Resume Next
Case Else
MsgBox Err & " " & Err.Description
fUploadDataFile = False
Resume OutHere
End Select

End Function

Wayne Gillespie
Gosford NSW Australia

Dec 12 '05 #12

P: n/a
On Sun, 11 Dec 2005 22:03:29 -0600, Lauren Wilson <no****@none.com> wrote:

Lauren

I don't really have a form that I can separate out of a main app as an example, but the code behind the upload /
download buttons is very similar to the function I posted (below).

Basically I store all the parameters required to initiate the ftp session in a table along with the folder location I
want to get/put the file from.

The function creates a new instance of the class and passes it the parameters required to access the site -

With New FTPClient
.ServerName = strServer
.UserName = strUserName
.Password = strPassword
.RemoteDir = strRemoteFolder
.TransferType = "BINARY"

It then opens the FTP connection -

.OpenFTP
.OpenServer

If it is able to establish a connection it then uploads the file -

If Not (booIsConnected) Then
Beep
msgtxt = "You are not connected to the internet." & vbCrLf
msgtxt = msgtxt & "Connect to the internet and then try the upload again."
MsgBox msgtxt, vbInformation + vbOKOnly
DoEvents
GoTo OutHere
Else 'put file on server
.PutFile .RemoteDir, strFileName, strLocalFolder & strFileName, "BINARY"
fUploadDataFile = booUploadSucceeded
End If
.CloseServer
.CloseFTP
End With
DoEvents

The download function is virtually identical except it uses .GetFile instead of .PutFile

HTH

Wayne

Wayne,

You have been so kind, I hate to be a pest but I wonder if you have a
form that uses this class module? I'm on such a short deadline, it
would really help me make sense of how to use all these functions,
methods and properties much more quickly if I could see an Access form
that already has this class code implemented behind controls for
retrieving files and sending files back to the server. Then I could
just modify it or use it as a guide to integrate it into our app.

Thanks.


On Sun, 11 Dec 2005 22:03:47 GMT, Wayne Gillespie
<be*****@NOhotmailSPAM.com.au> wrote:
On Sun, 11 Dec 2005 15:47:46 -0600, Lauren Wilson <no****@none.com> wrote:
On Sun, 11 Dec 2005 21:18:30 GMT, Wayne Gillespie
<be*****@NOhotmailSPAM.com.au> wrote:

On Sun, 11 Dec 2005 14:43:50 -0600, Lauren Wilson <no****@none.com> wrote:

>Hi Wayne,
>
>This code won't compile. It croaks on: booUploadSucceeded = False
>with "variable not defined". There are other examples of the same
>thing in other procs. Any clues?
>
>Thanks,
>-- LW

These are public variables I have probably added to pass the result of an action to other parts of the app.
Either rem out the offending lines if you don't need this functionality, or declare the variables in a separate standard
module.

Thanks Wayne. I wasn't sure to make them public global or private.


Actually looking at it further, I use the 3 variables booUploadSucceeded, booDownloadSucceeded and booIsConnected to do
what you requested in your original post. ie notify the user of errors.

Function fUploadDataFile() As Boolean
Dim strSQL As String
Dim Bfdb As Database
Dim rst As DAO.Recordset
Dim strServer As String
Dim strRemoteFolder As String
Dim strLocalFolder As String
Dim strUserName As String
Dim strPassword As String
Dim strFileName As String
Dim strUploadCompany As String
Dim msgtxt As String

On Error GoTo HandleIt
DoCmd.Hourglass True
fUploadDataFile = False

DoCmd.OpenForm "frmWaitUpload"
DoCmd.SelectObject acForm, "frmWaitUpload"
DoEvents

'get ftp paramaters
Set Bfdb = CurrentDb()
strSQL = "SELECT * FROM atblFtpParamaters;"
Set rst = Bfdb.OpenRecordset(strSQL, dbOpenSnapshot)
With rst
If .RecordCount <> 0 Then
.MoveFirst
strServer = !ServerName
strRemoteFolder = !RemoteDir
strLocalFolder = !LocalDir
strUserName = !UserName
strPassword = !Password
strFileName = !UploadFilename
strUploadCompany = !UploadCompany
End If
.Close
End With

With New FTPClient
.ServerName = strServer
.UserName = strUserName
.Password = strPassword
.RemoteDir = strRemoteFolder
.TransferType = "BINARY"

.OpenFTP
.OpenServer
If Not (booIsConnected) Then '<<<<<<<<<<<<<<<<<<<<<<<<
Beep
msgtxt = "You are not connected to the internet." & vbCrLf
msgtxt = msgtxt & "Connect to the internet and then try the upload again."
MsgBox msgtxt, vbInformation + vbOKOnly
DoEvents
GoTo OutHere
Else 'put file on server
.PutFile .RemoteDir, strFileName, strLocalFolder & strFileName, "BINARY"
fUploadDataFile = booUploadSucceeded '<<<<<<<<<<<<<<<<<<<<<
End If
.CloseServer
.CloseFTP
End With
DoEvents

OutHere:
DoCmd.Close acForm, "frmWaitUpload"
If Not (FTPClient Is Nothing) Then Set FTPClient = Nothing
If Not (rst Is Nothing) Then Set rst = Nothing
If Not (Bfdb Is Nothing) Then Set Bfdb = Nothing
DoCmd.Hourglass False
On Error GoTo 0
Exit Function

HandleIt:
Select Case Err.Number
Case 0, 91
Resume Next
Case Else
MsgBox Err & " " & Err.Description
fUploadDataFile = False
Resume OutHere
End Select

End Function

Wayne Gillespie
Gosford NSW Australia


Wayne Gillespie
Gosford NSW Australia
Dec 12 '05 #13

P: n/a

Thanks a lot Wayne. This helps. This is like primary documentation
for a class library.

On Mon, 12 Dec 2005 08:16:10 GMT, Wayne Gillespie
<be*****@NOhotmailSPAM.com.au> wrote:
On Sun, 11 Dec 2005 22:03:29 -0600, Lauren Wilson <no****@none.com> wrote:

Lauren

I don't really have a form that I can separate out of a main app as an example, but the code behind the upload /
download buttons is very similar to the function I posted (below).

Basically I store all the parameters required to initiate the ftp session in a table along with the folder location I
want to get/put the file from.

The function creates a new instance of the class and passes it the parameters required to access the site -

With New FTPClient
.ServerName = strServer
.UserName = strUserName
.Password = strPassword
.RemoteDir = strRemoteFolder
.TransferType = "BINARY"

It then opens the FTP connection -

.OpenFTP
.OpenServer

If it is able to establish a connection it then uploads the file -

If Not (booIsConnected) Then
Beep
msgtxt = "You are not connected to the internet." & vbCrLf
msgtxt = msgtxt & "Connect to the internet and then try the upload again."
MsgBox msgtxt, vbInformation + vbOKOnly
DoEvents
GoTo OutHere
Else 'put file on server
.PutFile .RemoteDir, strFileName, strLocalFolder & strFileName, "BINARY"
fUploadDataFile = booUploadSucceeded
End If
.CloseServer
.CloseFTP
End With
DoEvents

The download function is virtually identical except it uses .GetFile instead of .PutFile

HTH

Wayne

Wayne,

You have been so kind, I hate to be a pest but I wonder if you have a
form that uses this class module? I'm on such a short deadline, it
would really help me make sense of how to use all these functions,
methods and properties much more quickly if I could see an Access form
that already has this class code implemented behind controls for
retrieving files and sending files back to the server. Then I could
just modify it or use it as a guide to integrate it into our app.

Thanks.


On Sun, 11 Dec 2005 22:03:47 GMT, Wayne Gillespie
<be*****@NOhotmailSPAM.com.au> wrote:
On Sun, 11 Dec 2005 15:47:46 -0600, Lauren Wilson <no****@none.com> wrote:

On Sun, 11 Dec 2005 21:18:30 GMT, Wayne Gillespie
<be*****@NOhotmailSPAM.com.au> wrote:

>On Sun, 11 Dec 2005 14:43:50 -0600, Lauren Wilson <no****@none.com> wrote:
>
>>Hi Wayne,
>>
>>This code won't compile. It croaks on: booUploadSucceeded = False
>>with "variable not defined". There are other examples of the same
>>thing in other procs. Any clues?
>>
>>Thanks,
>>-- LW
>
>These are public variables I have probably added to pass the result of an action to other parts of the app.
>Either rem out the offending lines if you don't need this functionality, or declare the variables in a separate standard
>module.

Thanks Wayne. I wasn't sure to make them public global or private.

Actually looking at it further, I use the 3 variables booUploadSucceeded, booDownloadSucceeded and booIsConnected to do
what you requested in your original post. ie notify the user of errors.

Function fUploadDataFile() As Boolean
Dim strSQL As String
Dim Bfdb As Database
Dim rst As DAO.Recordset
Dim strServer As String
Dim strRemoteFolder As String
Dim strLocalFolder As String
Dim strUserName As String
Dim strPassword As String
Dim strFileName As String
Dim strUploadCompany As String
Dim msgtxt As String

On Error GoTo HandleIt
DoCmd.Hourglass True
fUploadDataFile = False

DoCmd.OpenForm "frmWaitUpload"
DoCmd.SelectObject acForm, "frmWaitUpload"
DoEvents

'get ftp paramaters
Set Bfdb = CurrentDb()
strSQL = "SELECT * FROM atblFtpParamaters;"
Set rst = Bfdb.OpenRecordset(strSQL, dbOpenSnapshot)
With rst
If .RecordCount <> 0 Then
.MoveFirst
strServer = !ServerName
strRemoteFolder = !RemoteDir
strLocalFolder = !LocalDir
strUserName = !UserName
strPassword = !Password
strFileName = !UploadFilename
strUploadCompany = !UploadCompany
End If
.Close
End With

With New FTPClient
.ServerName = strServer
.UserName = strUserName
.Password = strPassword
.RemoteDir = strRemoteFolder
.TransferType = "BINARY"

.OpenFTP
.OpenServer
If Not (booIsConnected) Then '<<<<<<<<<<<<<<<<<<<<<<<<
Beep
msgtxt = "You are not connected to the internet." & vbCrLf
msgtxt = msgtxt & "Connect to the internet and then try the upload again."
MsgBox msgtxt, vbInformation + vbOKOnly
DoEvents
GoTo OutHere
Else 'put file on server
.PutFile .RemoteDir, strFileName, strLocalFolder & strFileName, "BINARY"
fUploadDataFile = booUploadSucceeded '<<<<<<<<<<<<<<<<<<<<<
End If
.CloseServer
.CloseFTP
End With
DoEvents

OutHere:
DoCmd.Close acForm, "frmWaitUpload"
If Not (FTPClient Is Nothing) Then Set FTPClient = Nothing
If Not (rst Is Nothing) Then Set rst = Nothing
If Not (Bfdb Is Nothing) Then Set Bfdb = Nothing
DoCmd.Hourglass False
On Error GoTo 0
Exit Function

HandleIt:
Select Case Err.Number
Case 0, 91
Resume Next
Case Else
MsgBox Err & " " & Err.Description
fUploadDataFile = False
Resume OutHere
End Select

End Function

Wayne Gillespie
Gosford NSW Australia


Wayne Gillespie
Gosford NSW Australia

Dec 12 '05 #14

P: n/a
Not sure if either of these will help, but the first is an article I
posted at DBJ about simple FTP commands, based on Dev Ashish's
great code, but extended to add other FTP commands as well.

http://www.databasejournal.com/featu...le.php/3513061

The other is an old VBA app I created in Access 97 that used the
INet control and lots of VBA code. I never actually used this code
in production but I gave it to my brother and his fortune 500 company
used it daily for some time to perform daily FTP process.

http://amazecreations.com/datafast/G...=A97Ftp001.zip

--

Danny J. Lesandrini
dl*********@hotmail.com
http://amazecreations.com/datafast
"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.

Dec 12 '05 #15

P: n/a
Ted
I get a User Defined type not Defined message on the FTPClient in the
line "With New FTPClient" when I try to compile the code you posted.
What am I missing?

Dec 12 '05 #16

P: n/a
On 12 Dec 2005 10:21:43 -0800, "Ted" <be*****@gmail.com> wrote:
I get a User Defined type not Defined message on the FTPClient in the
line "With New FTPClient" when I try to compile the code you posted.
What am I missing?


Did you paste the code into a CLASS module and is the class module called FTPClient?

Wayne Gillespie
Gosford NSW Australia
Dec 12 '05 #17

P: n/a

Well Wayne, I have made very good use of your excellent FTP class
module. There is only one remaining problem: Despite the fact that
you defined FTP error codes in FTPClient, I cannot seem to get the
errors to trigger when they should (for example, "No internet
connection", or "Invalid login", etc.) Do I need to Raise these
error's myself? What am I missing?

Thanks for your help. Happy New Year!

--LW


On Sun, 11 Dec 2005 06:44:08 GMT, Wayne Gillespie
<be*****@NOhotmailSPAM.com.au> wrote:
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

Jan 1 '06 #18

This discussion thread is closed

Replies have been disabled for this discussion.