How do I detect an FTP timeout?


DevX Home    Today's Headlines   Articles Archive   Tip Bank   Forums   

Results 1 to 3 of 3

Thread: How do I detect an FTP timeout?

Hybrid View

  1. #1
    Julian Milano Guest

    How do I detect an FTP timeout?


    Hello all,

    At the end of this email, I have appended the code in question.

    Q. I got this code from a VB app and converted it to VBA for XL2K. The
    workings are the same, tho.

    I need to know if an FTP transfer is taking too long or keep an eye on the
    number of bytes per second to determine an FTP connection that has gone bad.
    Has anyone any idea on how to achieve this?

    One of the code lines in question is:

    bRet = FtpGetFile(hConnection, szFileRemote, szFileLocal & "/" &
    szFileRemote, False, _
    INTERNET_FLAG_RELOAD, dwType, 0)

    in the procedure cmdGet_Click().


    Form Code (fmVBFTPNHDS):
    ============

    Dim bActiveSession As Boolean
    Dim hOpen As Long, hConnection As Long
    Dim dwType As Long

    Dim EnumItemNameBag As New Collection
    Dim EnumItemAttributeBag As New Collection

    Private Sub Form_Load()
    bActiveSession = False
    hOpen = 0
    hConnection = 0
    chkPassive.Value = 1
    optBin.Value = 1
    dwType = FTP_TRANSFER_TYPE_BINARY
    Dim imgI As ListImage
    Set imgI = ImageList1.ListImages.Add(, "open", LoadPicture("open.bmp"))
    Set imgI = ImageList1.ListImages.Add(, "closed",
    LoadPicture("closed.bmp"))
    Set imgI = ImageList1.ListImages.Add(, "leaf", LoadPicture("leaf.bmp"))
    Set imgI = ImageList1.ListImages.Add(, "root", LoadPicture("root.bmp"))
    TreeView1.ImageList = ImageList1
    TreeView1.Style = tvwTreelinesPictureText
    EnableUI (False)
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
    cmdClosehOpen_Click
    End Sub

    Private Sub cmdInternetOpen_Click()
    If Len(txtProxy.Text) <> 0 Then
    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PROXY,
    txtProxy.Text, vbNullString, 0)
    Else
    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT,
    vbNullString, vbNullString, 0)
    End If
    If hOpen = 0 Then ErrorOut Err.LastDllError, "InternetOpen"
    EnableUI (True)
    End Sub

    Private Sub cmdClosehOpen_Click()
    If hConnection <> 0 Then InternetCloseHandle (hConnection)
    If hOpen <> 0 Then InternetCloseHandle (hOpen)
    hConnection = 0
    hOpen = 0
    If bActiveSession Then TreeView1.Nodes.Remove txtServer.Text
    bActiveSession = False
    ClearTextBoxAndBag
    EnableUI (False)
    txtFTPAddress.Text = "FTP Server Address: <None>"
    End Sub

    Private Sub cmdConnect_Click()
    If Not bActiveSession And hOpen <> 0 Then
    If txtServer.Text = "" Then
    MsgBox "Please enter a server name!"
    Exit Sub
    End If
    Dim nFlag As Long
    If chkPassive.Value Then
    nFlag = INTERNET_FLAG_PASSIVE
    Else
    nFlag = 0
    End If
    hConnection = InternetConnect(hOpen, txtServer.Text,
    INTERNET_INVALID_PORT_NUMBER, _
    txtUser, txtPassword, INTERNET_SERVICE_FTP, nFlag, 0)
    If hConnection = 0 Then
    bActiveSession = False
    ErrorOut Err.LastDllError, "InternetConnect"
    Else
    txtFTPAddress.Text = "Server Address: " & txtServer.Text
    bActiveSession = True
    EnableUI (CBool(hOpen))
    FillTreeViewControl (txtServer.Text)
    FtpEnumDirectory ("")
    If EnumItemNameBag.Count = 0 Then Exit Sub
    FillTreeViewControl (txtServer.Text)
    End If
    End If
    End Sub

    Private Sub cmdDisconnect_Click()
    bDirEmpty = True
    If hConnection <> 0 Then InternetCloseHandle hConnection
    hConnection = 0
    ClearBag
    TreeView1.Nodes.Remove txtServer.Text
    bActiveSession = False
    EnableUI (True)
    txtFTPAddress.Text = "FTP Server Address: <None>"
    End Sub

    Private Sub ClearTextBoxAndBag()
    txtServer.Text = ""
    txtUser.Text = ""
    txtPassword.Text = ""
    txtProxy.Text = ""
    ClearBag
    End Sub

    Private Sub ClearBag()
    Dim Num As Integer
    For Num = 1 To EnumItemNameBag.Count
    EnumItemNameBag.Remove 1
    Next Num
    For Num = 1 To EnumItemAttributeBag.Count
    EnumItemAttributeBag.Remove 1
    Next Num
    End Sub

    Private Sub FillTreeViewControl(strParentKey As String)
    Dim nodX As Node
    Dim strImg As String
    Dim nCount As Integer, i As Integer
    Dim nAttr As Integer
    Dim strItem As String

    If EnumItemNameBag.Count = 0 And strParentKey = txtServer.Text Then
    Set nodX = TreeView1.Nodes.Add(, tvwFirst, txtServer.Text,
    txtServer.Text, "root")
    Exit Sub
    End If
    nCount = EnumItemAttributeBag.Count
    If nCount = 0 Then Exit Sub
    For i = 1 To nCount
    nAttr = EnumItemAttributeBag.Item(i)
    strItem = EnumItemNameBag(i)
    If nAttr = FILE_ATTRIBUTE_DIRECTORY Then
    strImg = "closed"
    Else
    strImg = "leaf"
    End If
    Set nodX = TreeView1.Nodes.Add(strParentKey, tvwChild, strParentKey
    & "/" & strItem, _
    strParentKey & "/" & strItem, strImg)
    Next
    nodX.EnsureVisible
    End Sub

    Private Sub cmdGet_Click()
    Dim bRet As Boolean
    Dim szFileRemote As String, szDirRemote As String, szFileLocal As String
    Dim szTempString As String
    Dim nPos As Long, nTemp As Long
    Dim nodX As Node
    Set nodX = TreeView1.SelectedItem
    If bActiveSession Then
    If nodX Is Nothing Then
    MsgBox "Please select the item to GET!"
    Exit Sub
    End If
    szTempString = TreeView1.SelectedItem.Text
    szFileRemote = szTempString
    nPos = 0
    nTemp = 0
    Do
    nTemp = InStr(1, szTempString, "/", vbBinaryCompare)
    If nTemp = 0 Then Exit Do
    szTempString = Right(szTempString, Len(szTempString) - nTemp)
    nPos = nTemp + nPos
    Loop
    szDirRemote = Left(szFileRemote, nPos)
    szFileRemote = Right(szFileRemote, Len(szFileRemote) - nPos)
    szFileLocal = File1.Path
    rcd szDirRemote
    bRet = FtpGetFile(hConnection, szFileRemote, szFileLocal & "/" &
    szFileRemote, False, _
    INTERNET_FLAG_RELOAD, dwType, 0)
    File1.Refresh
    If bRet = False Then ErrorOut Err.LastDllError, "FtpGetFile"
    Else
    MsgBox "Not in session"
    End If
    End Sub

    Private Sub cmdPut_Click()
    Dim bRet As Boolean
    Dim szFileRemote As String, szDirRemote As String, szFileLocal As String
    Dim szTempString As String
    Dim nPos As Long, nTemp As Long
    Dim nodX As Node
    Set nodX = TreeView1.SelectedItem

    If bActiveSession Then
    If nodX Is Nothing Then
    MsgBox "Please select a remote directory to PUT to!"
    Exit Sub
    End If
    If nodX.Image = "leaf" Then
    MsgBox "Please select a remote directory to PUT to!"
    Exit Sub
    End If
    If File1.filename = "" Then
    MsgBox "Please select a local file to put"
    Exit Sub
    End If
    szTempString = nodX.Text
    szDirRemote = Right(szTempString, Len(szTempString) -
    Len(txtServer.Text))
    szFileRemote = File1.filename
    szFileLocal = File1.Path & "\" & File1.filename
    If (szDirRemote = "") Then szDirRemote = "\"
    rcd szDirRemote

    bRet = FtpPutFile(hConnection, szFileLocal, szFileRemote, _
    dwType, 0)
    If bRet = False Then
    ErrorOut Err.LastDllError, "FtpPutFile"
    Exit Sub
    End If

    Dim nodChild As Node, nodNextChild As Node
    Set nodChild = nodX.Child
    Do
    If nodChild Is Nothing Then Exit Do
    Set nodNextChild = nodChild.Next
    TreeView1.Nodes.Remove nodChild.Index
    If nodNextChild Is Nothing Then Exit Do
    Set nodChild = nodNextChild
    Loop
    If nodX.Image = "closed" Then
    nodX.Image = "open"
    End If
    FtpEnumDirectory (nodX.Text)
    FillTreeViewControl (nodX.Text)
    End If
    End Sub

    Private Sub Dir1_Change()
    File1.Path = Dir1.Path
    End Sub

    Private Sub Drive1_Change()
    On Error GoTo ErrProc
    Dir1.Path = Drive1.Drive
    Exit Sub
    ErrProc:
    Drive1.Drive = "c:"
    Dir1.Path = Drive1.Drive
    End Sub

    Private Sub rcd(pszDir As String)
    If pszDir = "" Then
    MsgBox "Please enter the directory to CD"
    Exit Sub
    Else
    Dim sPathFromRoot As String
    Dim bRet As Boolean
    If InStr(1, pszDir, txtServer.Text) Then
    sPathFromRoot = Mid(pszDir, Len(txtServer.Text) + 1, Len(pszDir)
    -
    Len(txtServer.Text))
    Else
    sPathFromRoot = pszDir
    End If
    If sPathFromRoot = "" Then sPathFromRoot = "/"
    bRet = FtpSetCurrentDirectory(hConnection, sPathFromRoot)
    If bRet = False Then ErrorOut Err.LastDllError, "rcd"
    End If
    End Sub

    Function ErrorOut(dError As Long, szCallFunction As String)
    Dim dwIntError As Long, dwLength As Long
    Dim strBuffer As String
    If dError = ERROR_INTERNET_EXTENDED_ERROR Then
    InternetGetLastResponseInfo dwIntError, vbNullString, dwLength
    strBuffer = String(dwLength + 1, 0)
    InternetGetLastResponseInfo dwIntError, strBuffer, dwLength

    MsgBox szCallFunction & " Extd Err: " & dwIntError & " " & strBuffer
    End If
    If MsgBox(szCallFunction & " Err: " & dError & _
    vbCrLf & "Close Connection and Session?", vbYesNo) = vbYes Then
    If hConnection Then InternetCloseHandle hConnection
    If hOpen Then InternetCloseHandle hOpen
    hConnection = 0
    hOpen = 0
    If bActiveSession Then TreeView1.Nodes.Remove txtServer.Text
    bActiveSession = False
    ClearTextBoxAndBag
    EnableUI (False)
    End If
    End Function

    Private Sub EnableUI(bEnabled As Boolean)
    txtServer.Enabled = bEnabled
    txtUser.Enabled = bEnabled
    txtPassword.Enabled = bEnabled
    cmdConnect.Enabled = bEnabled And Not bActiveSession
    cmdDisconnect.Enabled = bEnabled And bActiveSession
    chkPassive.Enabled = bEnabled
    cmdClosehOpen.Enabled = bEnabled
    cmdInternetOpen.Enabled = Not bEnabled
    txtProxy.Enabled = Not bEnabled
    optBin.Enabled = bEnabled
    optAscii.Enabled = bEnabled
    cmdGet.Enabled = bEnabled And bActiveSession
    cmdPut.Enabled = bEnabled And bActiveSession
    End Sub

    Private Sub FtpEnumDirectory(strDirectory As String)

    ClearBag
    Dim hFind As Long
    Dim nLastError As Long
    Dim dError As Long
    Dim ptr As Long
    Dim pData As WIN32_FIND_DATA

    If Len(strDirectory) > 0 Then rcd (strDirectory)
    pData.cFileName = String(MAX_PATH, 0)
    hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
    nLastError = Err.LastDllError

    If hFind = 0 Then
    If (nLastError = ERROR_NO_MORE_FILES) Then
    MsgBox "This directory is empty!"
    Else
    ErrorOut nLastError, "FtpFindFirstFile"
    End If
    Exit Sub
    End If

    dError = NO_ERROR
    Dim bRet As Boolean
    Dim strItemName As String

    EnumItemAttributeBag.Add pData.dwFileAttributes
    strItemName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1,
    0), vbBinaryCompare) - 1)
    EnumItemNameBag.Add strItemName
    Do
    pData.cFileName = String(MAX_PATH, 0)
    bRet = InternetFindNextFile(hFind, pData)
    If Not bRet Then
    dError = Err.LastDllError
    If dError = ERROR_NO_MORE_FILES Then
    Exit Do
    Else
    ErrorOut dError, "InternetFindNextFile"
    InternetCloseHandle (hFind)
    Exit Sub
    End If
    Else
    EnumItemAttributeBag.Add pData.dwFileAttributes
    strItemName = Left(pData.cFileName, InStr(1, pData.cFileName,
    String(1, 0), vbBinaryCompare) - 1)
    EnumItemNameBag.Add strItemName
    End If
    Loop

    InternetCloseHandle (hFind)
    End Sub


    Private Sub optAscii_Click()
    dwType = FTP_TRANSFER_TYPE_ASCII
    End Sub

    Private Sub optBin_Click()
    dwType = FTP_TRANSFER_TYPE_BINARY
    End Sub

    Private Sub TreeView1_DblClick()
    Dim nodX As Node
    Set nodX = TreeView1.SelectedItem
    If Not bActiveSession Then
    MsgBox "No in session!"
    Exit Sub
    End If
    If nodX Is Nothing Then
    MsgBox "no Selection to enumerate"
    End If
    If nodX.Image = "closed" Then
    nodX.Image = "open"
    FtpEnumDirectory (nodX.Text)
    FillTreeViewControl (nodX.Text)
    Else
    If nodX.Image = "open" Then
    nodX.Image = "closed"
    Dim nodChild As Node, nodNextChild As Node
    Set nodChild = nodX.Child
    Do
    Set nodNextChild = nodChild.Next
    TreeView1.Nodes.Remove nodChild.Index
    If nodNextChild Is Nothing Then Exit Do
    Set nodChild = nodNextChild
    Loop
    End If
    End If
    End Sub

    Class Code (modWinInet):
    ====================

    Option Explicit

    Declare Function GetProcessHeap Lib "kernel32" () As Long
    Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal
    dwFlags As Long, ByVal dwBytes As Long) As Long
    Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags
    As Long, lpMem As Any) As Long
    Public Const HEAP_ZERO_MEMORY = &H8
    Public Const HEAP_GENERATE_EXCEPTIONS = &H4

    Declare Sub CopyMemory1 Lib "kernel32" Alias "RtlMoveMemory" ( _
    hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
    Declare Sub CopyMemory2 Lib "kernel32" Alias "RtlMoveMemory" ( _
    hpvDest As Long, hpvSource As Any, ByVal cbCopy As Long)

    Public Const MAX_PATH = 260
    Public Const NO_ERROR = 0
    Public Const FILE_ATTRIBUTE_READONLY = &H1
    Public Const FILE_ATTRIBUTE_HIDDEN = &H2
    Public Const FILE_ATTRIBUTE_SYSTEM = &H4
    Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
    Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
    Public Const FILE_ATTRIBUTE_NORMAL = &H80
    Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
    Public Const FILE_ATTRIBUTE_COMPRESSED = &H800
    Public Const FILE_ATTRIBUTE_OFFLINE = &H1000


    Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
    End Type

    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


    Public Const ERROR_NO_MORE_FILES = 18

    Public Declare Function InternetFindNextFile Lib "wininet.dll" Alias
    "InternetFindNextFileA" _
    (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long

    Public Declare Function FtpFindFirstFile Lib "wininet.dll" Alias
    "FtpFindFirstFileA" _
    (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, _
    lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal
    dwContent As Long) As Long

    Public 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

    Public Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA"
    _
    (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
    ByVal lpszRemoteFile As String, _
    ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean

    Public Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias
    "FtpSetCurrentDirectoryA" _
    (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
    ' Initializes an application's use of the Win32 Internet functions
    Public 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

    ' User agent constant.
    Public Const scUserAgent = "vb wininet"

    ' Use registry access settings.
    Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0
    Public Const INTERNET_OPEN_TYPE_DIRECT = 1
    Public Const INTERNET_OPEN_TYPE_PROXY = 3
    Public Const INTERNET_INVALID_PORT_NUMBER = 0

    Public Const FTP_TRANSFER_TYPE_BINARY = &H2
    Public Const FTP_TRANSFER_TYPE_ASCII = &H1
    Public Const INTERNET_FLAG_PASSIVE = &H8000000

    ' Opens a HTTP session for a given site.
    Public 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

    Public Const ERROR_INTERNET_EXTENDED_ERROR = 12003
    Public Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias
    "InternetGetLastResponseInfoA" ( _
    lpdwError As Long, _
    ByVal lpszBuffer As String, _
    lpdwBufferLength As Long) As Boolean

    ' Number of the TCP/IP port on the server to connect to.
    Public Const INTERNET_DEFAULT_FTP_PORT = 21
    Public Const INTERNET_DEFAULT_GOPHER_PORT = 70
    Public Const INTERNET_DEFAULT_HTTP_PORT = 80
    Public Const INTERNET_DEFAULT_HTTPS_PORT = 443
    Public Const INTERNET_DEFAULT_SOCKS_PORT = 1080

    Public Const INTERNET_OPTION_CONNECT_TIMEOUT = 2
    Public Const INTERNET_OPTION_RECEIVE_TIMEOUT = 6
    Public Const INTERNET_OPTION_SEND_TIMEOUT = 5

    Public Const INTERNET_OPTION_USERNAME = 28
    Public Const INTERNET_OPTION_PASSWORD = 29
    Public Const INTERNET_OPTION_PROXY_USERNAME = 43
    Public Const INTERNET_OPTION_PROXY_PASSWORD = 44

    ' Type of service to access.
    Public Const INTERNET_SERVICE_FTP = 1
    Public Const INTERNET_SERVICE_GOPHER = 2
    Public Const INTERNET_SERVICE_HTTP = 3

    ' Opens an HTTP request handle.
    Public Declare Function HttpOpenRequest Lib "wininet.dll" Alias
    "HttpOpenRequestA" _
    (ByVal hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As
    String, ByVal sVersion As String, _
    ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long,
    ByVal lContext As Long) As Long

    ' Brings the data across the wire even if it locally cached.
    Public Const INTERNET_FLAG_RELOAD = &H80000000
    Public Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
    Public Const INTERNET_FLAG_MULTIPART = &H200000

    Public Const GENERIC_READ = &H80000000
    Public Const GENERIC_WRITE = &H40000000

    ' Sends the specified request to the HTTP server.
    Public Declare Function HttpSendRequest Lib "wininet.dll" Alias
    "HttpSendRequestA" (ByVal _
    hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As
    Long, ByVal sOptional As _
    String, ByVal lOptionalLength As Long) As Integer


    ' Queries for information about an HTTP request.
    Public Declare Function HttpQueryInfo Lib "wininet.dll" Alias
    "HttpQueryInfoA" _
    (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As Any,
    _
    ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer

    ' The possible values for the lInfoLevel parameter include:
    Public Const HTTP_QUERY_CONTENT_TYPE = 1
    Public Const HTTP_QUERY_CONTENT_LENGTH = 5
    Public Const HTTP_QUERY_EXPIRES = 10
    Public Const HTTP_QUERY_LAST_MODIFIED = 11
    Public Const HTTP_QUERY_PRAGMA = 17
    Public Const HTTP_QUERY_VERSION = 18
    Public Const HTTP_QUERY_STATUS_CODE = 19
    Public Const HTTP_QUERY_STATUS_TEXT = 20
    Public Const HTTP_QUERY_RAW_HEADERS = 21
    Public Const HTTP_QUERY_RAW_HEADERS_CRLF = 22
    Public Const HTTP_QUERY_FORWARDED = 30
    Public Const HTTP_QUERY_SERVER = 37
    Public Const HTTP_QUERY_USER_AGENT = 39
    Public Const HTTP_QUERY_SET_COOKIE = 43
    Public Const HTTP_QUERY_REQUEST_METHOD = 45
    Public Const HTTP_STATUS_DENIED = 401
    Public Const HTTP_STATUS_PROXY_AUTH_REQ = 407

    ' Add this flag to the about flags to get request header.
    Public Const HTTP_QUERY_FLAG_REQUEST_HEADERS = &H80000000
    Public Const HTTP_QUERY_FLAG_NUMBER = &H20000000
    ' Reads data from a handle opened by the HttpOpenRequest function.
    Public Declare Function InternetReadFile Lib "wininet.dll" _
    (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As
    Long, _
    lNumberOfBytesRead As Long) As Integer

    Public Declare Function InternetWriteFile Lib "wininet.dll" _
    (ByVal hFile As Long, ByVal sBuffer As String, _
    ByVal lNumberOfBytesToRead As Long, _
    lNumberOfBytesRead As Long) As Integer

    Public Declare Function FtpOpenFile Lib "wininet.dll" Alias _
    "FtpOpenFileA" (ByVal hFtpSession As Long, _
    ByVal sFileName As String, ByVal lAccess As Long, _
    ByVal lFlags As Long, ByVal lContext As Long) As Long
    Public Declare Function FtpDeleteFile Lib "wininet.dll" _
    Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, _
    ByVal lpszFileName As String) As Boolean
    Public Declare Function InternetSetOption Lib "wininet.dll" Alias
    "InternetSetOptionA" _
    (ByVal hInternet As Long, ByVal lOption As Long, ByRef sBuffer As Any, ByVal
    lBufferLength As Long) As Integer
    Public Declare Function InternetSetOptionStr Lib "wininet.dll" Alias
    "InternetSetOptionA" _
    (ByVal hInternet As Long, ByVal lOption As Long, ByVal sBuffer As String,
    ByVal lBufferLength As Long) As Integer

    ' Closes a single Internet handle or a subtree of Internet handles.
    Public Declare Function InternetCloseHandle Lib "wininet.dll" _
    (ByVal hInet As Long) As Integer

    ' Queries an Internet option on the specified handle
    Public Declare Function InternetQueryOption Lib "wininet.dll" Alias
    "InternetQueryOptionA" _
    (ByVal hInternet As Long, ByVal lOption As Long, ByRef sBuffer As Any, ByRef
    lBufferLength As Long) As Integer

    ' Returns the version number of Wininet.dll.
    Public Const INTERNET_OPTION_VERSION = 40

    ' Contains the version number of the DLL that contains the Windows Internet
    ' functions (Wininet.dll). This structure is used when passing the
    ' INTERNET_OPTION_VERSION flag to the InternetQueryOption function.
    Public Type tWinInetDLLVersion
    lMajorVersion As Long
    lMinorVersion As Long
    End Type

    ' Adds one or more HTTP request headers to the HTTP request handle.
    Public Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias
    "HttpAddRequestHeadersA" _
    (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength
    As Long, _
    ByVal lModifiers As Long) As Integer

    ' Flags to modify the semantics of this function. Can be a combination of
    these values:

    ' Adds the header only if it does not already exist; otherwise, an error
    is
    returned.
    Public Const HTTP_ADDREQ_FLAG_ADD_IF_NEW = &H10000000

    ' Adds the header if it does not exist. Used with REPLACE.
    Public Const HTTP_ADDREQ_FLAG_ADD = &H20000000

    ' Replaces or removes a header. If the header value is empty and the header
    is found,
    ' it is removed. If not empty, the header value is replaced
    Public Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000

    --

    -Julian Milano





  2. #2
    Cody Laird Guest

    Re: How do I detect an FTP timeout?


    Julian:

    Here is an example using the InternetReadFile API call that defaults to reading
    1000 byte chunks of the file and raises a simple event each time and when
    completed. Its not perfect, but it will get you started...

    Cody

    'use your declarations and add these if not already defined...
    Public Declare Function FtpOpenFile Lib "wininet.dll" Alias _
    "FtpOpenFileA" (ByVal hFtpSession As Long, _
    ByVal sFilename As String, ByVal lAccess As Long, _
    ByVal lFlags As Long, ByVal lContext As Long) As Long

    Public Declare Function InternetReadFile Lib "wininet.dll" _
    (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long,
    _
    lNumberOfBytesRead As Long) As Integer

    Public Sub GetFileByChunk(Optional pSize As Long = 1000, Optional pRemoteFileName
    As String = "", Optional pLocalFileName As String)
    Dim nRet As Integer
    Dim nFileHandle As Integer
    Dim Data As String
    Dim Written As Long
    Dim Size As Long
    Dim Sum As Long
    Dim hFile As Long
    Dim nLOF As Long

    On Error Resume Next

    mbCancelAction = False

    If pRemoteFileName <> "" Then RemoteFileName = pRemoteFileName
    If pLocalFileName <> "" Then LocalFileName = pLocalFileName

    If RemoteFileName = "" Or LocalFileName = "" Then
    RaiseEvent Error(101, "Remote and Local Filenames may not be blank.")
    Exit Sub
    End If

    If pSize <= 0 Then
    RaiseEvent Error(103, "Buffer Size must be greater than zero (0).")
    Exit Sub
    End If

    nFileHandle = FreeFile

    hFile = FtpOpenFile(mhConnection, RemoteFileName, GENERIC_READ, miTransferMode,
    0)
    If hFile = 0 Then
    'raise the error
    RaiseEvent Error(Err.LastDllError, GetMessageText)
    mbCancelAction = False
    Exit Sub
    End If

    Size = pSize

    Data = String(Size, 0)

    Open LocalFileName For Binary Access Write As #nFileHandle

    nLOF = LOF(nFileHandle) + 1

    nRet = InternetReadFile(hFile, Data, Size, Written)

    Sum = Sum + Written

    If Written > 0 And nRet Then
    RaiseEvent TransferStatus(Size, Sum, mbCancelAction)
    End If

    DoEvents

    While Written > 0 And nRet And Not mbCancelAction

    'trim the buffer to match the amount received
    Data = Left(Data, Written)

    Put #nFileHandle, nLOF, Data

    nLOF = nLOF + Written

    Data = String(Size, 0)
    nRet = InternetReadFile(hFile, Data, Size, Written)
    Sum = Sum + Written
    If nRet = False Then
    'raise the error
    RaiseEvent Error(Err.LastDllError, GetMessageText)
    Written = 0
    Else
    If Written > 0 Then
    'send the messages received
    RaiseEvent TransferStatus(Size, Sum, mbCancelAction)
    End If
    End If
    DoEvents
    Wend

    Close #nFileHandle

    InternetCloseHandle (hFile)

    mbCancelAction = False

    RaiseEvent TransferComplete

    End Sub

    "Julian Milano" <julian@viviannes-collection.com.au> wrote:
    >
    >Hello all,
    >
    >At the end of this email, I have appended the code in question.
    >
    >Q. I got this code from a VB app and converted it to VBA for XL2K. The
    >workings are the same, tho.
    >
    >I need to know if an FTP transfer is taking too long or keep an eye on the
    >number of bytes per second to determine an FTP connection that has gone

    bad.
    >Has anyone any idea on how to achieve this?
    >
    >One of the code lines in question is:
    >
    > bRet = FtpGetFile(hConnection, szFileRemote, szFileLocal & "/" &
    >szFileRemote, False, _
    > INTERNET_FLAG_RELOAD, dwType, 0)
    >
    >in the procedure cmdGet_Click().
    >
    >
    >Form Code (fmVBFTPNHDS):
    >============
    >
    >Dim bActiveSession As Boolean
    >Dim hOpen As Long, hConnection As Long
    >Dim dwType As Long
    >
    >Dim EnumItemNameBag As New Collection
    >Dim EnumItemAttributeBag As New Collection
    >
    >Private Sub Form_Load()
    > bActiveSession = False
    > hOpen = 0
    > hConnection = 0
    > chkPassive.Value = 1
    > optBin.Value = 1
    > dwType = FTP_TRANSFER_TYPE_BINARY
    > Dim imgI As ListImage
    > Set imgI = ImageList1.ListImages.Add(, "open", LoadPicture("open.bmp"))
    > Set imgI = ImageList1.ListImages.Add(, "closed",
    >LoadPicture("closed.bmp"))
    > Set imgI = ImageList1.ListImages.Add(, "leaf", LoadPicture("leaf.bmp"))
    > Set imgI = ImageList1.ListImages.Add(, "root", LoadPicture("root.bmp"))
    > TreeView1.ImageList = ImageList1
    > TreeView1.Style = tvwTreelinesPictureText
    > EnableUI (False)
    >End Sub
    >
    >Private Sub Form_Unload(Cancel As Integer)
    > cmdClosehOpen_Click
    >End Sub
    >
    >Private Sub cmdInternetOpen_Click()
    > If Len(txtProxy.Text) <> 0 Then
    > hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PROXY,
    >txtProxy.Text, vbNullString, 0)
    > Else
    > hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT,
    >vbNullString, vbNullString, 0)
    > End If
    > If hOpen = 0 Then ErrorOut Err.LastDllError, "InternetOpen"
    > EnableUI (True)
    >End Sub
    >
    >Private Sub cmdClosehOpen_Click()
    > If hConnection <> 0 Then InternetCloseHandle (hConnection)
    > If hOpen <> 0 Then InternetCloseHandle (hOpen)
    > hConnection = 0
    > hOpen = 0
    > If bActiveSession Then TreeView1.Nodes.Remove txtServer.Text
    > bActiveSession = False
    > ClearTextBoxAndBag
    > EnableUI (False)
    > txtFTPAddress.Text = "FTP Server Address: <None>"
    >End Sub
    >
    >Private Sub cmdConnect_Click()
    > If Not bActiveSession And hOpen <> 0 Then
    > If txtServer.Text = "" Then
    > MsgBox "Please enter a server name!"
    > Exit Sub
    > End If
    > Dim nFlag As Long
    > If chkPassive.Value Then
    > nFlag = INTERNET_FLAG_PASSIVE
    > Else
    > nFlag = 0
    > End If
    > hConnection = InternetConnect(hOpen, txtServer.Text,
    >INTERNET_INVALID_PORT_NUMBER, _
    > txtUser, txtPassword, INTERNET_SERVICE_FTP, nFlag, 0)
    > If hConnection = 0 Then
    > bActiveSession = False
    > ErrorOut Err.LastDllError, "InternetConnect"
    > Else
    > txtFTPAddress.Text = "Server Address: " & txtServer.Text
    > bActiveSession = True
    > EnableUI (CBool(hOpen))
    > FillTreeViewControl (txtServer.Text)
    > FtpEnumDirectory ("")
    > If EnumItemNameBag.Count = 0 Then Exit Sub
    > FillTreeViewControl (txtServer.Text)
    > End If
    > End If
    >End Sub
    >
    >Private Sub cmdDisconnect_Click()
    > bDirEmpty = True
    > If hConnection <> 0 Then InternetCloseHandle hConnection
    > hConnection = 0
    > ClearBag
    > TreeView1.Nodes.Remove txtServer.Text
    > bActiveSession = False
    > EnableUI (True)
    > txtFTPAddress.Text = "FTP Server Address: <None>"
    >End Sub
    >
    >Private Sub ClearTextBoxAndBag()
    > txtServer.Text = ""
    > txtUser.Text = ""
    > txtPassword.Text = ""
    > txtProxy.Text = ""
    > ClearBag
    >End Sub
    >
    >Private Sub ClearBag()
    > Dim Num As Integer
    > For Num = 1 To EnumItemNameBag.Count
    > EnumItemNameBag.Remove 1
    > Next Num
    > For Num = 1 To EnumItemAttributeBag.Count
    > EnumItemAttributeBag.Remove 1
    > Next Num
    >End Sub
    >
    >Private Sub FillTreeViewControl(strParentKey As String)
    > Dim nodX As Node
    > Dim strImg As String
    > Dim nCount As Integer, i As Integer
    > Dim nAttr As Integer
    > Dim strItem As String
    >
    > If EnumItemNameBag.Count = 0 And strParentKey = txtServer.Text Then
    > Set nodX = TreeView1.Nodes.Add(, tvwFirst, txtServer.Text,
    >txtServer.Text, "root")
    > Exit Sub
    > End If
    > nCount = EnumItemAttributeBag.Count
    > If nCount = 0 Then Exit Sub
    > For i = 1 To nCount
    > nAttr = EnumItemAttributeBag.Item(i)
    > strItem = EnumItemNameBag(i)
    > If nAttr = FILE_ATTRIBUTE_DIRECTORY Then
    > strImg = "closed"
    > Else
    > strImg = "leaf"
    > End If
    > Set nodX = TreeView1.Nodes.Add(strParentKey, tvwChild, strParentKey
    >& "/" & strItem, _
    > strParentKey & "/" & strItem, strImg)
    > Next
    > nodX.EnsureVisible
    >End Sub
    >
    >Private Sub cmdGet_Click()
    > Dim bRet As Boolean
    > Dim szFileRemote As String, szDirRemote As String, szFileLocal As String
    > Dim szTempString As String
    > Dim nPos As Long, nTemp As Long
    > Dim nodX As Node
    > Set nodX = TreeView1.SelectedItem
    > If bActiveSession Then
    > If nodX Is Nothing Then
    > MsgBox "Please select the item to GET!"
    > Exit Sub
    > End If
    > szTempString = TreeView1.SelectedItem.Text
    > szFileRemote = szTempString
    > nPos = 0
    > nTemp = 0
    > Do
    > nTemp = InStr(1, szTempString, "/", vbBinaryCompare)
    > If nTemp = 0 Then Exit Do
    > szTempString = Right(szTempString, Len(szTempString) - nTemp)
    > nPos = nTemp + nPos
    > Loop
    > szDirRemote = Left(szFileRemote, nPos)
    > szFileRemote = Right(szFileRemote, Len(szFileRemote) - nPos)
    > szFileLocal = File1.Path
    > rcd szDirRemote
    > bRet = FtpGetFile(hConnection, szFileRemote, szFileLocal & "/" &
    >szFileRemote, False, _
    > INTERNET_FLAG_RELOAD, dwType, 0)
    > File1.Refresh
    > If bRet = False Then ErrorOut Err.LastDllError, "FtpGetFile"
    > Else
    > MsgBox "Not in session"
    > End If
    >End Sub
    >
    >Private Sub cmdPut_Click()
    > Dim bRet As Boolean
    > Dim szFileRemote As String, szDirRemote As String, szFileLocal As String
    > Dim szTempString As String
    > Dim nPos As Long, nTemp As Long
    > Dim nodX As Node
    > Set nodX = TreeView1.SelectedItem
    >
    > If bActiveSession Then
    > If nodX Is Nothing Then
    > MsgBox "Please select a remote directory to PUT to!"
    > Exit Sub
    > End If
    > If nodX.Image = "leaf" Then
    > MsgBox "Please select a remote directory to PUT to!"
    > Exit Sub
    > End If
    > If File1.filename = "" Then
    > MsgBox "Please select a local file to put"
    > Exit Sub
    > End If
    > szTempString = nodX.Text
    > szDirRemote = Right(szTempString, Len(szTempString) -
    >Len(txtServer.Text))
    > szFileRemote = File1.filename
    > szFileLocal = File1.Path & "\" & File1.filename
    > If (szDirRemote = "") Then szDirRemote = "\"
    > rcd szDirRemote
    >
    > bRet = FtpPutFile(hConnection, szFileLocal, szFileRemote, _
    > dwType, 0)
    > If bRet = False Then
    > ErrorOut Err.LastDllError, "FtpPutFile"
    > Exit Sub
    > End If
    >
    > Dim nodChild As Node, nodNextChild As Node
    > Set nodChild = nodX.Child
    > Do
    > If nodChild Is Nothing Then Exit Do
    > Set nodNextChild = nodChild.Next
    > TreeView1.Nodes.Remove nodChild.Index
    > If nodNextChild Is Nothing Then Exit Do
    > Set nodChild = nodNextChild
    > Loop
    > If nodX.Image = "closed" Then
    > nodX.Image = "open"
    > End If
    > FtpEnumDirectory (nodX.Text)
    > FillTreeViewControl (nodX.Text)
    > End If
    >End Sub
    >
    >Private Sub Dir1_Change()
    > File1.Path = Dir1.Path
    >End Sub
    >
    >Private Sub Drive1_Change()
    > On Error GoTo ErrProc
    > Dir1.Path = Drive1.Drive
    > Exit Sub
    >ErrProc:
    > Drive1.Drive = "c:"
    > Dir1.Path = Drive1.Drive
    >End Sub
    >
    >Private Sub rcd(pszDir As String)
    > If pszDir = "" Then
    > MsgBox "Please enter the directory to CD"
    > Exit Sub
    > Else
    > Dim sPathFromRoot As String
    > Dim bRet As Boolean
    > If InStr(1, pszDir, txtServer.Text) Then
    > sPathFromRoot = Mid(pszDir, Len(txtServer.Text) + 1, Len(pszDir)
    >-
    >Len(txtServer.Text))
    > Else
    > sPathFromRoot = pszDir
    > End If
    > If sPathFromRoot = "" Then sPathFromRoot = "/"
    > bRet = FtpSetCurrentDirectory(hConnection, sPathFromRoot)
    > If bRet = False Then ErrorOut Err.LastDllError, "rcd"
    > End If
    >End Sub
    >
    >Function ErrorOut(dError As Long, szCallFunction As String)
    > Dim dwIntError As Long, dwLength As Long
    > Dim strBuffer As String
    > If dError = ERROR_INTERNET_EXTENDED_ERROR Then
    > InternetGetLastResponseInfo dwIntError, vbNullString, dwLength
    > strBuffer = String(dwLength + 1, 0)
    > InternetGetLastResponseInfo dwIntError, strBuffer, dwLength
    >
    > MsgBox szCallFunction & " Extd Err: " & dwIntError & " " & strBuffer
    > End If
    > If MsgBox(szCallFunction & " Err: " & dError & _
    > vbCrLf & "Close Connection and Session?", vbYesNo) = vbYes Then
    > If hConnection Then InternetCloseHandle hConnection
    > If hOpen Then InternetCloseHandle hOpen
    > hConnection = 0
    > hOpen = 0
    > If bActiveSession Then TreeView1.Nodes.Remove txtServer.Text
    > bActiveSession = False
    > ClearTextBoxAndBag
    > EnableUI (False)
    > End If
    >End Function
    >
    >Private Sub EnableUI(bEnabled As Boolean)
    > txtServer.Enabled = bEnabled
    > txtUser.Enabled = bEnabled
    > txtPassword.Enabled = bEnabled
    > cmdConnect.Enabled = bEnabled And Not bActiveSession
    > cmdDisconnect.Enabled = bEnabled And bActiveSession
    > chkPassive.Enabled = bEnabled
    > cmdClosehOpen.Enabled = bEnabled
    > cmdInternetOpen.Enabled = Not bEnabled
    > txtProxy.Enabled = Not bEnabled
    > optBin.Enabled = bEnabled
    > optAscii.Enabled = bEnabled
    > cmdGet.Enabled = bEnabled And bActiveSession
    > cmdPut.Enabled = bEnabled And bActiveSession
    >End Sub
    >
    >Private Sub FtpEnumDirectory(strDirectory As String)
    >
    > ClearBag
    > Dim hFind As Long
    > Dim nLastError As Long
    > Dim dError As Long
    > Dim ptr As Long
    > Dim pData As WIN32_FIND_DATA
    >
    > If Len(strDirectory) > 0 Then rcd (strDirectory)
    > pData.cFileName = String(MAX_PATH, 0)
    > hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
    > nLastError = Err.LastDllError
    >
    > If hFind = 0 Then
    > If (nLastError = ERROR_NO_MORE_FILES) Then
    > MsgBox "This directory is empty!"
    > Else
    > ErrorOut nLastError, "FtpFindFirstFile"
    > End If
    > Exit Sub
    > End If
    >
    > dError = NO_ERROR
    > Dim bRet As Boolean
    > Dim strItemName As String
    >
    > EnumItemAttributeBag.Add pData.dwFileAttributes
    > strItemName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1,
    >0), vbBinaryCompare) - 1)
    > EnumItemNameBag.Add strItemName
    > Do
    > pData.cFileName = String(MAX_PATH, 0)
    > bRet = InternetFindNextFile(hFind, pData)
    > If Not bRet Then
    > dError = Err.LastDllError
    > If dError = ERROR_NO_MORE_FILES Then
    > Exit Do
    > Else
    > ErrorOut dError, "InternetFindNextFile"
    > InternetCloseHandle (hFind)
    > Exit Sub
    > End If
    > Else
    > EnumItemAttributeBag.Add pData.dwFileAttributes
    > strItemName = Left(pData.cFileName, InStr(1, pData.cFileName,
    >String(1, 0), vbBinaryCompare) - 1)
    > EnumItemNameBag.Add strItemName
    > End If
    > Loop
    >
    > InternetCloseHandle (hFind)
    >End Sub
    >
    >
    >Private Sub optAscii_Click()
    > dwType = FTP_TRANSFER_TYPE_ASCII
    >End Sub
    >
    >Private Sub optBin_Click()
    > dwType = FTP_TRANSFER_TYPE_BINARY
    >End Sub
    >
    >Private Sub TreeView1_DblClick()
    > Dim nodX As Node
    > Set nodX = TreeView1.SelectedItem
    > If Not bActiveSession Then
    > MsgBox "No in session!"
    > Exit Sub
    > End If
    > If nodX Is Nothing Then
    > MsgBox "no Selection to enumerate"
    > End If
    > If nodX.Image = "closed" Then
    > nodX.Image = "open"
    > FtpEnumDirectory (nodX.Text)
    > FillTreeViewControl (nodX.Text)
    > Else
    > If nodX.Image = "open" Then
    > nodX.Image = "closed"
    > Dim nodChild As Node, nodNextChild As Node
    > Set nodChild = nodX.Child
    > Do
    > Set nodNextChild = nodChild.Next
    > TreeView1.Nodes.Remove nodChild.Index
    > If nodNextChild Is Nothing Then Exit Do
    > Set nodChild = nodNextChild
    > Loop
    > End If
    > End If
    >End Sub
    >
    >Class Code (modWinInet):
    >====================
    >
    >Option Explicit
    >
    >Declare Function GetProcessHeap Lib "kernel32" () As Long
    >Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal
    >dwFlags As Long, ByVal dwBytes As Long) As Long
    >Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags
    >As Long, lpMem As Any) As Long
    >Public Const HEAP_ZERO_MEMORY = &H8
    >Public Const HEAP_GENERATE_EXCEPTIONS = &H4
    >
    >Declare Sub CopyMemory1 Lib "kernel32" Alias "RtlMoveMemory" ( _
    > hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
    >Declare Sub CopyMemory2 Lib "kernel32" Alias "RtlMoveMemory" ( _
    > hpvDest As Long, hpvSource As Any, ByVal cbCopy As Long)
    >
    >Public Const MAX_PATH = 260
    >Public Const NO_ERROR = 0
    >Public Const FILE_ATTRIBUTE_READONLY = &H1
    >Public Const FILE_ATTRIBUTE_HIDDEN = &H2
    >Public Const FILE_ATTRIBUTE_SYSTEM = &H4
    >Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
    >Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
    >Public Const FILE_ATTRIBUTE_NORMAL = &H80
    >Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
    >Public Const FILE_ATTRIBUTE_COMPRESSED = &H800
    >Public Const FILE_ATTRIBUTE_OFFLINE = &H1000
    >
    >
    >Type FILETIME
    > dwLowDateTime As Long
    > dwHighDateTime As Long
    >End Type
    >
    >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
    >
    >
    >Public Const ERROR_NO_MORE_FILES = 18
    >
    >Public Declare Function InternetFindNextFile Lib "wininet.dll" Alias
    >"InternetFindNextFileA" _
    > (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
    >
    >Public Declare Function FtpFindFirstFile Lib "wininet.dll" Alias
    >"FtpFindFirstFileA" _
    >(ByVal hFtpSession As Long, ByVal lpszSearchFile As String, _
    > lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal
    >dwContent As Long) As Long
    >
    >Public 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
    >
    >Public Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA"
    >_
    >(ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
    > ByVal lpszRemoteFile As String, _
    > ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
    >
    >Public Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias
    >"FtpSetCurrentDirectoryA" _
    > (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
    >' Initializes an application's use of the Win32 Internet functions
    >Public 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
    >
    >' User agent constant.
    >Public Const scUserAgent = "vb wininet"
    >
    >' Use registry access settings.
    >Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0
    >Public Const INTERNET_OPEN_TYPE_DIRECT = 1
    >Public Const INTERNET_OPEN_TYPE_PROXY = 3
    >Public Const INTERNET_INVALID_PORT_NUMBER = 0
    >
    >Public Const FTP_TRANSFER_TYPE_BINARY = &H2
    >Public Const FTP_TRANSFER_TYPE_ASCII = &H1
    >Public Const INTERNET_FLAG_PASSIVE = &H8000000
    >
    >' Opens a HTTP session for a given site.
    >Public 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
    >
    >Public Const ERROR_INTERNET_EXTENDED_ERROR = 12003
    >Public Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias
    >"InternetGetLastResponseInfoA" ( _
    > lpdwError As Long, _
    > ByVal lpszBuffer As String, _
    > lpdwBufferLength As Long) As Boolean
    >
    >' Number of the TCP/IP port on the server to connect to.
    >Public Const INTERNET_DEFAULT_FTP_PORT = 21
    >Public Const INTERNET_DEFAULT_GOPHER_PORT = 70
    >Public Const INTERNET_DEFAULT_HTTP_PORT = 80
    >Public Const INTERNET_DEFAULT_HTTPS_PORT = 443
    >Public Const INTERNET_DEFAULT_SOCKS_PORT = 1080
    >
    >Public Const INTERNET_OPTION_CONNECT_TIMEOUT = 2
    >Public Const INTERNET_OPTION_RECEIVE_TIMEOUT = 6
    >Public Const INTERNET_OPTION_SEND_TIMEOUT = 5
    >
    >Public Const INTERNET_OPTION_USERNAME = 28
    >Public Const INTERNET_OPTION_PASSWORD = 29
    >Public Const INTERNET_OPTION_PROXY_USERNAME = 43
    >Public Const INTERNET_OPTION_PROXY_PASSWORD = 44
    >
    >' Type of service to access.
    >Public Const INTERNET_SERVICE_FTP = 1
    >Public Const INTERNET_SERVICE_GOPHER = 2
    >Public Const INTERNET_SERVICE_HTTP = 3
    >
    >' Opens an HTTP request handle.
    >Public Declare Function HttpOpenRequest Lib "wininet.dll" Alias
    >"HttpOpenRequestA" _
    >(ByVal hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As
    >String, ByVal sVersion As String, _
    >ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long,
    >ByVal lContext As Long) As Long
    >
    >' Brings the data across the wire even if it locally cached.
    >Public Const INTERNET_FLAG_RELOAD = &H80000000
    >Public Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
    >Public Const INTERNET_FLAG_MULTIPART = &H200000
    >
    >Public Const GENERIC_READ = &H80000000
    >Public Const GENERIC_WRITE = &H40000000
    >
    >' Sends the specified request to the HTTP server.
    >Public Declare Function HttpSendRequest Lib "wininet.dll" Alias
    >"HttpSendRequestA" (ByVal _
    >hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As
    >Long, ByVal sOptional As _
    >String, ByVal lOptionalLength As Long) As Integer
    >
    >
    >' Queries for information about an HTTP request.
    >Public Declare Function HttpQueryInfo Lib "wininet.dll" Alias
    >"HttpQueryInfoA" _
    >(ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As

    Any,
    >_
    >ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer
    >
    >' The possible values for the lInfoLevel parameter include:
    >Public Const HTTP_QUERY_CONTENT_TYPE = 1
    >Public Const HTTP_QUERY_CONTENT_LENGTH = 5
    >Public Const HTTP_QUERY_EXPIRES = 10
    >Public Const HTTP_QUERY_LAST_MODIFIED = 11
    >Public Const HTTP_QUERY_PRAGMA = 17
    >Public Const HTTP_QUERY_VERSION = 18
    >Public Const HTTP_QUERY_STATUS_CODE = 19
    >Public Const HTTP_QUERY_STATUS_TEXT = 20
    >Public Const HTTP_QUERY_RAW_HEADERS = 21
    >Public Const HTTP_QUERY_RAW_HEADERS_CRLF = 22
    >Public Const HTTP_QUERY_FORWARDED = 30
    >Public Const HTTP_QUERY_SERVER = 37
    >Public Const HTTP_QUERY_USER_AGENT = 39
    >Public Const HTTP_QUERY_SET_COOKIE = 43
    >Public Const HTTP_QUERY_REQUEST_METHOD = 45
    >Public Const HTTP_STATUS_DENIED = 401
    >Public Const HTTP_STATUS_PROXY_AUTH_REQ = 407
    >
    >' Add this flag to the about flags to get request header.
    >Public Const HTTP_QUERY_FLAG_REQUEST_HEADERS = &H80000000
    >Public Const HTTP_QUERY_FLAG_NUMBER = &H20000000
    >' Reads data from a handle opened by the HttpOpenRequest function.
    >Public Declare Function InternetReadFile Lib "wininet.dll" _
    >(ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As
    >Long, _
    >lNumberOfBytesRead As Long) As Integer
    >
    >Public Declare Function InternetWriteFile Lib "wininet.dll" _
    > (ByVal hFile As Long, ByVal sBuffer As String, _
    > ByVal lNumberOfBytesToRead As Long, _
    > lNumberOfBytesRead As Long) As Integer
    >
    >Public Declare Function FtpOpenFile Lib "wininet.dll" Alias _
    > "FtpOpenFileA" (ByVal hFtpSession As Long, _
    > ByVal sFileName As String, ByVal lAccess As Long, _
    > ByVal lFlags As Long, ByVal lContext As Long) As Long
    >Public Declare Function FtpDeleteFile Lib "wininet.dll" _
    > Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, _
    > ByVal lpszFileName As String) As Boolean
    >Public Declare Function InternetSetOption Lib "wininet.dll" Alias
    >"InternetSetOptionA" _
    >(ByVal hInternet As Long, ByVal lOption As Long, ByRef sBuffer As Any, ByVal
    >lBufferLength As Long) As Integer
    >Public Declare Function InternetSetOptionStr Lib "wininet.dll" Alias
    >"InternetSetOptionA" _
    >(ByVal hInternet As Long, ByVal lOption As Long, ByVal sBuffer As String,
    >ByVal lBufferLength As Long) As Integer
    >
    >' Closes a single Internet handle or a subtree of Internet handles.
    >Public Declare Function InternetCloseHandle Lib "wininet.dll" _
    >(ByVal hInet As Long) As Integer
    >
    >' Queries an Internet option on the specified handle
    >Public Declare Function InternetQueryOption Lib "wininet.dll" Alias
    >"InternetQueryOptionA" _
    >(ByVal hInternet As Long, ByVal lOption As Long, ByRef sBuffer As Any, ByRef
    >lBufferLength As Long) As Integer
    >
    >' Returns the version number of Wininet.dll.
    >Public Const INTERNET_OPTION_VERSION = 40
    >
    >' Contains the version number of the DLL that contains the Windows Internet
    >' functions (Wininet.dll). This structure is used when passing the
    >' INTERNET_OPTION_VERSION flag to the InternetQueryOption function.
    >Public Type tWinInetDLLVersion
    > lMajorVersion As Long
    > lMinorVersion As Long
    >End Type
    >
    >' Adds one or more HTTP request headers to the HTTP request handle.
    >Public Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias
    >"HttpAddRequestHeadersA" _
    >(ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength
    >As Long, _
    >ByVal lModifiers As Long) As Integer
    >
    >' Flags to modify the semantics of this function. Can be a combination of
    >these values:
    >
    >' Adds the header only if it does not already exist; otherwise, an error
    >is
    >returned.
    >Public Const HTTP_ADDREQ_FLAG_ADD_IF_NEW = &H10000000
    >
    >' Adds the header if it does not exist. Used with REPLACE.
    >Public Const HTTP_ADDREQ_FLAG_ADD = &H20000000
    >
    >' Replaces or removes a header. If the header value is empty and the header
    >is found,
    >' it is removed. If not empty, the header value is replaced
    >Public Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000
    >
    >--
    >
    >-Julian Milano
    >
    >
    >
    >



  3. #3
    Cody Laird Guest

    Re: How do I detect an FTP timeout?


    Julian:

    Here is an example using the InternetReadFile API call that defaults to reading
    1000 byte chunks of the file and raises a simple event each time and when
    completed. Its not perfect, but it will get you started...

    Cody

    'use your declarations and add these if not already defined...
    Public Declare Function FtpOpenFile Lib "wininet.dll" Alias _
    "FtpOpenFileA" (ByVal hFtpSession As Long, _
    ByVal sFilename As String, ByVal lAccess As Long, _
    ByVal lFlags As Long, ByVal lContext As Long) As Long

    Public Declare Function InternetReadFile Lib "wininet.dll" _
    (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long,
    _
    lNumberOfBytesRead As Long) As Integer

    Public Sub GetFileByChunk(Optional pSize As Long = 1000, Optional pRemoteFileName
    As String = "", Optional pLocalFileName As String)
    Dim nRet As Integer
    Dim nFileHandle As Integer
    Dim Data As String
    Dim Written As Long
    Dim Size As Long
    Dim Sum As Long
    Dim hFile As Long
    Dim nLOF As Long

    On Error Resume Next

    mbCancelAction = False

    If pRemoteFileName <> "" Then RemoteFileName = pRemoteFileName
    If pLocalFileName <> "" Then LocalFileName = pLocalFileName

    If RemoteFileName = "" Or LocalFileName = "" Then
    RaiseEvent Error(101, "Remote and Local Filenames may not be blank.")
    Exit Sub
    End If

    If pSize <= 0 Then
    RaiseEvent Error(103, "Buffer Size must be greater than zero (0).")
    Exit Sub
    End If

    nFileHandle = FreeFile

    hFile = FtpOpenFile(mhConnection, RemoteFileName, GENERIC_READ, miTransferMode,
    0)
    If hFile = 0 Then
    'raise the error
    RaiseEvent Error(Err.LastDllError, GetMessageText)
    mbCancelAction = False
    Exit Sub
    End If

    Size = pSize

    Data = String(Size, 0)

    Open LocalFileName For Binary Access Write As #nFileHandle

    nLOF = LOF(nFileHandle) + 1

    nRet = InternetReadFile(hFile, Data, Size, Written)

    Sum = Sum + Written

    If Written > 0 And nRet Then
    RaiseEvent TransferStatus(Size, Sum, mbCancelAction)
    End If

    DoEvents

    While Written > 0 And nRet And Not mbCancelAction

    'trim the buffer to match the amount received
    Data = Left(Data, Written)

    Put #nFileHandle, nLOF, Data

    nLOF = nLOF + Written

    Data = String(Size, 0)
    nRet = InternetReadFile(hFile, Data, Size, Written)
    Sum = Sum + Written
    If nRet = False Then
    'raise the error
    RaiseEvent Error(Err.LastDllError, GetMessageText)
    Written = 0
    Else
    If Written > 0 Then
    'send the messages received
    RaiseEvent TransferStatus(Size, Sum, mbCancelAction)
    End If
    End If
    DoEvents
    Wend

    Close #nFileHandle

    InternetCloseHandle (hFile)

    mbCancelAction = False

    RaiseEvent TransferComplete

    End Sub

    "Julian Milano" <julian@viviannes-collection.com.au> wrote:
    >
    >Hello all,
    >
    >At the end of this email, I have appended the code in question.
    >
    >Q. I got this code from a VB app and converted it to VBA for XL2K. The
    >workings are the same, tho.
    >
    >I need to know if an FTP transfer is taking too long or keep an eye on the
    >number of bytes per second to determine an FTP connection that has gone

    bad.
    >Has anyone any idea on how to achieve this?
    >
    >One of the code lines in question is:
    >
    > bRet = FtpGetFile(hConnection, szFileRemote, szFileLocal & "/" &
    >szFileRemote, False, _
    > INTERNET_FLAG_RELOAD, dwType, 0)
    >
    >in the procedure cmdGet_Click().
    >
    >
    >Form Code (fmVBFTPNHDS):
    >============
    >
    >Dim bActiveSession As Boolean
    >Dim hOpen As Long, hConnection As Long
    >Dim dwType As Long
    >
    >Dim EnumItemNameBag As New Collection
    >Dim EnumItemAttributeBag As New Collection
    >
    >Private Sub Form_Load()
    > bActiveSession = False
    > hOpen = 0
    > hConnection = 0
    > chkPassive.Value = 1
    > optBin.Value = 1
    > dwType = FTP_TRANSFER_TYPE_BINARY
    > Dim imgI As ListImage
    > Set imgI = ImageList1.ListImages.Add(, "open", LoadPicture("open.bmp"))
    > Set imgI = ImageList1.ListImages.Add(, "closed",
    >LoadPicture("closed.bmp"))
    > Set imgI = ImageList1.ListImages.Add(, "leaf", LoadPicture("leaf.bmp"))
    > Set imgI = ImageList1.ListImages.Add(, "root", LoadPicture("root.bmp"))
    > TreeView1.ImageList = ImageList1
    > TreeView1.Style = tvwTreelinesPictureText
    > EnableUI (False)
    >End Sub
    >
    >Private Sub Form_Unload(Cancel As Integer)
    > cmdClosehOpen_Click
    >End Sub
    >
    >Private Sub cmdInternetOpen_Click()
    > If Len(txtProxy.Text) <> 0 Then
    > hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PROXY,
    >txtProxy.Text, vbNullString, 0)
    > Else
    > hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT,
    >vbNullString, vbNullString, 0)
    > End If
    > If hOpen = 0 Then ErrorOut Err.LastDllError, "InternetOpen"
    > EnableUI (True)
    >End Sub
    >
    >Private Sub cmdClosehOpen_Click()
    > If hConnection <> 0 Then InternetCloseHandle (hConnection)
    > If hOpen <> 0 Then InternetCloseHandle (hOpen)
    > hConnection = 0
    > hOpen = 0
    > If bActiveSession Then TreeView1.Nodes.Remove txtServer.Text
    > bActiveSession = False
    > ClearTextBoxAndBag
    > EnableUI (False)
    > txtFTPAddress.Text = "FTP Server Address: <None>"
    >End Sub
    >
    >Private Sub cmdConnect_Click()
    > If Not bActiveSession And hOpen <> 0 Then
    > If txtServer.Text = "" Then
    > MsgBox "Please enter a server name!"
    > Exit Sub
    > End If
    > Dim nFlag As Long
    > If chkPassive.Value Then
    > nFlag = INTERNET_FLAG_PASSIVE
    > Else
    > nFlag = 0
    > End If
    > hConnection = InternetConnect(hOpen, txtServer.Text,
    >INTERNET_INVALID_PORT_NUMBER, _
    > txtUser, txtPassword, INTERNET_SERVICE_FTP, nFlag, 0)
    > If hConnection = 0 Then
    > bActiveSession = False
    > ErrorOut Err.LastDllError, "InternetConnect"
    > Else
    > txtFTPAddress.Text = "Server Address: " & txtServer.Text
    > bActiveSession = True
    > EnableUI (CBool(hOpen))
    > FillTreeViewControl (txtServer.Text)
    > FtpEnumDirectory ("")
    > If EnumItemNameBag.Count = 0 Then Exit Sub
    > FillTreeViewControl (txtServer.Text)
    > End If
    > End If
    >End Sub
    >
    >Private Sub cmdDisconnect_Click()
    > bDirEmpty = True
    > If hConnection <> 0 Then InternetCloseHandle hConnection
    > hConnection = 0
    > ClearBag
    > TreeView1.Nodes.Remove txtServer.Text
    > bActiveSession = False
    > EnableUI (True)
    > txtFTPAddress.Text = "FTP Server Address: <None>"
    >End Sub
    >
    >Private Sub ClearTextBoxAndBag()
    > txtServer.Text = ""
    > txtUser.Text = ""
    > txtPassword.Text = ""
    > txtProxy.Text = ""
    > ClearBag
    >End Sub
    >
    >Private Sub ClearBag()
    > Dim Num As Integer
    > For Num = 1 To EnumItemNameBag.Count
    > EnumItemNameBag.Remove 1
    > Next Num
    > For Num = 1 To EnumItemAttributeBag.Count
    > EnumItemAttributeBag.Remove 1
    > Next Num
    >End Sub
    >
    >Private Sub FillTreeViewControl(strParentKey As String)
    > Dim nodX As Node
    > Dim strImg As String
    > Dim nCount As Integer, i As Integer
    > Dim nAttr As Integer
    > Dim strItem As String
    >
    > If EnumItemNameBag.Count = 0 And strParentKey = txtServer.Text Then
    > Set nodX = TreeView1.Nodes.Add(, tvwFirst, txtServer.Text,
    >txtServer.Text, "root")
    > Exit Sub
    > End If
    > nCount = EnumItemAttributeBag.Count
    > If nCount = 0 Then Exit Sub
    > For i = 1 To nCount
    > nAttr = EnumItemAttributeBag.Item(i)
    > strItem = EnumItemNameBag(i)
    > If nAttr = FILE_ATTRIBUTE_DIRECTORY Then
    > strImg = "closed"
    > Else
    > strImg = "leaf"
    > End If
    > Set nodX = TreeView1.Nodes.Add(strParentKey, tvwChild, strParentKey
    >& "/" & strItem, _
    > strParentKey & "/" & strItem, strImg)
    > Next
    > nodX.EnsureVisible
    >End Sub
    >
    >Private Sub cmdGet_Click()
    > Dim bRet As Boolean
    > Dim szFileRemote As String, szDirRemote As String, szFileLocal As String
    > Dim szTempString As String
    > Dim nPos As Long, nTemp As Long
    > Dim nodX As Node
    > Set nodX = TreeView1.SelectedItem
    > If bActiveSession Then
    > If nodX Is Nothing Then
    > MsgBox "Please select the item to GET!"
    > Exit Sub
    > End If
    > szTempString = TreeView1.SelectedItem.Text
    > szFileRemote = szTempString
    > nPos = 0
    > nTemp = 0
    > Do
    > nTemp = InStr(1, szTempString, "/", vbBinaryCompare)
    > If nTemp = 0 Then Exit Do
    > szTempString = Right(szTempString, Len(szTempString) - nTemp)
    > nPos = nTemp + nPos
    > Loop
    > szDirRemote = Left(szFileRemote, nPos)
    > szFileRemote = Right(szFileRemote, Len(szFileRemote) - nPos)
    > szFileLocal = File1.Path
    > rcd szDirRemote
    > bRet = FtpGetFile(hConnection, szFileRemote, szFileLocal & "/" &
    >szFileRemote, False, _
    > INTERNET_FLAG_RELOAD, dwType, 0)
    > File1.Refresh
    > If bRet = False Then ErrorOut Err.LastDllError, "FtpGetFile"
    > Else
    > MsgBox "Not in session"
    > End If
    >End Sub
    >
    >Private Sub cmdPut_Click()
    > Dim bRet As Boolean
    > Dim szFileRemote As String, szDirRemote As String, szFileLocal As String
    > Dim szTempString As String
    > Dim nPos As Long, nTemp As Long
    > Dim nodX As Node
    > Set nodX = TreeView1.SelectedItem
    >
    > If bActiveSession Then
    > If nodX Is Nothing Then
    > MsgBox "Please select a remote directory to PUT to!"
    > Exit Sub
    > End If
    > If nodX.Image = "leaf" Then
    > MsgBox "Please select a remote directory to PUT to!"
    > Exit Sub
    > End If
    > If File1.filename = "" Then
    > MsgBox "Please select a local file to put"
    > Exit Sub
    > End If
    > szTempString = nodX.Text
    > szDirRemote = Right(szTempString, Len(szTempString) -
    >Len(txtServer.Text))
    > szFileRemote = File1.filename
    > szFileLocal = File1.Path & "\" & File1.filename
    > If (szDirRemote = "") Then szDirRemote = "\"
    > rcd szDirRemote
    >
    > bRet = FtpPutFile(hConnection, szFileLocal, szFileRemote, _
    > dwType, 0)
    > If bRet = False Then
    > ErrorOut Err.LastDllError, "FtpPutFile"
    > Exit Sub
    > End If
    >
    > Dim nodChild As Node, nodNextChild As Node
    > Set nodChild = nodX.Child
    > Do
    > If nodChild Is Nothing Then Exit Do
    > Set nodNextChild = nodChild.Next
    > TreeView1.Nodes.Remove nodChild.Index
    > If nodNextChild Is Nothing Then Exit Do
    > Set nodChild = nodNextChild
    > Loop
    > If nodX.Image = "closed" Then
    > nodX.Image = "open"
    > End If
    > FtpEnumDirectory (nodX.Text)
    > FillTreeViewControl (nodX.Text)
    > End If
    >End Sub
    >
    >Private Sub Dir1_Change()
    > File1.Path = Dir1.Path
    >End Sub
    >
    >Private Sub Drive1_Change()
    > On Error GoTo ErrProc
    > Dir1.Path = Drive1.Drive
    > Exit Sub
    >ErrProc:
    > Drive1.Drive = "c:"
    > Dir1.Path = Drive1.Drive
    >End Sub
    >
    >Private Sub rcd(pszDir As String)
    > If pszDir = "" Then
    > MsgBox "Please enter the directory to CD"
    > Exit Sub
    > Else
    > Dim sPathFromRoot As String
    > Dim bRet As Boolean
    > If InStr(1, pszDir, txtServer.Text) Then
    > sPathFromRoot = Mid(pszDir, Len(txtServer.Text) + 1, Len(pszDir)
    >-
    >Len(txtServer.Text))
    > Else
    > sPathFromRoot = pszDir
    > End If
    > If sPathFromRoot = "" Then sPathFromRoot = "/"
    > bRet = FtpSetCurrentDirectory(hConnection, sPathFromRoot)
    > If bRet = False Then ErrorOut Err.LastDllError, "rcd"
    > End If
    >End Sub
    >
    >Function ErrorOut(dError As Long, szCallFunction As String)
    > Dim dwIntError As Long, dwLength As Long
    > Dim strBuffer As String
    > If dError = ERROR_INTERNET_EXTENDED_ERROR Then
    > InternetGetLastResponseInfo dwIntError, vbNullString, dwLength
    > strBuffer = String(dwLength + 1, 0)
    > InternetGetLastResponseInfo dwIntError, strBuffer, dwLength
    >
    > MsgBox szCallFunction & " Extd Err: " & dwIntError & " " & strBuffer
    > End If
    > If MsgBox(szCallFunction & " Err: " & dError & _
    > vbCrLf & "Close Connection and Session?", vbYesNo) = vbYes Then
    > If hConnection Then InternetCloseHandle hConnection
    > If hOpen Then InternetCloseHandle hOpen
    > hConnection = 0
    > hOpen = 0
    > If bActiveSession Then TreeView1.Nodes.Remove txtServer.Text
    > bActiveSession = False
    > ClearTextBoxAndBag
    > EnableUI (False)
    > End If
    >End Function
    >
    >Private Sub EnableUI(bEnabled As Boolean)
    > txtServer.Enabled = bEnabled
    > txtUser.Enabled = bEnabled
    > txtPassword.Enabled = bEnabled
    > cmdConnect.Enabled = bEnabled And Not bActiveSession
    > cmdDisconnect.Enabled = bEnabled And bActiveSession
    > chkPassive.Enabled = bEnabled
    > cmdClosehOpen.Enabled = bEnabled
    > cmdInternetOpen.Enabled = Not bEnabled
    > txtProxy.Enabled = Not bEnabled
    > optBin.Enabled = bEnabled
    > optAscii.Enabled = bEnabled
    > cmdGet.Enabled = bEnabled And bActiveSession
    > cmdPut.Enabled = bEnabled And bActiveSession
    >End Sub
    >
    >Private Sub FtpEnumDirectory(strDirectory As String)
    >
    > ClearBag
    > Dim hFind As Long
    > Dim nLastError As Long
    > Dim dError As Long
    > Dim ptr As Long
    > Dim pData As WIN32_FIND_DATA
    >
    > If Len(strDirectory) > 0 Then rcd (strDirectory)
    > pData.cFileName = String(MAX_PATH, 0)
    > hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
    > nLastError = Err.LastDllError
    >
    > If hFind = 0 Then
    > If (nLastError = ERROR_NO_MORE_FILES) Then
    > MsgBox "This directory is empty!"
    > Else
    > ErrorOut nLastError, "FtpFindFirstFile"
    > End If
    > Exit Sub
    > End If
    >
    > dError = NO_ERROR
    > Dim bRet As Boolean
    > Dim strItemName As String
    >
    > EnumItemAttributeBag.Add pData.dwFileAttributes
    > strItemName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1,
    >0), vbBinaryCompare) - 1)
    > EnumItemNameBag.Add strItemName
    > Do
    > pData.cFileName = String(MAX_PATH, 0)
    > bRet = InternetFindNextFile(hFind, pData)
    > If Not bRet Then
    > dError = Err.LastDllError
    > If dError = ERROR_NO_MORE_FILES Then
    > Exit Do
    > Else
    > ErrorOut dError, "InternetFindNextFile"
    > InternetCloseHandle (hFind)
    > Exit Sub
    > End If
    > Else
    > EnumItemAttributeBag.Add pData.dwFileAttributes
    > strItemName = Left(pData.cFileName, InStr(1, pData.cFileName,
    >String(1, 0), vbBinaryCompare) - 1)
    > EnumItemNameBag.Add strItemName
    > End If
    > Loop
    >
    > InternetCloseHandle (hFind)
    >End Sub
    >
    >
    >Private Sub optAscii_Click()
    > dwType = FTP_TRANSFER_TYPE_ASCII
    >End Sub
    >
    >Private Sub optBin_Click()
    > dwType = FTP_TRANSFER_TYPE_BINARY
    >End Sub
    >
    >Private Sub TreeView1_DblClick()
    > Dim nodX As Node
    > Set nodX = TreeView1.SelectedItem
    > If Not bActiveSession Then
    > MsgBox "No in session!"
    > Exit Sub
    > End If
    > If nodX Is Nothing Then
    > MsgBox "no Selection to enumerate"
    > End If
    > If nodX.Image = "closed" Then
    > nodX.Image = "open"
    > FtpEnumDirectory (nodX.Text)
    > FillTreeViewControl (nodX.Text)
    > Else
    > If nodX.Image = "open" Then
    > nodX.Image = "closed"
    > Dim nodChild As Node, nodNextChild As Node
    > Set nodChild = nodX.Child
    > Do
    > Set nodNextChild = nodChild.Next
    > TreeView1.Nodes.Remove nodChild.Index
    > If nodNextChild Is Nothing Then Exit Do
    > Set nodChild = nodNextChild
    > Loop
    > End If
    > End If
    >End Sub
    >
    >Class Code (modWinInet):
    >====================
    >
    >Option Explicit
    >
    >Declare Function GetProcessHeap Lib "kernel32" () As Long
    >Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal
    >dwFlags As Long, ByVal dwBytes As Long) As Long
    >Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags
    >As Long, lpMem As Any) As Long
    >Public Const HEAP_ZERO_MEMORY = &H8
    >Public Const HEAP_GENERATE_EXCEPTIONS = &H4
    >
    >Declare Sub CopyMemory1 Lib "kernel32" Alias "RtlMoveMemory" ( _
    > hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
    >Declare Sub CopyMemory2 Lib "kernel32" Alias "RtlMoveMemory" ( _
    > hpvDest As Long, hpvSource As Any, ByVal cbCopy As Long)
    >
    >Public Const MAX_PATH = 260
    >Public Const NO_ERROR = 0
    >Public Const FILE_ATTRIBUTE_READONLY = &H1
    >Public Const FILE_ATTRIBUTE_HIDDEN = &H2
    >Public Const FILE_ATTRIBUTE_SYSTEM = &H4
    >Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
    >Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
    >Public Const FILE_ATTRIBUTE_NORMAL = &H80
    >Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
    >Public Const FILE_ATTRIBUTE_COMPRESSED = &H800
    >Public Const FILE_ATTRIBUTE_OFFLINE = &H1000
    >
    >
    >Type FILETIME
    > dwLowDateTime As Long
    > dwHighDateTime As Long
    >End Type
    >
    >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
    >
    >
    >Public Const ERROR_NO_MORE_FILES = 18
    >
    >Public Declare Function InternetFindNextFile Lib "wininet.dll" Alias
    >"InternetFindNextFileA" _
    > (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
    >
    >Public Declare Function FtpFindFirstFile Lib "wininet.dll" Alias
    >"FtpFindFirstFileA" _
    >(ByVal hFtpSession As Long, ByVal lpszSearchFile As String, _
    > lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal
    >dwContent As Long) As Long
    >
    >Public 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
    >
    >Public Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA"
    >_
    >(ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
    > ByVal lpszRemoteFile As String, _
    > ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
    >
    >Public Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias
    >"FtpSetCurrentDirectoryA" _
    > (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
    >' Initializes an application's use of the Win32 Internet functions
    >Public 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
    >
    >' User agent constant.
    >Public Const scUserAgent = "vb wininet"
    >
    >' Use registry access settings.
    >Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0
    >Public Const INTERNET_OPEN_TYPE_DIRECT = 1
    >Public Const INTERNET_OPEN_TYPE_PROXY = 3
    >Public Const INTERNET_INVALID_PORT_NUMBER = 0
    >
    >Public Const FTP_TRANSFER_TYPE_BINARY = &H2
    >Public Const FTP_TRANSFER_TYPE_ASCII = &H1
    >Public Const INTERNET_FLAG_PASSIVE = &H8000000
    >
    >' Opens a HTTP session for a given site.
    >Public 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
    >
    >Public Const ERROR_INTERNET_EXTENDED_ERROR = 12003
    >Public Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias
    >"InternetGetLastResponseInfoA" ( _
    > lpdwError As Long, _
    > ByVal lpszBuffer As String, _
    > lpdwBufferLength As Long) As Boolean
    >
    >' Number of the TCP/IP port on the server to connect to.
    >Public Const INTERNET_DEFAULT_FTP_PORT = 21
    >Public Const INTERNET_DEFAULT_GOPHER_PORT = 70
    >Public Const INTERNET_DEFAULT_HTTP_PORT = 80
    >Public Const INTERNET_DEFAULT_HTTPS_PORT = 443
    >Public Const INTERNET_DEFAULT_SOCKS_PORT = 1080
    >
    >Public Const INTERNET_OPTION_CONNECT_TIMEOUT = 2
    >Public Const INTERNET_OPTION_RECEIVE_TIMEOUT = 6
    >Public Const INTERNET_OPTION_SEND_TIMEOUT = 5
    >
    >Public Const INTERNET_OPTION_USERNAME = 28
    >Public Const INTERNET_OPTION_PASSWORD = 29
    >Public Const INTERNET_OPTION_PROXY_USERNAME = 43
    >Public Const INTERNET_OPTION_PROXY_PASSWORD = 44
    >
    >' Type of service to access.
    >Public Const INTERNET_SERVICE_FTP = 1
    >Public Const INTERNET_SERVICE_GOPHER = 2
    >Public Const INTERNET_SERVICE_HTTP = 3
    >
    >' Opens an HTTP request handle.
    >Public Declare Function HttpOpenRequest Lib "wininet.dll" Alias
    >"HttpOpenRequestA" _
    >(ByVal hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As
    >String, ByVal sVersion As String, _
    >ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long,
    >ByVal lContext As Long) As Long
    >
    >' Brings the data across the wire even if it locally cached.
    >Public Const INTERNET_FLAG_RELOAD = &H80000000
    >Public Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
    >Public Const INTERNET_FLAG_MULTIPART = &H200000
    >
    >Public Const GENERIC_READ = &H80000000
    >Public Const GENERIC_WRITE = &H40000000
    >
    >' Sends the specified request to the HTTP server.
    >Public Declare Function HttpSendRequest Lib "wininet.dll" Alias
    >"HttpSendRequestA" (ByVal _
    >hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As
    >Long, ByVal sOptional As _
    >String, ByVal lOptionalLength As Long) As Integer
    >
    >
    >' Queries for information about an HTTP request.
    >Public Declare Function HttpQueryInfo Lib "wininet.dll" Alias
    >"HttpQueryInfoA" _
    >(ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As

    Any,
    >_
    >ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer
    >
    >' The possible values for the lInfoLevel parameter include:
    >Public Const HTTP_QUERY_CONTENT_TYPE = 1
    >Public Const HTTP_QUERY_CONTENT_LENGTH = 5
    >Public Const HTTP_QUERY_EXPIRES = 10
    >Public Const HTTP_QUERY_LAST_MODIFIED = 11
    >Public Const HTTP_QUERY_PRAGMA = 17
    >Public Const HTTP_QUERY_VERSION = 18
    >Public Const HTTP_QUERY_STATUS_CODE = 19
    >Public Const HTTP_QUERY_STATUS_TEXT = 20
    >Public Const HTTP_QUERY_RAW_HEADERS = 21
    >Public Const HTTP_QUERY_RAW_HEADERS_CRLF = 22
    >Public Const HTTP_QUERY_FORWARDED = 30
    >Public Const HTTP_QUERY_SERVER = 37
    >Public Const HTTP_QUERY_USER_AGENT = 39
    >Public Const HTTP_QUERY_SET_COOKIE = 43
    >Public Const HTTP_QUERY_REQUEST_METHOD = 45
    >Public Const HTTP_STATUS_DENIED = 401
    >Public Const HTTP_STATUS_PROXY_AUTH_REQ = 407
    >
    >' Add this flag to the about flags to get request header.
    >Public Const HTTP_QUERY_FLAG_REQUEST_HEADERS = &H80000000
    >Public Const HTTP_QUERY_FLAG_NUMBER = &H20000000
    >' Reads data from a handle opened by the HttpOpenRequest function.
    >Public Declare Function InternetReadFile Lib "wininet.dll" _
    >(ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As
    >Long, _
    >lNumberOfBytesRead As Long) As Integer
    >
    >Public Declare Function InternetWriteFile Lib "wininet.dll" _
    > (ByVal hFile As Long, ByVal sBuffer As String, _
    > ByVal lNumberOfBytesToRead As Long, _
    > lNumberOfBytesRead As Long) As Integer
    >
    >Public Declare Function FtpOpenFile Lib "wininet.dll" Alias _
    > "FtpOpenFileA" (ByVal hFtpSession As Long, _
    > ByVal sFileName As String, ByVal lAccess As Long, _
    > ByVal lFlags As Long, ByVal lContext As Long) As Long
    >Public Declare Function FtpDeleteFile Lib "wininet.dll" _
    > Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, _
    > ByVal lpszFileName As String) As Boolean
    >Public Declare Function InternetSetOption Lib "wininet.dll" Alias
    >"InternetSetOptionA" _
    >(ByVal hInternet As Long, ByVal lOption As Long, ByRef sBuffer As Any, ByVal
    >lBufferLength As Long) As Integer
    >Public Declare Function InternetSetOptionStr Lib "wininet.dll" Alias
    >"InternetSetOptionA" _
    >(ByVal hInternet As Long, ByVal lOption As Long, ByVal sBuffer As String,
    >ByVal lBufferLength As Long) As Integer
    >
    >' Closes a single Internet handle or a subtree of Internet handles.
    >Public Declare Function InternetCloseHandle Lib "wininet.dll" _
    >(ByVal hInet As Long) As Integer
    >
    >' Queries an Internet option on the specified handle
    >Public Declare Function InternetQueryOption Lib "wininet.dll" Alias
    >"InternetQueryOptionA" _
    >(ByVal hInternet As Long, ByVal lOption As Long, ByRef sBuffer As Any, ByRef
    >lBufferLength As Long) As Integer
    >
    >' Returns the version number of Wininet.dll.
    >Public Const INTERNET_OPTION_VERSION = 40
    >
    >' Contains the version number of the DLL that contains the Windows Internet
    >' functions (Wininet.dll). This structure is used when passing the
    >' INTERNET_OPTION_VERSION flag to the InternetQueryOption function.
    >Public Type tWinInetDLLVersion
    > lMajorVersion As Long
    > lMinorVersion As Long
    >End Type
    >
    >' Adds one or more HTTP request headers to the HTTP request handle.
    >Public Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias
    >"HttpAddRequestHeadersA" _
    >(ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength
    >As Long, _
    >ByVal lModifiers As Long) As Integer
    >
    >' Flags to modify the semantics of this function. Can be a combination of
    >these values:
    >
    >' Adds the header only if it does not already exist; otherwise, an error
    >is
    >returned.
    >Public Const HTTP_ADDREQ_FLAG_ADD_IF_NEW = &H10000000
    >
    >' Adds the header if it does not exist. Used with REPLACE.
    >Public Const HTTP_ADDREQ_FLAG_ADD = &H20000000
    >
    >' Replaces or removes a header. If the header value is empty and the header
    >is found,
    >' it is removed. If not empty, the header value is replaced
    >Public Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000
    >
    >--
    >
    >-Julian Milano
    >
    >
    >
    >



Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
HTML5 Development Center
 
 
FAQ
Latest Articles
Java
.NET
XML
Database
Enterprise
Questions? Contact us.
C++
Web Development
Wireless
Latest Tips
Open Source


   Development Centers

   -- Android Development Center
   -- Cloud Development Project Center
   -- HTML5 Development Center
   -- Windows Mobile Development Center