CFTPclient.cls

Option Explicit

' //********************************************\\
' |**********************************************|
' |* CFTPclient: wininet ftp functions wrapper  *|
' |*             needs IE version 4 or above    *|
' |**********************************************|
' \\********************************************//

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

' Public events
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)
Public Event Failure(ByVal lCode As Long, ByVal sMessage As String)

' 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

' Storage area
Private mFTP        As tag_FtpSession     ' current session
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   ' prevent using java/script/INS
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)

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
    With mFTP
        .sServer = "ftp.cisco.com"
        .nPort = INTERNET_DEFAULT_FTP_PORT
        .sUser = "anonymous"
        .sPassword = "guest@example.com"
        .bPassive = True
        .hInternet = 0
        .hConnect = 0
        .hCtx = 0
        .dwLastError = 0
        .szLastError = ""
    End With
    msAgent = App.EXEName & "(" & App.Major & ":" & App.Minor & ":" & 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

' .:::: 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

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

    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
    FtpResponse
    bRet = True

    Connect = bRet
End Function

' .:::: Disconnect
Public Sub Disconnect()
    On Local Error Resume Next
    DbgTrace "Disconnect"
    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

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

    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

    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

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

    hLocal = OpenFile(sLocalFile, True)
    If hLocal = 0 Then
        Exit Function
    End If

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

    lSizeLow = FtpFileSize(hRemote, lSizeHigh)
    lSize = DecodeSize(lSizeLow, lSizeHigh)
    RaiseEvent Progress(lCurrent, lSize)

    ' loop: read from ftp and write to file
    bRet = False
    Do
        bRead = FtpBuffSize(hRemote, lBuff, 0&, mFTP.hCtx)
        If lBuff < 1 Then
            lBuff = 1024
        End If
        ReDim cbBuff(lBuff + 1)
        lBytes = 0
        bRead = FtpReadFile(hRemote, cbBuff(0), lBuff, lBytes)
        If (bRead <> False) Then
            If (lBytes > 0) Then
                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)
                End If
            Else
                bRead = False
                bRet = True
            End If
        Else
            DecodeError
            bRead = False
            bRet = False
        End If
    Loop While (bRead <> False)

    If bRet = True Then
        RaiseEvent Progress(lCurrent, lSize)
    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

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

    hLocal = OpenFile(sLocalFile, False)
    If hLocal = 0 Then
        Exit Function
    End If

    If nMode = ffm_Ascii Then
        lMode = FTP_TRANSFER_TYPE_ASCII + FTP_TRANSFER_NO_CACHE
    Else
        lMode = FTP_TRANSFER_TYPE_BINARY + FTP_TRANSFER_NO_CACHE
    End If
    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)

    ' loop: read from file and write to ftp
    bRet = False
    lRemainder = lSize
    Do
        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
            lBytes = 0
            bWrite = FtpWriteFile(hRemote, cbBuff(0), lBuff, lBytes)
            If (bWrite <> False) Then
                If (lBytes > 0) Then
                    lCurrent = lCurrent + lBytes
                    RaiseEvent Progress(lCurrent, lSize)
                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)

    If bRet = True Then
        RaiseEvent Progress(lCurrent, lSize)
    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
    mFTP.szLastError = String(lSize, vbNullChar)
    lRet = InternetError(mFTP.dwLastError, mFTP.szLastError, lSize)
    If (lRet <> 0) And (mFTP.dwLastError <> 0) Then
        mFTP.szLastError = GetSZ(mFTP.szLastError)
    Else
        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
            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)
    If InternetError(lCode, sData, lSize) Then
        sData = GetSZ(sData)
        vaData = Split(sData, vbCrLf)
        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 (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
        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
        On Local Error Resume Next
        SetAttr sFileName, vbNormal
        Kill sFileName
        On Local Error GoTo Catch
        Open sFileName For Binary Access Write Lock Read Write As #hFile
    Else
        Open sFileName For Binary Access Read Lock Read Write As #hFile
    End If
    bRet = True

BailOut:
    On Local Error Resume Next
    If bRet = False Then
        Close #hFile
        hFile = 0
        If bWrite Then
            Kill sFileName
        End If
    End If
    OpenFile = hFile
    Exit Function

Catch:
    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
        sTxt = "[" & App.EXEName & "][FTP] " & sMsg & vbCrLf
        Call OutputDebugString(sTxt)
    End If
End Function