|
How to create an FTP client within Access
By William Hindman,Darren Dick, and Jim Lawrence
Demo File: How to create an FTP client within Access download sample MDB file Print this Page
Demo file, How to create an FTP client within Access download
This application includes a number of very interesting components via a Common File Dialog:
The one key module that will be discussed in this article is the Class exposing the FTP client.
To use a FTP client you’ll need a good understanding of the API functions within the ‘wininet.dll’. This DLL is a very important program and many Microsoft key applications are designed around it. Without it, programs like Outlook, Internet Explorer, and FTP would not function.
Here is a class module created to expose these features. First the declaration section:
|
Option
Compare Database Option
Explicit ''''''''''''''''''''''''''''''' '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. (FILE NOT PRESENT IN
DIRECTORY)" 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." & vbCrLf & "(FILE NOT FOUND IN REMOTE DIRECTORY -
or REMOTE DIRECTORY DOES NOT EXIST)" 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 |
A staggering
array of features is exposed within the previous declaration section. These
features give the class the capabilities to do the following:
To
set up the Class the private and public properties must be created. The Private
Properties are only accessible within the class and the Public properties can be
accessed externally. The Let properties can acquire information and the Get
properties can receive and store information.
There
is a Let/Get property for each of the FTP client requirements: Server name,
username, password, type of access, type of transfer, and names of files to
send or receive.
|
''''''''''''''''''''''''''''''' '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 |
The
next section is the Class methods. These private and public functions perform
most of the duties required by the Class. First the opening methods:
|
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 |
Before
further processing is done the Class_Initialize methods clears all the Public
variables. The initialization is performed automatically when an Instant of the
Class is created.
|
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 |
If
Proxy settings are used the information can either be set or retrieved from the
Properties.
|
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 End
Sub |
The
above code checks that all the required parameters are provided or have been
set previously so a connection to the FTP server can be made.
|
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 End
Sub |
The above Method uses the standard set of Properties
to access the FTP server. If an error is not raised to the caller, routine
processing continues.
Below is a standard set of Methods for handling
files. They get, put, rename and delete files from the FTP server:
|
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 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 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 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 |
The
next set of Methods manage the FTP server by providing navigation through the
directories, acquiring and display files within those directories and allow the
remote user to create and delete directories.
|
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 ' '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
|