CFTPclient.cls

Option Explicit

' =========================================
' CFTPclient: wininet ftp functions wrapper
'             needs IE version 4 or above
' =========================================

' FTP file transfer modes
Public Enum enFtpFileMode
  ffm_Ascii = 1&
  ffm_Binary = 2&
End Enum

' Public events
Public Event Connected(ByVal sServer As String, ByVal lPort As Long)
Public Event Message(ByVal sMsg As String)
Public Event DirLine(ByVal vAttr As VbFileAttribute, ByVal dtDateTime As Date, ByVal dSize As Double, ByVal sName As String)
Public Event Progress(ByVal lCurrent As Long, ByVal lTotal As Long, bCancel As Boolean)
Public Event Failure(ByVal lCode As Long, ByVal sMessage As String)
Public Event Disconnected(ByVal sServer As String, ByVal lPort As Long)

' ftp defaults (used in constructor)
Private Const FTP_DEFAULT_SITE = "ftp.cisco.com"
Private Const FTP_DEFAULT_USER = "Anonymous"
Private Const FTP_DEFAULT_PASS = "guest@example.com"
Private Const FTP_DEFAULT_PASV = True

' Private FTP session data
Private Type tag_FtpSession
  sServer         As String   ' server name/ip
  nPort           As Long     ' server port
  sUser           As String   ' username
  sPassword       As String   ' password
  bPassive        As Boolean  ' true=passive mode
  hInternet       As Long     ' internet session handle
  hConnect        As Long     ' ftp session handle
  hCtx            As Long     ' context (not used)
  dwLastError     As Long     ' last error #
  szLastError     As String   ' last error msg
End Type

' private storage area
Private mFTP        As tag_FtpSession     ' current session
Private msAppName   As String             ' application name w/o ".exe"
Private msAgent     As String             ' user agent string
Private mbDebug     As Boolean            ' true=enable debug/trace

' Type of internet connection
Private Enum INTERNET_OPEN_TYPE
  INTERNET_OPEN_TYPE_PRECONFIG = 0                        ' use system (IE) configuration
  INTERNET_OPEN_TYPE_DIRECT = 1                           ' direct to net
  INTERNET_OPEN_TYPE_PROXY = 3                            ' via named proxy
  INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4      ' preconfig, no proxy autodiscovery
End Enum

' Misc constants
Private Const INTERNET_INVALID_PORT_NUMBER = 0            ' invalid port
Private Const INTERNET_DEFAULT_FTP_PORT = 21              ' default for FTP servers
Private Const INTERNET_SERVICE_FTP = 1                    ' FTP service type selector
Private Const INTERNET_FLAG_PASSIVE = &H8000000           ' passive FTP connections
Private Const INTERNET_FLAG_RELOAD = &H80000000           ' avoid data caching

Private Const MAX_PATH = 260                              ' max path/file size
Private Const ERROR_NO_MORE_FILES = 18                    ' end of dir listing

' FileTime (see below)
Private Type FILETIME
  dwLowDateTime       As Long
  dwHighDateTime      As Long
End Type

' Struct used for dir enumeration
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

' Used to convert filetime to vb time
Private Type SYSTEMTIME
  wYear               As Integer
  wMonth              As Integer
  wDayOfWeek          As Integer
  wDay                As Integer
  wHour               As Integer
  wMinute             As Integer
  wSecond             As Integer
  wMilliseconds       As Integer
End Type

' Directory data in VB format
Private Type VB_FIND_DATA
  vFileAttributes     As VbFileAttribute
  dtCreationTime      As Date
  dtLastAccessTime    As Date
  dtLastWriteTime     As Date
  dFileSize           As Double
  sFileName           As String
  sAlternate          As String
End Type

' Date/Time and memory manipulation
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFILETIME As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFILETIME As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal bytes As Long)

' error constants
Private Const ERROR_INTERNET_EXTENDED_ERROR = &H2EE3
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800

' Error messages decoding
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, dwArguments As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpLibFileName As String) As Long

' FTP transfer modes (private)
Private Enum FTP_FILE_OPEN_MODE
  GENERIC_READ = &H80000000                           ' file read mode (download)
  GENERIC_WRITE = &H40000000                          ' file write mode (upload)
End Enum

