Create a new CLASS module and paste this source code into it. If you have previously downloaded issue #56 you should add this code to that class. If you have not downloaded issue 56 you should get it first at http://www.codeoftheweek.com/membersonly/bi/0056.html and then add this code to it.
You should name this class module cFTP. If you have any questions, email us at help@codeoftheweek.com
'----------------------------------------------------------------------
'
' Module Name: cFTP
' Written By: C&D Programming Corp.
' Create Date: 9/99
' Copyright: Copyright 1999 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
'
' BE SURE TO INCLUDE THE SOURCE FROM ISSUE #55 and
' #56 FOR COMPLETE FUNCTIONALITY.
'
' http://www.codeoftheweek.com/membersonly/bi/0055.html
' http://www.codeoftheweek.com/membersonly/bi/0056.html
'
Private Declare Function InternetWriteFile Lib "wininet.dll" _
(ByVal hFile As Long, ByVal sBuffer As String, _
ByVal lNumberOfBytesToWrite As Long, _
lNumberOfBytesWritten As Long) As Integer
Public Sub UploadWithStatus()
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, "cFTP.UploadWithStatus", _
"You must specify a source filename, such as c:\Upload\filename.zip"
End If
If Dir(SourceFilename) = "" Then
Err.Raise 53, "cFTP.UploadWithStatus", "The file " & SourceFilename & " does not exist."
End If
If Trim$(DestinationFilename) = "" Then
Err.Raise 5, "cFTP.UploadWithStatus", _
"You must specify a filename to store the Uploaded data, such as /public/filename.zip"
End If
'
' try to connect to server. If we can't connect, raise an error.
'
ConnectToServer
' break apart filename for passing to the Ftp call
' we need to do this because the Ftp 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 files.
sFileRemote = DestinationFilename
lPos = FindLastOccurrence(sFileRemote, "/")
sDirRemote = Left(sFileRemote, lPos)
sFileRemote = Right(sFileRemote, Len(sFileRemote) - lPos)
sFileLocal = SourceFilename
' 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
Dim sData As String ' to get data from the net
Dim lNumberOfBytesWritten As Long ' number of bytes written by the InternetWriteFile routine
Dim curTotalBytes As Currency ' total number of bytes read for this call
Dim hFile As Long ' file handle to use in InternetReadFile
' this is a pointer to the remote file
Dim curFileSize As Currency ' to hold the filesize of the file about to
' be transferred
Dim iInFile As Integer ' Handle for input file
' retrieve the file size if possible, returns -1 if it can not be
' determined
curFileSize = FileLen(sFileLocal)
' open destination file
iInFile = FreeFile
On Error Resume Next
Open sFileLocal For Binary As iInFile
If Err Then
DisconnectFromServer
TerminateSession
Err.Raise Err.Number, "cFTP.UploadWithStatus", "Could not open input file: " & sFileLocal & vbCrLf & "Error was " & Err.Description
End If
On Error GoTo Handler
' open file and force it to be loaded from the network, even if it is
' already cached.
hFile = FtpOpenFile(mhConnection, sFileRemote, GENERIC_WRITE, _
lDataType Or INTERNET_FLAG_RELOAD, vbNull)
' init our counter and buffer
curTotalBytes = 0
' loop until there is no more data to be written
Do
' if the size of the file is less than one BufferSize then just send it.
If LOF(iInFile) <= BufferSize Then
sData = Input(LOF(iInFile) - 1, iInFile)
Else
If Loc(iInFile) + BufferSize > LOF(iInFile) Then
sData = Input(LOF(iInFile) - Loc(iInFile) + 1, iInFile)
Else
sData = Input(BufferSize, iInFile)
End If
End If
bRet = InternetWriteFile(hFile, sData, Len(sData), _
lNumberOfBytesWritten)
If Not bRet Then
Dim lError As Long
Dim sErrorData As String
sErrorData = String(1024, " ")
InternetGetLastResponseInfo lError, sErrorData, Len(sErrorData) - 1
End If
RaiseEvent TransferProgress(lNumberOfBytesWritten, curTotalBytes, curFileSize)
curTotalBytes = curTotalBytes + lNumberOfBytesWritten
Loop Until EOF(iInFile)
Close iInFile
RaiseEvent TransferComplete(curTotalBytes)
' close of file handle for FTP file
InternetCloseHandle hFile
If bRet Then
DisconnectFromServer
TerminateSession
Else
Err.Raise Err.LastDllError, "cFTP.UploadWithStatus", ErrorMessage(Err.LastDllError)
End If
Exit Sub
Handler:
If Err Then
Err.Raise 5, "cFTP.UploadWithStatus", "Trying to Upload file from " & ServerName & "." & vbCrLf & vbCrLf & "Error Message: " & Err.Description
Exit Sub
End If
Err.Raise Err.Number, "cFTP.UploadWithStatus", Err.Description
Resume
End Sub