extract directory contents from ftp site using vba 
Author Message
 extract directory contents from ftp site using vba

I'd like to use VBA to connect to an FTP site and get the
contents loaded into my database (file name, modified
date, etc.).  Is there code or a code example that I can
reference to learn how to do this?


Sat, 31 Jan 2004 02:13:32 GMT  
 extract directory contents from ftp site using vba
Sure... Look at sEnumFTPFolder proc in the code below.
Watch out for weird line wraps

<pre>

' **** Code Start ****
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 * 260
    cAlternate As String * 16
End Type

Private Type URL_COMPONENTS
  dwStructSize As Long
  lpszScheme As String
  dwSchemeLength As Long
  nScheme As Long
  lpszHostName As String
  dwHostNameLength As Long
  nPort As Long
  lpszUserName As String
  dwUserNameLength As Long
  lpszPassword As String
  dwPasswordLength As Long
  lpszUrlPath As String
  dwUrlPathLength As Long
  lpszExtraInfo As String
  dwExtraInfoLength As Long
End Type

Private Declare Function InternetConnect _
    Lib "WinInet.dll" Alias "InternetConnectA" _
    (ByVal hInternet As Long, _
    ByVal lpszServerName As String, _
    ByVal nServerPort As Integer, _
    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 WIN32_FIND_DATA, _
    ByVal dwFlags As Long, _
    ByVal dwContext As Long) _
    As Long

Private Declare Function InternetFindNextFile _
    Lib "WinInet.dll" Alias "InternetFindNextFileA" _
    (ByVal hFind As Long, _
    lpvFindData As Any) _
    As Long

Private Declare Function InternetCloseHandle _
    Lib "WinInet.dll" _
    (ByVal hInternet As Long) _
    As Long

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

Private Declare Function InternetGetLastResponse _
    Lib "WinInet.dll" Alias "InternetGetLastResponseInfoA"
_
    (lpdwError As Long, _
    ByVal lpszBuffer As String, _
    lpdwBufferLength As Long) _
    As Long

Private Declare Function LoadLibraryEx _
    Lib "kernel32" Alias "LoadLibraryExA" _
    (ByVal lpLibFileName As String, _
    ByVal hFile As Long, _
    ByVal dwFlags As Long) _
    As Long

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, _
    Arguments As Long) _
    As Long

Private Declare Function FreeLibrary _
    Lib "kernel32" _
    (ByVal hLibModule As Long) _
    As Long

Private Declare Function InternetCanonicalizeUrl _
    Lib "WinInet.dll" Alias "InternetCanonicalizeUrlA" _
    (ByVal lpszUrl As String, _
    ByVal lpszBuffer As String, _
    lpdwBufferLength As Long, _
    ByVal dwFlags As Long) _
    As Long

Private Declare Function InternetCrackUrl _
    Lib "WinInet.dll" Alias "InternetCrackUrlA" _
    (ByVal lpszUrl As String, _
    ByVal dwUrlLength As Long, _
    ByVal dwFlags As Long, _
    lpUrlComponents As URL_COMPONENTS) _
    As Long

Private Declare Function FtpSetCurrentDirectory _
    Lib "wininet" Alias "FtpSetCurrentDirectoryA" _
    (ByVal hFtpSession As Long, _
    ByVal lpszDirectory As String) _
    As Long

Private Const INTERNET_FLAG_RESYNCHRONIZE = &H800
Private Const ERROR_NO_MORE_FILES = 18
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Const INTERNET_SERVICE_FTP = 1
Private Const INTERNET_INVALID_PORT_NUMBER = 0
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_ERROR_BASE = 12000
Private Const INTERNET_SCHEME_UNKNOWN = -1
Private Const ICU_BROWSER_MODE = &H2000000
Private Const ERROR_INTERNET_EXTENDED_ERROR =
(INTERNET_ERROR_BASE + 3)
Private Const LOAD_LIBRARY_AS_DATAFILE = 2&
Private Const MAX_BUFFER = 1024
Private Const ERR_GENERIC = vbObjectError + 5555
Private Const ICU_ESCAPE = &H80000000
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200&
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800&
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF

Sub sEnumFTPFolder()
On Error GoTo ErrHandler
Dim hConnect As Long, hInet As Long
Dim lngFlags As Long, lngSC As Long
Dim tURLInfo As URL_COMPONENTS
Dim colFolders As VBA.Collection
Dim colFiles As VBA.Collection
Dim i As Integer
Const USER_NAME_ANONYMOUS = "anonymous"

Const URL_FTP = "ftp://ftp.microsoft.com/bussys"

    lngFlags = INTERNET_FLAG_PASSIVE

    If (fParseURL(tURLInfo, URL_FTP)) Then
        hInet = InternetOpen( _
                    "VBAFTPEnumerator", _
                    INTERNET_OPEN_TYPE_PRECONFIG, _
                    vbNullString, _
                    vbNullString, _
                    0)

        hConnect = InternetConnect( _
                            hInet, _
                            tURLInfo.lpszHostName, _
                            INTERNET_INVALID_PORT_NUMBER, _
                            USER_NAME_ANONYMOUS, _
                            USER_PASSWORD_ANONYMOUS, _
                            INTERNET_SERVICE_FTP, _
                            lngFlags, _
                            lngSC)
        If (hConnect = 0) Then
            With Err
                .Raise .LastDllError, "sEnumFTPFolder",