' FTP transfer types (private)
Private Enum FTP_TRANSFER_TYPE
  FTP_TRANSFER_TYPE_UNKNOWN = &H0&                    ' unknown (binary)
  FTP_TRANSFER_TYPE_ASCII = &H1&                      ' ASCII
  FTP_TRANSFER_TYPE_BINARY = &H2&                     ' binary
  FTP_TRANSFER_NO_CACHE = &H80000000                  ' no caching
End Enum


' open/close an internet session
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal lpszAgent As String, ByVal dwAccessType As INTERNET_OPEN_TYPE, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Private Declare Function InternetClose Lib "wininet.dll" Alias "InternetCloseHandle" (ByVal hInternet As Long) As Long

' last error code/message
Private Declare Function InternetError Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Long

' connect/disconnect an ftp server
Private Declare Function FtpConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternet As Long, ByVal lpszServerName As String, ByVal nServerPort As Long, ByVal lpszUserName As String, ByVal lpszPassword As String, ByVal dwService As Long, ByVal dwFlags As Long, dwContext As Long) As Long
Private Declare Function FtpDisconnect Lib "wininet.dll" Alias "InternetCloseHandle" (ByVal hInternet As Long) As Long

' directory operations
Private Declare Function FtpQueryDir Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" (ByVal hConnect As Long, ByVal lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Long
Private Declare Function FtpChangeDir Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hConnect As Long, ByVal lpszDirectory As String) As Long
Private Declare Function FtpCreateDir Lib "wininet.dll" Alias "FtpCreateDirectoryA" (ByVal hConnect As Long, ByVal lpszDirectory As String) As Long
Private Declare Function FtpRemoveDir Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hConnect As Long, ByVal lpszDirectory As String) As Long
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hConnect As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, dwContext As Long) As Long
Private Declare Function FtpFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FtpFindClose Lib "wininet.dll" Alias "InternetCloseHandle" (ByVal hInternet As Long) As Long

' file operations
Private Declare Function FtpOpenFile Lib "wininet.dll" Alias "FtpOpenFileA" (ByVal hConnect As Long, ByVal lpszFileName As String, ByVal dwAccess As FTP_FILE_OPEN_MODE, ByVal dwFlags As FTP_TRANSFER_TYPE, dwContext As Long) As Long
Private Declare Function FtpFileSize Lib "wininet.dll" Alias "FtpGetFileSize" (ByVal hFile As Long, lpdwFileSizeHigh As Long) As Long
Private Declare Function FtpBuffSize Lib "wininet.dll" Alias "InternetQueryDataAvailable" (ByVal hFile As Long, lpdwNumberOfBytesAvailable As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function FtpReadFile Lib "wininet.dll" Alias "InternetReadFile" (ByVal hFile As Long, ByRef lpBuffer As Byte, ByVal dwNumberOfBytesToRead As Long, lpdwNumberOfBytesRead As Long) As Long
Private Declare Function FtpWriteFile Lib "wininet.dll" Alias "InternetWriteFile" (ByVal hFile As Long, ByRef lpBuffer As Byte, ByVal dwNumberOfBytesToWrite As Long, lpdwNumberOfBytesWritten As Long) As Long
Private Declare Function FtpCloseFile Lib "wininet.dll" Alias "InternetCloseHandle" (ByVal hInternet As Long) As Long
Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hConnect As Long, ByVal lpszFileName As String) As Long
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" (ByVal hConnect As Long, ByVal lpszExisting As String, ByVal lpszNew As String) As Long

' debugging
Private Declare Sub OutputDebugString Lib "kernel32" Alias "OutputDebugStringA" (ByVal lpOutputString As String)

' .:::: Init instance
Private Sub Class_Initialize()
  ' setup some reasonable defaults so that
  ' just instancing the class and calling
  ' the connect method, it will work
  With mFTP
    .sServer = FTP_DEFAULT_SITE
    .nPort = INTERNET_DEFAULT_FTP_PORT
    .sUser = FTP_DEFAULT_USER
    .sPassword = FTP_DEFAULT_PASS
    .bPassive = FTP_DEFAULT_PASV
    .hInternet = 0
    .hConnect = 0
    .hCtx = 0
    .dwLastError = 0
    .szLastError = ""
  End With
  msAppName = GetAppName()
  msAgent = msAppName & "/" & App.Major & "." & App.Minor & " (build=" & App.Revision & ")"
  mbDebug = False
