我试图遍历使用以下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>
我的代码尝试遍历网站上的所有文件夹（如果存在）并下载每个文件。问题是，在输入返回到根目录后，我收到错误70＆＃34;权限被拒绝。＆＃34;相关代码可以在下面找到：
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并返回＆＃34; Permission denied＆＃34;错误。有什么方法可以解决这个问题吗？
答案 0 :(得分：0)
由于您的问题在FTP页面内，请尝试修改以下内容以适合您的下载。这仅用于演示链接提取过程，尚未实现对IE凭据提示的下载和响应。
下面的代码将提取所有文件链接并显示它们，当计数高于 maxCount 时，它会停止递归到文件夹中（您可能希望将其保留用于调试目的）。
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
答案 1 :(得分：0)
如果有人有兴趣，@ 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