Source code for Issue Number 106

Copyright 1997-2000 by C&D Programming Corp. All Rights Reserved. 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

Code of the Week Home

Source Code

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 and then add this code to it.

You should name this class module cFTP. If you have any questions, email us at

'   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
Option Explicit


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\"
    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/"
    End If

    ' try to connect to server.  If we can't connect, raise an error.

    ' 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
    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
        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
        ' 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)
            If Loc(iInFile) + BufferSize > LOF(iInFile) Then
                sData = Input(LOF(iInFile) - Loc(iInFile) + 1, iInFile)
                sData = Input(BufferSize, iInFile)
            End If
        End If
        bRet = InternetWriteFile(hFile, sData, Len(sData), _
        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
        Err.Raise Err.LastDllError, "cFTP.UploadWithStatus", ErrorMessage(Err.LastDllError)
    End If
    Exit Sub

    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
End Sub