End Sub

' .:::: Release instance
Private Sub Class_Terminate()
  On Local Error Resume Next
  Disconnect
End Sub

' .:::: Server name or IP address
Public Property Let Server(ByVal sServer As String)
  mFTP.sServer = sServer
End Property

Public Property Get Server() As String
  Server = mFTP.sServer
End Property

' .:::: server port #
Public Property Let Port(ByVal nPort As Long)
  mFTP.nPort = nPort
End Property

Public Property Get Port() As Long
  Port = mFTP.nPort
End Property

' .:::: logon user name
Public Property Let User(ByVal sUser As String)
  mFTP.sUser = sUser
End Property

Public Property Get User() As String
  User = mFTP.sUser
End Property

' .:::: logon password
Public Property Let Password(ByVal sPassword As String)
  mFTP.sPassword = sPassword
End Property

Public Property Get Password() As String
  Password = mFTP.sPassword
End Property

' .:::: passive mode
Public Property Let Passive(ByVal bYesNo As Boolean)
  mFTP.bPassive = bYesNo
End Property

Public Property Get Passive() As Boolean
  Passive = mFTP.bPassive
End Property

' .:::: user agent string
Public Property Let UserAgent(ByVal sAgent As String)
  msAgent = sAgent
End Property

Public Property Get UserAgent() As String
  UserAgent = msAgent
End Property

' .:::: debug/trace mode
Public Property Let DebugMode(ByVal bYesNo As Boolean)
  mbDebug = bYesNo
End Property

Public Property Get DebugMode() As Boolean
  DebugMode = mbDebug
End Property

' .:::: last error number/message
Public Property Get LastErrorNum() As Long
  LastErrorNum = mFTP.dwLastError
End Property

Public Property Get LastErrorMsg() As String
  LastErrorMsg = mFTP.szLastError
End Property

' .:::: Connect and logon to ftp server
Public Function Connect() As Boolean
  Dim lErrNo As Long, lFlags As Long
  Dim bRet As Boolean

  On Local Error Resume Next
  bRet = False
  Connect = bRet

  DbgTrace "Connect " & mFTP.sServer & ":" & mFTP.nPort & " " & msAgent

  ' acquire an internet handle
  Err.Clear
  mFTP.hInternet = InternetOpen(msAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0&)
  If (mFTP.hInternet = 0) Then
    DecodeError
    Disconnect
    Exit Function
  End If

  ' connect to the FTP server
  lFlags = IIf(mFTP.bPassive, INTERNET_FLAG_PASSIVE, 0&)
  Err.Clear
  mFTP.hConnect = FtpConnect(mFTP.hInternet, mFTP.sServer, mFTP.nPort, mFTP.sUser, mFTP.sPassword, INTERNET_SERVICE_FTP, lFlags, mFTP.hCtx)
  If (mFTP.hConnect = 0) Then
    DecodeError
    Disconnect
    Exit Function
  End If

  RaiseEvent Connected(mFTP.sServer, mFTP.nPort)
  FtpResponse
  bRet = True

  Connect = bRet
End Function

' .:::: Disconnect
Public Sub Disconnect()
  On Local Error Resume Next
  If (mFTP.hConnect <> 0) Or (mFTP.hInternet <> 0) Then
    RaiseEvent Disconnected(mFTP.sServer, mFTP.nPort)
    DbgTrace "Disconnect"
  End If
  If mFTP.hConnect <> 0 Then
    Call FtpDisconnect(mFTP.hConnect)
    FtpResponse
    mFTP.hConnect = 0
  End If
  If mFTP.hInternet <> 0 Then
    Call InternetClose(mFTP.hInternet)
    mFTP.hInternet = 0
  End If
End Sub

' .:::: read current dir path
Public Function GetCurrentDirectory() As String
  Dim sDir As String, lSize As Long, bRet As Boolean

  On Local Error Resume Next
  lSize = 2048
  sDir = String(lSize, vbNullChar)
  bRet = FtpQueryDir(mFTP.hConnect, sDir, lSize)
  If bRet = False Then
    DecodeError
    sDir = vbNullString
  Else
    FtpResponse
  End If
  sDir = GetSZ(sDir)
  DbgTrace "GetCurrentDirectory = " & sDir
  GetCurrentDirectory = sDir