fInetError(.LastDllError)
            End With
        End If
    End If

    Set colFolders = New VBA.Collection
    Set colFiles = New VBA.Collection

    Call ChangeDirectory(hConnect, tURLInfo.lpszUrlPath)

    Call sEnumerateFolder(hConnect, _

tURLInfo.lpszUrlPath, _
                                        colFolders, _
                                        colFiles)

    Debug.Print "Folders found at " & URL_FTP & ": "
    For i = 1 To colFolders.Count
        Debug.Print Space$(5) & colFolders(i)
    Next
    Debug.Print "Files found at " & URL_FTP & ": "
    For i = 1 To colFiles.Count
        Debug.Print Space$(5) & colFiles(i)
    Next
    Debug.Print "-------------------------------"

    Set colFiles = Nothing
    Set colFolders = Nothing
    Call InternetCloseHandle(hConnect)
    Call InternetCloseHandle(hInet)
    Exit Sub
ErrHandler:
    Call InternetCloseHandle(hConnect)
    Call InternetCloseHandle(hInet)
    With Err
        MsgBox "Error: " & .Number & vbCrLf
& .Description, _
            vbCritical Or vbOKOnly, .Source
    End With
End Sub

Private Sub ChangeDirectory(hConnect As Long, _
                                            ByVal NewPath
As String)
On Error GoTo ErrHandler
Dim lngRet As Long
Dim astrNames() As String, i As Integer
Const vbKeySlash = "/"

    If (Len(NewPath) = 1 And StrComp(NewPath, vbKeySlash,
vbTextCompare) = 0) Then
        ReDim astrNames(0)
        astrNames(0) = vbKeySlash
    Else
        astrNames = Split(NewPath, vbKeySlash)
    End If

    For i = LBound(astrNames) To UBound(astrNames)
        If (Len(astrNames(i))) Then
            lngRet = FtpSetCurrentDirectory(hConnect,
astrNames(i) & vbKeySlash)
            If (lngRet = 0 And (Err.LastDllError)) Then
                With Err
                    .Raise .LastDllError, "ChangeDirectory"
, fInetError(.LastDllError)
                End With
            End If
        End If
    Next

    Exit Sub
ErrHandler:
    With Err
        .Raise .Number, .Source, .Description, .HelpFile, .
HelpContext
   End With
End Sub

Private Sub sEnumerateFolder(hConnect As Long, _

strFolderName As String, _
                                                colFolders
As VBA.Collection, _
                                                colFiles
As VBA.Collection, _
                                                Optional
strSearchArg As String = "*.*")
On Error GoTo ErrHandler
Dim tDirInfo As WIN32_FIND_DATA
Dim hDir As Long, lngRet As Long

    hDir = FtpFindFirstFile(hConnect, strSearchArg, _
                                tDirInfo,
INTERNET_FLAG_RESYNCHRONIZE, 0)
    If Not (CBool(hDir)) Then
        If (Err.LastDllError <> ERROR_NO_MORE_FILES) Then
            ' exit
        Else
            ' no files
        End If
    Else
        Set colFolders = New VBA.Collection
        Set colFiles = New VBA.Collection
        If (tDirInfo.dwFileAttributes =
FILE_ATTRIBUTE_DIRECTORY) Then
            colFolders.Add fTrimNull(tDirInfo.cFileName)
        Else
            colFiles.Add fTrimNull(tDirInfo.cFileName)
        End If

        lngRet = InternetFindNextFile(hDir, tDirInfo)
        If (CBool(lngRet) And Err.LastDllError <>
ERROR_NO_MORE_FILES) Then
            Do While (lngRet > 0 And Err.LastDllError <>
ERROR_NO_MORE_FILES)
                With tDirInfo
                    If (.dwFileAttributes =
FILE_ATTRIBUTE_DIRECTORY) Then
                        colFolders.Add fTrimNull
(.cFileName)
                    Else
                        colFiles.Add fTrimNull(.cFileName)
                    End If
                End With

                lngRet = InternetFindNextFile(hDir,
tDirInfo)
            Loop
        End If
    End If
    Call InternetCloseHandle(hDir)
    Exit Sub
ErrHandler:
    Call InternetCloseHandle(hDir)
    With Err
        If (.Number <> ERR_GENERIC) Then
            .Raise .Number, .Source, .Description, .HelpFil
e, .HelpContext
        End If
    End With
End Sub

Private Static Function fTrimNull(ByVal strIn As String)
As String
Dim intPos As Integer
    intPos = InStr(1, strIn, vbNullChar,
...

read more »



Mon, 02 Feb 2004 22:04:04 GMT  
 
 [ 2 post ] 

 Relevant Pages 

1. List the contents of an FTP site in VBA

2. ITC crashes on FTP Site with a empty directory

3. Default FTP Site directory?

4. Using VB to extract content from System Administrator underliverable messages

5. FTP Help with SITE Command for IBM Mainframe Server Using VB

6. Displaying directory contents using getfolder

7. Add FTP site operators using ADSI and VBscript

8. FTP - Get File Date from FTP Site

9. Display web site directory in ListBox control using Inet

10. Internet Transfer Control - Cannot FTP to Intranet FTP sites

11. Extract photograph from within Access Database using VBA?

12. Extracting Internet headers using VBA?

 

 
Powered by phpBB® Forum Software