循环通过FTP文件夹下载文件VBA？

Question

我正在尝试循环通过使用以下 HTML 进行上传（文件夹/文件）的 FTP：

<pre>
<a href="/Example%20Folder/">Example Folder</a>
<a href="/Example%20File.xlsx">Example File.xlsx</a>
<a href="/Example%20Folder/Example%20File%20In%20Folder.xlsx">Example File In Folder.xlsx</a>
</pre>

我的代码尝试遍历站点上的所有文件夹（如果存在）并下载每个文件。问题是进入然后导航 back 到根目录后，我收到错误 70“Permission Denied”。相关代码如下：

Dim fso As New FileSystemObject
Dim oFolder, oSubfolder, oFile, bButton, queue As Collection
Dim oFileName As String
Dim processed As Boolean
Dim processedList As String
Dim toPath As String
Dim fromPath As String
Dim HWNDsrc As Long

Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection

queue.Add IE.Document.getElementsByTagName("a")

Do While queue.Count > 0 
   Set oFolder = queue(1)
   Set bButton = Nothing
   queue.Remove 1

   If Right(oFolder, 1) = "/" Then 'Check if the link is a folder ***ERROR HERE
     IE.Navigate oFolder
     Do While IE.Busy: DoEvents: Loop
     Do Until IE.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop 'readystate=4
     Set bButton = IE.Document.getElementById("goParent") 'Back button in browser
     Set oFolder = IE.Document.getElementsByTagName("a")
   End If

  For Each oSubfolder In oFolder
    If Right(oSubfolder, 1) = "/" Then
      queue.Add oSubfolder
    End If
  Next oSubfolder

  For Each oFile in oFolder 
    If InStr(oFile, ".") > 0 Then 'Check if link is file
      oFileName = Replace(Right(oFile, Len(oFile) - InStrRev(oFile, "/")), "%20", " ")
      fromPath = DOWNLOADS_FOLDER & oFileName 'downloads_folder defined earlier
      toPath = DESTINATION_FOLDER & oFileName 'destination_folder defined earlier

      With IE
        .Visible = True
        .Navigate oFile
      End With

      HWNDsrc = IE.HWND
      SetForegroundWindow HWNDsrc
      Sleep (1500)
      Application.SendKeys ("%s") 'Used because URLDownloadToFile can't handle FTP
      Do While IE.Busy: DoEvents: Loop
      Do Until IE.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop

      processed = True
      processedList = processedList & vbCrLf & _
                      oFileName

      If Len(Dir(toPath)) = 0 Then
        fso.MoveFile fromPath, toPath
      End If
    End If
  Next oFile

  If Not bButton Is Nothing Then 'If in subfolder, return to main directory
    With IE
      bButton.Click
      Do While .Busy: DoEvents: Loop
      Do Until .ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
    End With
  End If
Loop

执行 bButton 代码块后，无法打印 oFolder 并返回“Permission denied”错误。有没有办法解决这个问题？

Answer 1

由于您的问题在 FTP 页面内，请尝试在下面进行修改以适合您的下载。这只是为了演示链接提取过程，没有实现下载和响应来自IE的凭据提示。

下面的代码将提取所有文件链接并显示它们，当计数高于 ma​​xCount 时，它会停止递归到文件夹中（您可能希望保留它以用于调试目的）。

Const maxCount = 20
Const sRootURL As String = "<Your FTP Site>" ' e.g. "ftp://ftp.kernel.org/"
Dim oIE As Object, oFolderLinks As Object, oFileLinks As Object

Sub IE_FTP()
    Set oFolderLinks = CreateObject("System.Collections.ArrayList") ' .NET Runtime required
    Set oFileLinks = CreateObject("System.Collections.ArrayList") ' .NET Runtime required
    Set oIE = CreateObject("InternetExplorer.Application")
    oIE.Visible = True ' For Debug Purposes
    oIE.Silent = True ' Disable Popups
    ExtractLinks sRootURL
    For i = 1 To oFileLinks.Count
        Debug.Print "[" & i & "] " & oFileLinks(i - 1)
        ' You may want to create and call a Download Sub for each of these file links
    Next
    Set oIE = Nothing
    oFileLinks.Clear
    Set oFileLinks = Nothing
    oFolderLinks.Clear
    Set oFolderLinks = Nothing