End Function

' .:::: set current dir path
Public Function SetCurrentDirectory(ByVal sDirectory As String) As Boolean
  Dim bRet As Boolean

  On Local Error Resume Next
  DbgTrace "SetCurrentDirectory " & sDirectory
  bRet = FtpChangeDir(mFTP.hConnect, sDirectory)
  If bRet = False Then
    DecodeError
  Else
    FtpResponse
  End If
  SetCurrentDirectory = bRet
End Function

' .:::: create a directory
Public Function CreateDirectory(ByVal sDirectory As String) As Boolean
  Dim bRet As Boolean

  On Local Error Resume Next
  DbgTrace "CreateDirectory " & sDirectory
  bRet = FtpCreateDir(mFTP.hConnect, sDirectory)
  If bRet = False Then
    DecodeError
  Else
    FtpResponse
  End If
  CreateDirectory = bRet
End Function

' .:::: remove a directory (directory must be empty)
Public Function RemoveDirectory(ByVal sDirectory As String) As Boolean
  Dim bRet As Boolean

  On Local Error Resume Next
  DbgTrace "RemoveDirectory " & sDirectory
  bRet = FtpRemoveDir(mFTP.hConnect, sDirectory)
  If bRet = False Then
    DecodeError
  Else
    FtpResponse
  End If
  RemoveDirectory = bRet
End Function

' .:::: read directory listing
Public Function ReadDirList(Optional ByVal sFileMask As String = vbNullString) As Long
  Dim hFind As Long, tFIND As WIN32_FIND_DATA
  Dim bFind As Boolean, lFiles As Long

  On Local Error Resume Next
  lFiles = -1
  ReadDirList = lFiles
  DbgTrace "ReadDirList " & sFileMask

  ' start the listing
  Err.Clear
  hFind = FtpFindFirstFile(mFTP.hConnect, sFileMask, tFIND, INTERNET_FLAG_RELOAD, mFTP.hCtx)
  If (hFind = 0) Then
    DecodeError
    Exit Function
  End If
  FtpResponse

  ' loop over FTP folder items
  lFiles = 0
  Do
    lFiles = lFiles + 1
    DecodeDirEntry tFIND
    bFind = FtpFindNextFile(hFind, tFIND)
    If bFind = False Then
      If Err.LastDllError <> ERROR_NO_MORE_FILES Then
        DecodeError
        lFiles = -1
      End If
    End If
  Loop While bFind <> False

  ' cleanup and return
  Call FtpFindClose(hFind)
  If lFiles <> -1 Then
    FtpResponse
  End If
  ReadDirList = lFiles
End Function

' .:::: delete a file
Public Function DeleteFile(ByVal sFileName As String) As Boolean
  Dim bRet As Boolean

  On Local Error Resume Next
  DbgTrace "DeleteFile " & sFileName
  bRet = FtpDeleteFile(mFTP.hConnect, sFileName)
  If bRet = False Then
    DecodeError
  Else
    FtpResponse
  End If
  DeleteFile = bRet
End Function

' .:::: rename a file
Public Function RenameFile(ByVal sFileName As String, ByVal sNewName As String) As Boolean
  Dim bRet As Boolean

  On Local Error Resume Next
  DbgTrace "RenameFile " & sFileName & " -> " & sNewName
  bRet = FtpRenameFile(mFTP.hConnect, sFileName, sNewName)
  If bRet = False Then
    DecodeError
  Else
    FtpResponse
  End If
  RenameFile = bRet
End Function

