Just paste this source code into a module called basDates and include it in your project.
'----------------------------------------------------------------------
'
' Module Name: cFTP
' Written By: C&D Programming Corp.
' Create Date: 8/98
' Copyright: Copyright 1998 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
Option Explicit
'
' Initializes an application's use of the Win32 Internet functions
'
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
'
' Closes a single Internet handle or a subtree of Internet handles.
'
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
'
' Opens a HTTP/FTP session for a given site.
'
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
'
' Retrieves a file using the FTP protocol
'
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
'
' Changes the directory on the remote server
'
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" _
Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Boolean
' User agent constant.
Private Const scUserAgent = "vb5 wininet"
' Use registry access settings.
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
' This is the type of service that you are connecting to
Private Const INTERNET_SERVICE_FTP = 1
Private Const INTERNET_SERVICE_GOPHER = 2
Private Const INTERNET_SERVICE_HTTP = 3
' These are the available FTP transfer types.
Private Const FTP_TRANSFER_TYPE_ASCII = &H1 ' one of these are wrong
Private Const FTP_TRANSFER_TYPE_BINARY = &H2
' Brings the data across the wire even if it locally cached.
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
Private Const INTERNET_FLAG_MULTIPART = &H200000
Private Const INTERNET_INVALID_PORT_NUMBER = 0 ' used to get a port number in the
' InternetConnect call
Private Const INTERNET_FLAG_PASSIVE = &H8000000
'
' information to retrieve error codes and messages
'
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" _
Alias "InternetGetLastResponseInfoA" ( _
lpdwError As Long, _
ByVal lpszBuffer As String, _
lpdwBufferLength As Long) As Boolean
' No more handles could be generated at this time.
Private Const ERROR_INTERNET_OUT_OF_HANDLES = 12001
' The request has timed out.
Private Const ERROR_INTERNET_TIMEOUT = 12002
' An extended error was returned from the server. This is typically a string or buffer containing a verbose error message. Call InternetGetLastResponseInfo to retrieve the error text.
Private Const ERROR_INTERNET_EXTENDED_ERROR = 12003
' An internal error has occurred.
Private Const ERROR_INTERNET_INTERNAL_ERROR = 12004
' The URL is invalid.
Private Const ERROR_INTERNET_INVALID_URL = 12005
' The URL scheme could not be recognized or is not supported.
Private Const ERROR_INTERNET_UNRECOGNIZED_SCHEME = 12006
' The server name could not be resolved.
Private Const ERROR_INTERNET_NAME_NOT_RESOLVED = 12007
' The requested protocol could not be located.
Private Const ERROR_INTERNET_PROTOCOL_NOT_FOUND = 12008
' A request to InternetQueryOption or InternetSetOption specified an invalid option value.
Private Const ERROR_INTERNET_INVALID_OPTION = 12009
' The length of an option supplied to InternetQueryOption or InternetSetOption is incorrect for the type of option specified.
Private Const ERROR_INTERNET_BAD_OPTION_LENGTH = 12010
' The request option cannot be set, only queried.
Private Const ERROR_INTERNET_OPTION_NOT_SETTABLE = 12011
' The Win32 Internet function support is being shut down or unloaded.
Private Const ERROR_INTERNET_SHUTDOWN = 12012
' The request to connect and log on to an FTP server could not be completed because the supplied user name is incorrect.
Private Const ERROR_INTERNET_INCORRECT_USER_NAME = 12013
' The request to connect and log on to an FTP server could not be completed because the supplied password is incorrect.
Private Const ERROR_INTERNET_INCORRECT_PASSWORD = 12014
' The request to connect to and log on to an FTP server failed.
Private Const ERROR_INTERNET_LOGIN_FAILURE = 12015
' The requested operation is invalid.
Private Const ERROR_INTERNET_INVALID_OPERATION = 12016
' The operation was canceled, usually because the handle on which the request was operating was closed before the operation completed.
Private Const ERROR_INTERNET_OPERATION_CANCELLED = 12017
' The type of handle supplied is incorrect for this operation.
Private Const ERROR_INTERNET_INCORRECT_HANDLE_TYPE = 12018
' The requested operation cannot be carried out because the handle supplied is not in the correct state.
Private Const ERROR_INTERNET_INCORRECT_HANDLE_STATE = 12019
' The request cannot be made via a proxy.
Private Const ERROR_INTERNET_NOT_PROXY_REQUEST = 12020
' A required registry value could not be located.
Private Const ERROR_INTERNET_REGISTRY_VALUE_NOT_FOUND = 12021
' A required registry value was located but is an incorrect type or has an invalid value.
Private Const ERROR_INTERNET_BAD_REGISTRY_PARAMETER = 12022
' Direct network access cannot be made at this time.
Private Const ERROR_INTERNET_NO_DIRECT_ACCESS = 12023
' An asynchronous request could not be made because a zero context value was supplied.
Private Const ERROR_INTERNET_NO_CONTEXT = 12024
' An asynchronous request could not be made because a callback function has not been set.
Private Const ERROR_INTERNET_NO_CALLBACK = 12025
' The required operation could not be completed because one or more requests are pending.
Private Const ERROR_INTERNET_REQUEST_PENDING = 12026
' The format of the request is invalid.
Private Const ERROR_INTERNET_INCORRECT_FORMAT = 12027
' The requested item could not be located.
Private Const ERROR_INTERNET_ITEM_NOT_FOUND = 12028
' The attempt to connect to the server failed.
Private Const ERROR_INTERNET_CANNOT_CONNECT = 12029
' The connection with the server has been terminated.
Private Const ERROR_INTERNET_CONNECTION_ABORTED = 12030
' The connection with the server has been reset.
Private Const ERROR_INTERNET_CONNECTION_RESET = 12031
' Calls for the Win32 Internet function to redo the request.
Private Const ERROR_INTERNET_FORCE_RETRY = 12032
' Invalid Proxy request
Private Const ERROR_INTERNET_INVALID_PROXY_REQUEST = 12033
' The request failed because the handle already exists.
Private Const ERROR_INTERNET_HANDLE_EXISTS = 12036
' Security certifcate date is invalid
Private Const ERROR_INTERNET_SEC_CERT_DATE_INVALID = 12037
' Security certifcate CN is invalid
Private Const ERROR_INTERNET_SEC_CERT_CN_INVALID = 12038
' HTTP to HTTPS on redirect
Private Const ERROR_INTERNET_HTTP_TO_HTTPS_ON_REDIR = 12039
' HTTPS to HTTP on redirect
Private Const ERROR_INTERNET_HTTPS_TO_HTTP_ON_REDIR = 12040
' Indicates that the content is not entirely secure. Some of the content being viewed may have come from unsecured servers.
Private Const ERROR_INTERNET_MIXED_SECURITY = 12041
' Change posting is non-secure
Private Const ERROR_INTERNET_CHG_POST_IS_NON_SECURE = 12042
' Post is non-secure
Private Const ERROR_INTERNET_POST_IS_NON_SECURE = 12043
' The requested operation cannot be made on the FTP session handle because an operation is already in progress.
Private Const ERROR_FTP_TRANSFER_IN_PROGRESS = 12110
' The FTP operation was not completed because the session was aborted.
Private Const ERROR_FTP_DROPPED = 12111
' An error was detected while parsing data returned from the gopher server.
Private Const ERROR_GOPHER_PROTOCOL_ERROR = 12130
' The request must be made for a file locator.
Private Const ERROR_GOPHER_NOT_FILE = 12131
' An error was detected while receiving data from the gopher server.
Private Const ERROR_GOPHER_DATA_ERROR = 12132
' The end of the data has been reached.
Private Const ERROR_GOPHER_END_OF_DATA = 12133
' The supplied locator is not valid.
Private Const ERROR_GOPHER_INVALID_LOCATOR = 12134
' The type of the locator is not correct for this operation.
Private Const ERROR_GOPHER_INCORRECT_LOCATOR_TYPE = 12135
' The requested operation can only be made against a Gopher+ server or with a locator that specifies a Gopher+ operation.
Private Const ERROR_GOPHER_NOT_GOPHER_PLUS = 12136
' The requested attribute could not be located.
Private Const ERROR_GOPHER_ATTRIBUTE_NOT_FOUND = 12137
' The locator type is unknown.
Private Const ERROR_GOPHER_UNKNOWN_LOCATOR = 12138
' The requested header could not be located.
Private Const ERROR_HTTP_HEADER_NOT_FOUND = 12150
' The server did not return any headers.
Private Const ERROR_HTTP_DOWNLEVEL_SERVER = 12151
' The server response could not be parsed.
Private Const ERROR_HTTP_INVALID_SERVER_RESPONSE = 12152
' The supplied header is invalid.
Private Const ERROR_HTTP_INVALID_HEADER = 12153
' The request made to HttpQueryInfo is invalid.
Private Const ERROR_HTTP_INVALID_QUERY_REQUEST = 12154
' The header could not be added because it already exists.
Private Const ERROR_HTTP_HEADER_ALREADY_EXISTS = 12155
' HTTP redirect failed
Private Const ERROR_HTTP_REDIRECT_FAILED = 12156
'
' Public variables
'
Public ProxyServer As String
Public ServerName As String
Public SourceFilename As String
Public DestinationFilename As String
Public Username As String
Public Password As String
Public PassiveMode As Boolean
Public BinaryMode As Boolean
Dim mhOpen As Long
Dim mhConnection As Long
Public Sub InitSession()
If Len(ProxyServer) <> 0 Then
mhOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PROXY, ProxyServer, vbNullString, 0)
Else
mhOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
End If
If mhOpen = 0 Then
Err.Raise Err.LastDllError, "InitSession", ErrorMessage(Err.LastDllError)
End If
End Sub
Public Sub ConnectToServer()
Dim lFlag As Long
If mhOpen = 0 Then
On Error Resume Next
InitSession
If Err Then
Err.Raise Err.Number, "ConnectToServer", Err.Description
End If
End If
If PassiveMode Then
lFlag = INTERNET_FLAG_PASSIVE
Else
lFlag = 0
End If
mhConnection = InternetConnect(mhOpen, ServerName, INTERNET_INVALID_PORT_NUMBER, _
Username, Password, INTERNET_SERVICE_FTP, lFlag, 0)
If mhConnection = 0 Then
Dim sErr As String
sErr = ErrorMessage(Err.LastDllError)
Err.Raise Err.LastDllError, "InternetConnect", sErr
End If
End Sub
Public Sub DisconnectFromServer()
If mhConnection <> 0 Then
Call InternetCloseHandle(mhConnection)
mhConnection = 0
End If
End Sub
Public Sub TerminateSession()
If mhOpen <> 0 Then
Call InternetCloseHandle(mhOpen)
mhOpen = 0
End If
End Sub
Public Sub OneStepDownload()
Dim bRet As Boolean
Dim sFileRemote As String
Dim sDirRemote As String
Dim sFileLocal As String ' the local filename
Dim lDataType As Long ' data type to transfer the file with binary/ascii
Dim lPos As Long
On Error GoTo Handler
'
' Do some data validation on the source filename and
' the destination filename
'
If SourceFilename = "" Then
Err.Raise 5, "cInternet.DownloadFile", _
"You must specify a source filename, such as /public/filename.zip"
Exit Sub
End If
If Trim$(DestinationFilename) = "" Then
Err.Raise 5, "cInternet.DownloadFile", _
"You must specify a filename to store the downloaded data, such as c:\download\filename.zip"
Exit Sub
End If
'
' try to connect to server. If we can't connect, raise an error.
'
On Error Resume Next
ConnectToServer
If Err Then
Err.Raise 5, "DownloadFile", "Could not connect to server " & ServerName & ". Error was '" & Err.Description & "'"
Exit Sub
End If
On Error GoTo Handler
' break apart filename for passing to the FtpGetFile call
' we need to do this because the FtpGetFile call will not
' automatically change the directory on the ftp server. So,
' we first have to determine the directory and then do a
' remote change directory call to position the ftp server
' to the correct place. After this, we can successfully
' transfer the file.
sFileRemote = SourceFilename
lPos = FindLastOccurrence(sFileRemote, "/")
sDirRemote = Left(sFileRemote, lPos)
sFileRemote = Right(sFileRemote, Len(sFileRemote) - lPos)
sFileLocal = DestinationFilename
' change remote directory to sDirRemote
RemoteChangeDir sDirRemote
' set the data transfer mode
If BinaryMode Then
lDataType = FTP_TRANSFER_TYPE_BINARY
Else
lDataType = FTP_TRANSFER_TYPE_ASCII
End If
' get the file
bRet = FtpGetFile(mhConnection, sFileRemote, sFileLocal, False, _
INTERNET_FLAG_RELOAD, lDataType, 0&)
If Not bRet Then
DisconnectFromServer
TerminateSession
Else
Err.Raise Err.LastDllError, "FtpGetFile", ErrorMessage(Err.LastDllError)
End If
Exit Sub
Handler:
Err.Raise Err.Number, "OneStepDownload", Err.Description
End Sub
Private Sub RemoteChangeDir(sDir As String)
Dim bRet As Boolean
' if the directory is blank, let's assume they really mean the
' root directory
If sDir = "" Then sDir = "/"
bRet = FtpSetCurrentDirectory(mhConnection, sDir)
If bRet = False Then
Err.Raise Err.LastDllError, "RemoteChangeDir", ErrorMessage(Err.LastDllError)
End If
End Sub
Function ErrorMessage(dError As Long) As String
Dim lIntError As Long
Dim lLength As Long
Dim sBuffer As String
If dError = ERROR_INTERNET_EXTENDED_ERROR Then
InternetGetLastResponseInfo lIntError, vbNullString, lLength
sBuffer = String(lLength + 1, 0)
InternetGetLastResponseInfo lIntError, sBuffer, lLength
ErrorMessage = lIntError & " " & sBuffer
Else
' we will include better error handling in the next issue.
ErrorMessage = "Error number " & dError & " occurred."
End If
End Function