Option Explicit
'Information
'Address of currently connected server
Private m_strServerAddress As String
'User name used to connect to server "anonymous" for anonymous
Private m_strUserName As String
'Number of last error to occur
Private m_lErrorNumber As Long
'Description of last error to occur
Private m_strErrorInfo As String
'Name of proxy server, vbnullstring if none
Private m_strProxyName As String
'State flags
'Are we currently connected to a server
Private m_blIsConnected As Boolean
'Handle of current server connection
Private m_hConn As Long
'Handle of current internet session
Private m_hSession As Long
'Option flags for the current internet session: use of proxy and DNS services
Private m_lInternetOptions As Long
'Proxy connection options enum
Public Enum ProxyOptions
PRECONFIG = 0 'Default
DIRECT = 1
PROXY = 3
End Enum
'Usage flags
'Close connection after file transfer is complete?
Private m_blCloseAfterXFer As Boolean
'Replace local file if it already exists or fail the transfer?
Private m_blReplaceLocal As Boolean
'Replace remote file if it already exists or fail the transfer?
Private m_blReplaceRemote As Boolean
'Close internet session when closing server connection?
Private m_blCloseInternet As Boolean
'Custom error messages
'No currently open connection for requested operation
Private Const ERR_NO_CONNECTION = vbObjectError + 2
Private Const ERR_NO_CONNECTION_INFO = "No currently open connection for requested operation."
'Attempt to open a new connection when one is already open
Private Const ERR_ALREADY_OPEN = vbObjectError + 3
Private Const ERR_ALREADY_OPEN_INFO = "Connection already open."
Public Function OpenConnection(strServerAddr As String, strUser As String, strPass As String) As Boolean
'Opens a connection to the specified server
'strServerAddr can be an IP address or server name, cached in ServerName property
'strUser should be a valid user id or anonymous, cached in UserName property
'strPass is a valid password
If m_blIsConnected Then
'Can't open a connection if we already have one open.
m_lErrorNumber = ERR_ALREADY_OPEN
m_strErrorInfo = ERR_ALREADY_OPEN_INFO
OpenConnection = False
Else
'cache the server and user names for retrieval via read-only properties later.
m_strServerAddress = strServerAddr
m_strUserName = strUser
'If we don't alredy have an internet session open, open one.
If m_hSession = 0 Then
m_hSession = InternetOpen(App.EXEName, m_lInternetOptions, m_strProxyName, vbNullString, 0)
If m_hSession = 0 Then
GetErrorInfo "OpenConnection:InternetSession"
OpenConnection = False
'Could not open Internet session for some reason.
'Gotta exit sub here, otherwise InternetConnect will fail also
Exit Function
End If
End If
'Open the specified FTP server
m_hConn = InternetConnect(m_hSession, m_strServerAddress, INTERNET_DEFAULT_FTP_PORT, _
m_strUserName, strPass, INTERNET_SERVICE_FTP, 0, 0)
If m_hConn = 0 Then
GetErrorInfo "OpenConnection:ServerConnect"
OpenConnection = False
'Could not open server for some reason.
Else
OpenConnection = True
m_blIsConnected = True
End If
End If
End Function
Public Function CloseConnection() As Boolean
'Closes the current server connection, and may close the internet session
'as well, if m_blCloseInternet is true
If m_blIsConnected Then
'Close the server connection
m_blIsConnected = False
CloseConnection = True
m_strServerAddress = vbNullString
m_strUserName = vbNullString
InternetCloseHandle m_hConn
'Close the internet session as well, if that option is set
If m_blCloseInternet Then
InternetCloseHandle m_hSession
End If
Else
'Can't close a connection when there isn't one open.
m_lErrorNumber = ERR_NO_CONNECTION
m_strErrorInfo = ERR_NO_CONNECTION
CloseConnection = False
End If
End Function
Public Function GetFile(strLocalName As String, strRemoteName As String, blBinary As Boolean)
'Downloads a file from the remote server
'strLocalName is the full path and name the file will have locally
'strRemoteName is the full path and name of the file on the server
'blBinary sets binary transfer mode if true, ASCII mode if false
Dim lAtts As Long 'transfer attributes
Dim lFlags As Long 'ASCII/Binary mode
Dim blRet As Boolean 'return value from API call
'Set flags for binary/ascii transfer
If blBinary Then
lFlags = FTP_TRANSFER_TYPE_BINARY
Else
lFlags = FTP_TRANSFER_TYPE_ASCII
End If
'Set to always re-download the remote file
lAtts = INTERNET_FLAG_RELOAD
If Not m_blIsConnected Then
'We'll fail if there's no open connection.
'However, this method could be modified to accept a server address and manage
'connections on its own. Left to you to implement if desired.
m_lErrorNumber = ERR_NO_CONNECTION
m_strErrorInfo = ERR_NO_CONNECTION_INFO
Exit Function
Else
'Get the file
blRet = FtpGetFile(m_hConn, strRemoteName, strLocalName, Not m_blReplaceLocal _
, lAtts, lFlags, 0)
If Not blRet Then
GetErrorInfo "GetFile: " & strRemoteName
GetFile = False
'Transfer failed for some reason, get error info
End If
'Pass back the success/failure value
GetFile = blRet
'should we close connection the connection?
If m_blCloseAfterXFer Then
CloseConnection
End If
End If
End Function
Public Function PutFile(strLocalName As String, strRemoteName As String, blBinary As Boolean)
'Uploads a file to the remote server
'strLocalName is the full path and name of the local file
'strRemoteName is the full path and name the file will have on the server
'blBinary sets binary mode if true, ASCII mode if false
Dim blRet As Boolean 'Return value from API call
Dim lFlags As Long 'transfer flags
'Set flags for binary/ascii transfer
If blBinary Then
lFlags = FTP_TRANSFER_TYPE_BINARY
Else
lFlags = FTP_TRANSFER_TYPE_ASCII
End If
If Not m_blIsConnected Then
'We'll fail if there's no open connection.
'However, this method could be modified to accept a server address and manage
'connections on its own. Left to you to implement if desired.
m_lErrorNumber = ERR_NO_CONNECTION
m_strErrorInfo = ERR_NO_CONNECTION_INFO
Exit Function
Else
'Send the file
blRet = FtpPutFile(m_hConn, strLocalName, strRemoteName, lFlags, 0)
If Not blRet Then
GetErrorInfo "PutFile: " & strLocalName
PutFile = False
'Transfer failed for some reason
End If
'pass back the return value
PutFile = blRet
'Should we close the connection?
If m_blCloseAfterXFer Then
CloseConnection
End If
End If
End Function
Public Sub ClearError()
'Clears cached error information
m_lErrorNumber = 0
m_strErrorInfo = vbNullString
End Sub
Public Property Get ErrorNumber() As Long
'Returns error number of the reported error
ErrorNumber = m_lErrorNumber
End Property
Public Property Get ErrorInfo() As String
'Returns description of the last reported error
ErrorInfo = m_strErrorInfo
End Property
Public Property Get UserName() As String
'Returns the user name used to connect
'to the currently active connection
'if IsConnected is false, this will return vbNullString
UserName = m_strUserName
End Property
Public Property Get IsConnected() As Boolean
'Returns true if a connection is open to a server
IsConnected = m_blIsConnected
End Property
Public Property Get ServerName() As String
'Returns the name of the currently connected server
'if IsConnected is false, returns vbNullString
ServerName = m_strServerAddress
End Property
Public Property Let AutoCloseFTP(data As Boolean)
'Sets a value controlling whether or not
'the active FTP connection is closed after
'each Get or Put opertation (True) or if
'the client must handle connections manually
'(False and the default)
m_blCloseAfterXFer = data
End Property
Public Property Get AutoCloseFTP() As Boolean
'Returns a value controlling whether or not
'the active FTP connection is closed after
'each Get or Put opertation (True) or if
'the client must handle connections manually
'(False and the default)
AutoCloseFTP = m_blCloseAfterXFer
End Property
Public Property Let AutoCloseINET(data As Boolean)
'Sets a value controlling whether or not the
'active internet session is closed when a server
'connection is closed (True and the default) or
'if sessions stay open from the first server connection
'for the life of the object(false).
m_blCloseInternet = data
End Property
Public Property Get AutoCloseINET() As Boolean
'Returns a value controlling whether or not the
'active internet session is closed when a server
'connection is closed (True and the default) or
'if sessions stay open from the first server connection
'for the life of the object(false).
AutoCloseINET = m_blCloseInternet
End Property
Public Property Let ProxyName(data As String)
'Sets the name of the proxy server we'll use
'to connect to the internet
If m_hSession = 0 Then
'can't change this once we're in a session
m_strProxyName = data
End If
End Property
Public Property Get ProxyName() As String
'Returns the name of the proxy server we'll use to
'connect to the internet, default is none (vbNullString)
ProxyName = m_strProxyName
End Property
Public Property Let ProxyOptions(data As ProxyOptions)
'Sets the proxy options for the internet session
If m_hSession = 0 Then
'Can't change this once we're in an internet session
m_lInternetOptions = data
End If
End Property
Public Property Get ProxyOptions() As ProxyOptions
ProxyOptions = m_lInternetOptions
End Property
Private Sub Class_Initialize()
'By default, replace when getting and the local file exists
m_blReplaceLocal = True
'But fail when sending and the remote file exists.
m_blReplaceRemote = False
'Also leave server connections open after transfers by default
m_blCloseAfterXFer = False
'and close internet sessions when server connections are closed
m_blCloseInternet = True
'default to no proxy server
m_strProxyName = vbNullString
'and default to use of IE preconfigured settings
m_lInternetOptions = PRECONFIG
End Sub
Private Sub GetErrorInfo(strStatus As String)
Dim lExtErr As Long
Dim strExtErr As String
Dim lBuffLen As Long
If Err.LastDllError = ERROR_INTERNET_EXTENDED_ERROR Then
'get the length of the string buffer needed for the error text
InternetGetLastResponseInfo lExtErr, vbNullString, lBuffLen
'Create a suitably-sized string buffer
strExtErr = String(lBuffLen + 1, 0)
'Get the error info
InternetGetLastResponseInfo lExtErr, strExtErr, lBuffLen
'Strip off that annoying last null char
strExtErr = Trim(Left(strExtErr, Len(strExtErr) - 1))
m_strErrorInfo = "Error reported from " & strStatus & vbCrLf _
& "Server response (if applicable): " & vbCrLf & strExtErr
m_lErrorNumber = lExtErr
Else
m_lErrorNumber = Err.LastDllError
m_strErrorInfo = vbNullString
End If
End Sub
Private Sub Class_Terminate()
'Close any open internet sessions
If m_hSession <> 0 Then
InternetCloseHandle m_hSession
End If
End Sub