' .:::: download (receive) a file from ftp server
Public Function DownloadFile(ByVal sRemoteFile As String, ByVal sLocalFile As String, Optional ByVal nMode As enFtpFileMode = ffm_Binary) As Boolean
  Dim lMode As FTP_TRANSFER_TYPE
  Dim hLocal As Long, hRemote As Long
  Dim lSizeLow As Long, lSizeHigh As Long
  Dim lSize As Long, lCurrent As Long
  Dim bRet As Boolean, bRead As Boolean
  Dim cbBuff() As Byte, lBuff As Long, lBytes As Long
  Dim bCancel As Boolean

  On Local Error Resume Next
  bRet = False
  lCurrent = 0
  DownloadFile = bRet
  DbgTrace "DownloadFile " & sRemoteFile & " -> " & sLocalFile

  ' open local file for writing (delete existing)
  hLocal = OpenFile(sLocalFile, True)
  If hLocal = 0 Then
    Exit Function
  End If

  ' open remote file for reading
  If nMode = ffm_Ascii Then
    lMode = FTP_TRANSFER_TYPE_ASCII
  Else
    lMode = FTP_TRANSFER_TYPE_BINARY
  End If
  lMode = lMode + FTP_TRANSFER_NO_CACHE
  Err.Clear
  hRemote = FtpOpenFile(mFTP.hConnect, sRemoteFile, GENERIC_READ, lMode, mFTP.hCtx)
  If (hRemote = 0) Then
    DecodeError
    Close #hLocal
    Exit Function
  End If
  FtpResponse

  ' read the remote file size
  lSizeLow = FtpFileSize(hRemote, lSizeHigh)
  lSize = DecodeSize(lSizeLow, lSizeHigh)
  RaiseEvent Progress(lCurrent, lSize, bCancel)

  ' loop: read from ftp and write to file
  If Not bCancel Then
    bRet = False
    Do
      ' find out the current read buffer size
      bRead = FtpBuffSize(hRemote, lBuff, 0&, mFTP.hCtx)
      If lBuff < 1 Then
        lBuff = 1024
      End If
      ReDim cbBuff(lBuff + 1)
      lBytes = 0
      ' read a chunk from remote file
      bRead = FtpReadFile(hRemote, cbBuff(0), lBuff, lBytes)
      If (bRead <> False) Then
        If (lBytes > 0) Then
          ' write local file
          ReDim Preserve cbBuff(lBytes - 1)
          Err.Clear
          Put #hLocal, , cbBuff
          If Err.Number <> 0 Then
            RaiseEvent Failure(Err.Number, Err.Description)
            DbgTrace "Error: " & Err.Number & " " & Err.Description
            bRead = False
            bRet = False
          Else
            lCurrent = lCurrent + lBytes
            RaiseEvent Progress(lCurrent, lSize, bCancel)
            If bCancel Then
              bRead = False
              bRet = False
            End If
          End If
        Else
          bRead = False
          bRet = True
        End If
      Else
        DecodeError
        bRead = False
        bRet = False
      End If
    Loop While (bRead <> False)
  End If

  If bRet = True Then
    RaiseEvent Progress(lCurrent, lSize, bCancel)
  End If
  Call FtpCloseFile(hRemote)
  If bRet = True Then
    FtpResponse
  End If
  Close #hLocal

  DownloadFile = bRet
End Function