End Sub

Private Sub ExtractLinks(sURL As String)
    On Error Resume Next
    Dim oItem As Object, sLink As String, oLocalLinks As Object, i As Long

    If oFileLinks.Count > maxCount Then Exit Sub
    With oIE
        .Navigate2 sURL
        If Err.Number = 0 Then
            Set oLocalLinks = CreateObject("System.Collections.ArrayList") ' .NET Runtime required
            Do While .Busy
            Loop
            ' Add current URL to Folder Links
            If Not oFolderLinks.contains(sURL) Then
                oFolderLinks.Add sURL
            End If
            ' Extract all local links on this page
            For Each oItem In .Document.getElementsByTagName("A")
                sLink = CStr(oItem)
                If Not oLocalLinks.contains(sLink) Then
                    oLocalLinks.Add sLink
                End If
            Next
            For i = 0 To oLocalLinks.Count - 1
                sLink = oLocalLinks(i)
                If Right(sLink, 1) = "/" Then
                    ' Navigate to all Local Links that are not already in Folder Links
                    If Not oFolderLinks.contains(sLink) Then ExtractLinks sLink
                Else
                    ' sLink is not a folder, add this to File Links
                    If Not oFileLinks.contains(sLink) Then
                        oFileLinks.Add sLink
                    End If
                End If
            Next
            oLocalLinks.Clear
            Set oLocalLinks = Nothing
        Else
            Debug.Print "ERR(" & Err.Number & "):" & Err.Description & " | " & sURL
            Err.Clear
        End If
    End With
End Sub

Answer 2

如果有人感兴趣，@PatricK 让我意识到一个错误，我最终通过使用 CStr() 函数解决了我的问题，如下所示：

Dim fso As New FileSystemObject
Dim oFolder, oFile, bButton, queue As Collection
Dim oFileName As String
Dim EMAIL_BODY As String
Dim processed As Boolean
Dim processedList As String
Dim toPath As String
Dim fromPath As String
Dim HWNDsrc As Long

Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
Set oFolder = IE.Document.getElementsByTagName("a")

'Make sure there is something in the queue
For Each oFile In oFolder 
    If Right(oFile, 1) = "/" Or InStr(oFile, ".") > 0 Then
        queue.Add FTP_URL
        Exit For
    End If
Next oFile

Do While queue.count > 0
    IE.Navigate queue(1)
    Sleep (700)
    Set oFolder = IE.Document.getElementsByTagName("a")
    Set bButton = Nothing
    queue.Remove 1

    For Each oFile In oFolder
        'Format name to allow downloads
        oFileName = Replace(Right(oFile, Len(oFile) - InStrRev(oFile, "/")), "%20", " ")
        fromPath = DOWNLOADS_FOLDER & oFileName
        toPath = DESTINATION_FOLDER & oFileName

        If InStr(oFile, ".") > 0 And Len(Dir(toPath)) = 0 Then 'Check if link is new file
            IE.Visible = True
            IE.Navigate oFile

            'Handle IE "Open", "Save", "Close" prompt
            Sleep (1500)
            HWNDsrc = IE.HWND
            SetForegroundWindow HWNDsrc
            Application.SendKeys ("%s") 'URLDownloadToFile does not work with FTP
            Sleep (1500)
            fso.MoveFile fromPath, toPath

            processed = True
            processedList = processedList & vbCrLf & _
                            oFileName
        ElseIf Right(oFile, 1) = "/" Then ' Check if link is subfolder
            queue.Add CStr(oFile) '**Converting to string prevents Permission Error
        End If
    Next oFile
Loop

IE.Quit