VB Forum / General 2 / October 2004

If you're using FTP you should be able to use this. Hopefully the word-wrap
won't be too severe.

Option Explicit

'persistent handle to the internet
Private hInternet As Long

'persistent handle internet connection
Private hConnect As Long

'default FTP login data
Private Const sFtpUserName = "anonymous"
Private Const sFtpPassword = "yourname@someisp.com"

Private Const sSlash = "/"

Private Const MAX_PATH  As Long = 260
Private Const MAXDWORD = &HFFFFFFF

Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Const INTERNET_DEFAULT_FTP_PORT = 21
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_FLAG_EXISTING_CONNECT = &H20000000
Private Const INTERNET_SERVICE_FTP = 1
Private Const FTP_TRANSFER_TYPE_UNKNOWN = &H0
Private Const GENERIC_READ = &H80000000

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

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

Private Declare Function InternetOpen Lib "Wininet.dll" _
  Alias "InternetOpenA" _
 (ByVal lpszAgent As String, _
  ByVal dwAccessType As Long, _
  ByVal lpszProxyName As String, _
  ByVal lpszProxyBypass As String, _
  ByVal dwFlags As Long) As Long

Private Declare Function InternetCloseHandle Lib "Wininet.dll" _
  (ByVal hEnumHandle As Long) As Long

Private Declare Function InternetConnect 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, _
  ByVal dwContext As Long) As Long

Private Declare Function FtpFindFirstFile Lib "Wininet.dll" _
  Alias "FtpFindFirstFileA" _
 (ByVal hConnect As Long, _
  ByVal lpszSearchFile As String, _
  lpFindFileData As Any, _
  ByVal dwFlags As Long, _
  ByVal dwContext As Long) As Long

Private Declare Function FtpGetCurrentDirectory Lib "Wininet.dll" _
  Alias "FtpGetCurrentDirectoryA" _
 (ByVal hConnect As Long, _
  ByVal lpszCurrentDirectory As String, _
   lpdwCurrentDirectory As Long) As Long

Private Declare Function FtpGetFileSize Lib "Wininet.dll" _
 (ByVal hConnect As Long, _
  lpdwFileSizeHigh As Long) As Long

Private Declare Function FtpOpenFile Lib "Wininet.dll" _
  Alias "FtpOpenFileA" _
 (ByVal hConnect As Long, _
  ByVal lpszFileName As String, _
  ByVal dwAccess As Long, _
  ByVal dwFlags As Long, _
  ByVal dwContext As Long) As Long

Private Declare Function FtpSetCurrentDirectory Lib "Wininet.dll" _
  Alias "FtpSetCurrentDirectoryA" _
 (ByVal hConnect As Long, _
  ByVal lpszDirectory As String) As Long

Private Sub Command1_Click()

  Dim sPathAndFileOnly As String
  Dim sFullPathToRemoteFile As String
  Dim sFullPathToRemoteFiles() As String
  Dim sRemoteServerName As String

  Dim wfd As WIN32_FIND_DATA
  Dim hFindConnect As Long
  Dim hFind As Long
  Dim hFTPFile As Long

  sRemoteServerName = "ftp2.freebsd.org"
  sFullPathToRemoteFile =
"ftp2.freebsd.org/pub/FreeBSD/development/FreeBSD-CVS/supfile.cvsup"
  sPathAndFileOnly = "/pub/FreeBSD/development/FreeBSD-CVS/supfile.cvsup"

  hConnect = GetFTPConnection(sRemoteServerName)

  If hConnect <> 0 Then

     sFullPathToRemoteFiles() = Split(sFullPathToRemoteFile, "/")

     If UBound(sFullPathToRemoteFiles) > 0 Then

        If FTPDecendDirs(sFullPathToRemoteFiles()) = True Then

           Print "looking in :", sPathAndFileOnly

           hFindConnect = GetInetConnectHandle(sRemoteServerName)

           If hFindConnect Then

              hFind = FtpFindFirstFile(hFindConnect, _
                                       sPathAndFileOnly, wfd, _
                                       INTERNET_FLAG_RELOAD Or _
                                       INTERNET_FLAG_NO_CACHE_WRITE, 0&)

                 If hFind Then

                    hFTPFile = FtpOpenFile(hFindConnect, _
                                           sPathAndFileOnly, _
                                           GENERIC_READ, _
                                           FTP_TRANSFER_TYPE_UNKNOWN, _
                                           0&)

                    If hFTPFile > 0 Then

                       Print "The file size is:", GetFileSize(hFTPFile)

                       InternetCloseHandle hFTPFile
                       hFTPFile = 0

                    End If  'hFTPFile
                 End If  'hFind

                 InternetCloseHandle hFind

           End If  'hFindConnect

           InternetCloseHandle hFindConnect

        End If  'FTPDecendDirs
     End If 'UBound(sFullPathToRemoteFiles

    'clean up
     Call InternetCloseHandle(hConnect)
     Call InternetCloseHandle(hInternet)

     hInternet = 0
     hConnect = 0

  End If

End Sub