' .:::: upload (send) a file to ftp server
Public Function UploadFile(ByVal sLocalFile As String, ByVal sRemoteFile As String, Optional ByVal nMode As enFtpFileMode = ffm_Binary) As Boolean
  Dim lMode As FTP_TRANSFER_TYPE
  Dim hLocal As Long, hRemote As Long
  Dim lSizeLow As Long, lSizeHigh As Long
  Dim lSize As Long, lCurrent As Long, lRemainder As Long
  Dim bRet As Boolean, bWrite As Boolean
  Dim cbBuff() As Byte, lBuff As Long, lBytes As Long
  Dim bCancel As Boolean

  On Local Error Resume Next
  bRet = False
  lCurrent = 0
  UploadFile = bRet
  DbgTrace "UploadFile " & sLocalFile & " -> " & sRemoteFile

  ' open local file for reading
  hLocal = OpenFile(sLocalFile, False)
  If hLocal = 0 Then
    Exit Function
  End If

  ' open remote file for writing
  If nMode = ffm_Ascii Then
    lMode = FTP_TRANSFER_TYPE_ASCII
  Else
    lMode = FTP_TRANSFER_TYPE_BINARY
  End If
  lMode = lMode + FTP_TRANSFER_NO_CACHE
  Err.Clear
  hRemote = FtpOpenFile(mFTP.hConnect, sRemoteFile, GENERIC_WRITE, lMode, mFTP.hCtx)
  If (hRemote = 0) Then
    DecodeError
    Close #hLocal
    Exit Function
  End If
  FtpResponse

  lSize = FileLen(sLocalFile)
  RaiseEvent Progress(lCurrent, lSize, bCancel)

  ' loop: read from file and write to ftp
  If Not bCancel Then
    bRet = False
    lRemainder = lSize
    Do
      ' read a chunk from local file
      If lRemainder < 1024 Then
        lBuff = lRemainder
      Else
        lBuff = 1024
      End If
      ReDim cbBuff(lBuff - 1)
      lRemainder = lRemainder - lBuff
      Err.Clear
      Get #hLocal, , cbBuff
      If Err.Number <> 0 Then
        RaiseEvent Failure(Err.Number, Err.Description)
        DbgTrace "Error: " & Err.Number & " " & Err.Description
        bWrite = False
        bRet = False
      Else
        ' write a chunk to remote file
        lBytes = 0
        bWrite = FtpWriteFile(hRemote, cbBuff(0), lBuff, lBytes)
        If (bWrite <> False) Then
          If (lBytes > 0) Then
            lCurrent = lCurrent + lBytes
            RaiseEvent Progress(lCurrent, lSize, bCancel)
            If bCancel Then
              bWrite = False
              bRet = False
            End If
          Else
            bWrite = False
            bRet = True
          End If
          If lRemainder < 1 Then
            bWrite = False
            bRet = True
          End If
        Else
          DecodeError
          bWrite = False
          bRet = False
        End If
      End If
    Loop While (bWrite <> False)
  End If
  If bRet = True Then
    RaiseEvent Progress(lCurrent, lSize, bCancel)
  End If
  Call FtpCloseFile(hRemote)
  If bRet = True Then
    FtpResponse
  End If
  Close #hLocal

  UploadFile = bRet
End Function

' :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
' :: Internal service functions - not visible from outer program
' :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

' ==== decode error and signal it
Private Sub DecodeError()
  Dim lSize As Long, lErrNo As Long, lRet As Long
  Dim hMod As Long

  lErrNo = Err.LastDllError
  lSize = 2048
  mFTP.dwLastError = 0
  If lErrNo = ERROR_INTERNET_EXTENDED_ERROR Then
    ' got an FTP error message, try retrieving it
    mFTP.szLastError = String(lSize, vbNullChar)
    lRet = InternetError(mFTP.dwLastError, mFTP.szLastError, lSize)
  End If
  If (lRet <> 0) And (mFTP.dwLastError <> 0) Then
    ' got the message, go on
    mFTP.szLastError = GetSZ(mFTP.szLastError)
  Else
    ' retrieve the message from system
    mFTP.dwLastError = lErrNo
    mFTP.szLastError = ""
    hMod = GetModuleHandle("wininet.dll")
    If hMod <> 0 Then
      lSize = 2048
      mFTP.szLastError = String(lSize, vbNullChar)
      lRet = FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, hMod, lErrNo, 0, mFTP.szLastError, lSize, 0)
      mFTP.dwLastError = lErrNo
      mFTP.szLastError = GetSZ(mFTP.szLastError)
    End If
    If Len(mFTP.szLastError) < 1 Then
      ' unable to retrieve the error message
      mFTP.szLastError = "Unexpected error."
    End If
  End If
  RaiseEvent Failure(mFTP.dwLastError, mFTP.szLastError)
  DbgTrace "Failure: " & mFTP.dwLastError & " " & mFTP.szLastError
End Sub

' ==== FTP responses
Private Sub FtpResponse()
  Dim lSize As Long, lErrNo As Long
  Dim lCode As Long, sData As String
  Dim vaData As Variant, iData As Long
  Dim sMsg As String

  On Local Error Resume Next
  lSize = 2048
  lCode = 0
  sData = String(lSize, vbNullChar)
  ' retrieve the FTP response
  If InternetError(lCode, sData, lSize) Then
    ' response may be multiline, split it
    sData = GetSZ(sData)
    vaData = Split(sData, vbCrLf)
    ' loop over message lines
    For iData = LBound(vaData) To UBound(vaData)
      sMsg = Trim(Replace(vaData(iData), vbCr, " "))
      sMsg = Trim(Replace(sMsg, vbLf, " "))
      If Len(sMsg) > 0 Then
        RaiseEvent Message(sMsg)
        DbgTrace "Message " & sMsg
      End If
    Next iData
  End If
End Sub

' ==== cut an AsciiZ to its length
Private Function GetSZ(ByVal sBuff As String)
  On Local Error Resume Next
  GetSZ = Mid(sBuff, 1, InStr(sBuff & vbNullChar, vbNullChar) - 1)
End Function

' ==== decode a directory entry
Private Sub DecodeDirEntry(tFIND As WIN32_FIND_DATA)
  Dim tDATA As VB_FIND_DATA
  Dim cTemp As Currency
  Dim st As SYSTEMTIME

  On Local Error Resume Next
  With tDATA
    ' if it's a regular file, calculate size
    If (tFIND.dwFileAttributes And vbDirectory) = 0 Then
      CopyMemory cTemp, tFIND.nFileSizeLow, 4
      CopyMemory ByVal VarPtr(cTemp) + 4, tFIND.nFileSizeHigh, 4
      .dFileSize = CDbl(cTemp) * 10000#
    End If
    ' convert file time and set other infos
    FileTimeToSystemTime tFIND.ftLastWriteTime, st
    .dtLastWriteTime = DateSerial(st.wYear, st.wMonth, st.wDay) + TimeSerial(st.wHour, st.wMinute, st.wSecond) + (st.wMilliseconds / 86400000)
    .vFileAttributes = tFIND.dwFileAttributes
    .sFileName = GetSZ(tFIND.cFileName)
    .sAlternate = GetSZ(tFIND.cAlternate) ' <-- not used
    RaiseEvent DirLine(.vFileAttributes, .dtLastWriteTime, .dFileSize, .sFileName)
    DbgTrace "DirLine " & Format(.dtLastWriteTime, "YYYY-MM-DD HH:NN:SS") & " " & Format(.dFileSize, "#,###,###,###,##0") & " " & .sFileName
  End With
End Sub

' ==== decode a qword quantity
Private Function DecodeSize(ByVal lSizeLow As Long, ByVal lSizeHigh As Long) As Double
  Dim cTemp As Currency

  On Local Error Resume Next
  CopyMemory cTemp, lSizeLow, 4
  CopyMemory ByVal VarPtr(cTemp) + 4, lSizeHigh, 4
  DecodeSize = CDbl(cTemp) * 10000#
End Function

' ==== Open a file for read or write
Private Function OpenFile(ByVal sFileName As String, Optional bWrite As Boolean = False) As Long
  Dim hFile As Long, bRet As Boolean

  On Local Error GoTo Catch
  bRet = False
  hFile = FreeFile
  If bWrite Then
    ' write mode, delete local file
    On Local Error Resume Next
    SetAttr sFileName, vbNormal
    Kill sFileName
    ' open file in binary write mode with exclusive access
    On Local Error GoTo Catch
    Open sFileName For Binary Access Write Lock Read Write As #hFile
  Else
    ' open file in binary read mode with exclusive access
    Open sFileName For Binary Access Read Lock Read Write As #hFile
  End If
  bRet = True

BailOut:
  ' common exit point
  On Local Error Resume Next
  If bRet = False Then
    ' got an error
    Close #hFile
    hFile = 0
    If bWrite Then
      Kill sFileName
    End If
  End If
  OpenFile = hFile
  Exit Function

Catch:
  ' error handler
  RaiseEvent Failure(Err.Number, Err.Description)
  DbgTrace "Error: " & Err.Number & " " & Err.Description
  bRet = False
  Resume BailOut
End Function

' ==== writes a debug message
Private Function DbgTrace(ByVal sMsg As String)
  Dim sTxt As String

  On Local Error Resume Next
  If mbDebug = True Then
    ' compose and emit the trace message
    Debug.Print sMsg
    sTxt = "[" & msAppName & "][FTP] " & sMsg & vbCrLf
    Call OutputDebugString(sTxt)
  End If
End Function

' ==== gets the application name
Private Function GetAppName() As String
  Dim nPos As Integer
  Dim sName As String

  sName = App.EXEName
  nPos = InStr(sName, ".")
  If nPos > 0 Then
    sName = Mid(sName, 1, nPos - 1)
  End If
  GetAppName = sName
End Function