Private Function FTPDecendDirs(sRemoteFiles() As String) As Boolean

 'given an FTP path, dig down through
 'each subfolder until in the last one

  Dim cnt As Long
  Dim thisdir As String
  Dim firstdir As Long
  Dim lastdir As Long

  firstdir = 1
  lastdir = UBound(sRemoteFiles) - 1

  If lastdir - firstdir <> 0 Then

     Do

        cnt = cnt + 1

       'retrieve the current FTP path
       'using GetFTPDirectory
        thisdir = GetFTPDirectory(hConnect)

       'qualify it if necessary, and append
       'the new path to it
        If Right$(thisdir, 1) <> sSlash Then
           thisdir = thisdir & sSlash & sRemoteFiles(cnt)
        Else
           thisdir = thisdir & sRemoteFiles(cnt)
        End If

       'Set the new path and continue
     Loop While (cnt < lastdir) And _
                FtpSetCurrentDirectory(hConnect, thisdir)

     FTPDecendDirs = thisdir & "/" = GetFTPDirectory(hConnect)

  End If

End Function

Private Function GetInetConnectHandle(ByVal sServerName As String) As Long

  Dim tmp As Long

 'GetInetConnectHandle obtains a new
 'handle expressly for use with the
 'FtpFindFirstFile and APIs.
 '
 'Care must be taken to close only the handle
 'returned by this function once the listing
 'of the directory has been obtained.
 '
 'A temporary variable is used here
 'to reduce line length
  If hInternet Then

    'Pass the same server as with other
    'calls, along with the requisite username
    'and password. If the site being accessed
    'allows anonymous login, set username
    'as 'anonymous' and the password as the
    'user's email address.

     tmp = InternetConnect(hInternet, _
                           sServerName, _
                           0&, _
                           sFtpUserName, _
                           sFtpPassword, _
                           INTERNET_SERVICE_FTP, _
                           INTERNET_FLAG_EXISTING_CONNECT Or _
                           INTERNET_FLAG_PASSIVE, _
                           &H0)

   '  tmp = InternetConnect(hInternet, _
                           sServerName, _
                           0&, _
                           sFtpUserName, _
                           sFtpPassword, _
                           INTERNET_SERVICE_FTP, _
                           INTERNET_FLAG_EXISTING_CONNECT, _
                           &H0)

  End If

 'return the connection handle
  GetInetConnectHandle = tmp

End Function

Private Function GetFTPDirectory(hConnect As Long) As String

  Dim nCurrDir As Long
  Dim sCurrDir As String

 'FtpGetCurrentDirectory retrieves the current
 'directory for the connection. Using this API
 'means its not necessary to track the directory
 'hierarchy for navigation.

 'pad the requisite buffers
  sCurrDir = Space$(256)
  nCurrDir = Len(sCurrDir)

 'FtpGetCurrentDirectory returns 1 if successful
  If FtpGetCurrentDirectory(hConnect, _
                            sCurrDir, _
                            nCurrDir) = 1 Then

    'return a properly qualified path
     sCurrDir = StripNull(sCurrDir)

     If Right$(sCurrDir, 1) <> sSlash Then
        GetFTPDirectory = sCurrDir & sSlash
     Else
        GetFTPDirectory = sCurrDir
     End If

  End If

End Function

Private Function GetFTPConnection(ByVal sRemoteServerName As String) As Long

  Screen.MousePointer = vbHourglass

 'Begin the FTP process by obtaining a
 'handle to an internet session. This
 'handle will be used in subsequent calls,
 'so its declared as a form-wide variable.
  hInternet = InternetOpen("VBnet FTP Transfer", _
                            INTERNET_OPEN_TYPE_DIRECT, _
                            vbNullString, _
                            vbNullString, _
                            INTERNET_FLAG_NO_CACHE_WRITE)

 'If a handle was obtained, the next step is
 'to obtain a connection handle that will be
 'used for all operations except the FTP
 'directory navigation. The MSDN states that
 'the handle used by FtpFindFirstFile and subsequent
 'file calls can not be reused for additional
 'navigation or other operations. This handle
 'then will be used for all functions except
 'the directory listings.
  If hInternet Then

    'and get a connection handle
     hConnect = InternetConnect(hInternet, _
                                sRemoteServerName, _
                                INTERNET_DEFAULT_FTP_PORT, _
                                sFtpUserName, _
                                sFtpPassword, _
                                INTERNET_SERVICE_FTP, _
                                INTERNET_FLAG_EXISTING_CONNECT Or _
                                INTERNET_FLAG_PASSIVE, _
                                &H0)

    'return the handle
     GetFTPConnection = hConnect

  Else

     InternetCloseHandle hInternet

  End If

  Screen.MousePointer = vbDefault

End Function

Private Function GetFileSize(hFTPFile As Long) As Long

  Dim nFileSizeHigh As Long
  Dim nFileSizeLow As Long

  nFileSizeLow = FtpGetFileSize(hFTPFile, nFileSizeHigh)
  GetFileSize = FormatNumber(nFileSizeHigh * (MAXDWORD + 1) + nFileSizeLow,
2)

End Function

Private Function StripNull(item As String)

  'Return a string without the chr$(0) terminator.
   Dim pos As Integer

   pos = InStr(item, Chr$(0))

   If pos Then
     StripNull = Left$(item, pos - 1)
   Else
     StripNull = item
   End If

End Function